/*execute module, called to execute code in the form of evb's */ /* symbol descriptor headers as structures and unions */ #include #include #include #include #include "ana_structures.h" #include "defs.h" extern struct sym_desc sym[]; extern struct ana_subr_struct ana_subr[]; extern int num_internal_syms; extern int rupt_flag; extern int subr_ptr_table[]; extern int vfix_top; extern int temp_base, sps_base, edb2_base, edb_base; extern int max_sp, max_temp; extern jmp_buf sjbuf; extern int ana_type_size[]; extern unsigned short *user_subr_ptrs[], *user_func_ptrs[], *user_code_ptrs[]; extern struct user_subr_table *user_subrs_nf[]; extern struct user_subr_table *user_funcs_nf[]; extern struct user_subr_table *user_code_nf[]; extern int num_ana_subr, num_ana_func, delete_symbol(); extern int range_warn_flag; extern char *strsave(); int *return_sym_ptr; /*used by return for symbol returned in function */ int line_count [100], level, nroutine, levelp; int stop_flag; /*used to stop ANA after current execution */ int stop_file; int narg_user; int mention_recursives = 1; #define next_level \ if ( ++level > 100 ) return execute_error(2); line_count[level]=0; #define down_level \ if ( --level <0 ) return execute_error(3); #define next_line line_count[level]++; #define get_evb_ptr(ns) \ narg = (int) sym[ns].xx;\ if (narg<5) ap= &sym[ns].spec.evb.args[0];\ else ap = (unsigned short *) sym[ns].spec.array.ptr; unsigned short *ap; union types_ptr { byte *b; short *w; int *l; float *f; double *d;}; /*------------------------------------------------------------------------- */ int ana_return(narg,ps) /* returns from subr or func */ /* optional return symbol */ int narg,ps[]; { if ( return_sym_ptr == NULL ) return 0x1002; if (narg) *return_sym_ptr = ps[0]; else *return_sym_ptr = 0; return 0x1002; } /*end of return */ /*------------------------------------------------------------------------- */ int execute_error(n) /* handle errors */ int n; { printf("execution error: "); switch (n) { case 1: printf("invalid EDB passed to EXECUTE\n"); break; case 2: printf("# of levels exceeds 100\n"); break; case 3: printf("(X) an impossible error\n"); break; case 4: printf("lhs of REPLACE is a constant\n"); break; case 5: printf("illegal symbol on RHS of REPLACE\n"); break; case 6: printf("conditional does not evaluate to a scalar\n"); break; case 7: printf("undefined symbol in expression (eval)\n"); break; case 8: printf("illegal symbol class in expression (eval)\n"); break; case 9: printf("bad binary op in eval (this is impossible)\n"); break; case 10: printf("argument was not a scalar\n"); break; case 11: printf("more than 8 dimensions specified\n"); break; case 12: printf("illegal scalar type (impossible?)\n"); break; case 13: printf("memory allocation failure\n"); break; case 14: printf("problem initializing counter in FOR loop\n"); break; case 15: printf("problem with final counter value in FOR loop\n"); break; case 16: printf("problem with increment in FOR loop\n"); break; case 17: printf("problem deleting a symbol (impossible?)\n"); break; case 18: printf("illegal variable type (string?) for unary negative\n"); break; case 19: printf("(X) symbol passed to array_clone not an array\n"); break; case 20: printf("(X) no memory allocated to symbol in array_clone\n"); break; case 21: printf("(X) symbol passed to string_clone not a string\n"); break; case 22: printf("INDGEN accepts only arrays or scalars\n"); break; case 23: printf("(X) malloc failure creating argument list (how did you do this?)\n"); break; case 24: printf("incompatible arrays in expression\n"); break; case 25: printf("(X) error in fixed_string count\n"); break; case 26: printf("illegal action with a string (kinky?)\n"); break; case 27: printf("(X) mysterious class in binary operation or function\n"); break; case 28: printf("(X) illegal variable type in dump\n"); break; case 29: printf("floating point values illegal in logical expression\n"); break; case 30: printf("illegal variable type (string?) in math function\n"); break; case 31: printf("subscripted variable is not an array or string\n"); break; case 32: printf("illegal variable type\n"); break; case 33: printf("symbol table overflow for subscript pointers\n"); break; case 34: printf("symbol table overflow for temporaries\n"); break; case 35: printf("subscript out of range\n"); break; case 36: printf("too many subscripts\n"); break; case 37: printf("invalid rearrange attempted\n"); break; case 38: printf("(X)impossible error in ana_sub_arg\n"); break; case 39: printf("illegal subscript type\n"); break; case 40: printf("(X)scalar_scratch_copy got a non-scalar\n"); break; case 41: printf("undefined subroutine\n"); break; case 42: printf("recursive subroutine calls not allowed\n"); break; case 43: printf("too many arguments passed to subroutine\n"); break; case 44: printf("(X)bad return status handed to escaper\n"); break; case 45: printf("in user subroutine "); break; case 46: printf("(X) illegal (impossible) scalar type\n"); break; case 47: printf("inappropiate string argument\n"); break; case 48: printf("undefined argument in a function\n"); break; case 49: printf("illegal variable type (string?) in DSUM function\n"); break; case 50: printf("illegal variable type (string?) in RUNSUM function\n"); break; case 51: printf("illegal variable type (string?) in SDEV function\n"); break; case 52: printf("illegal variable type (string?) in SWAB function\n"); break; case 53: printf("undefined argument in TYPE\n"); break; case 54: printf("error in argument for DUMP\n"); break; case 55: printf("wrong number of arguments passed\n"); break; case 56: printf("(X) bad rhs in replacement statement\n"); break; case 57: printf("bad argument class in CONCATENATION\n"); break; case 58: printf("illegal combination of string with non-string in CONCATENATION\n"); break; case 59:printf("illegal combination of dimensions in CONCATENATION\n"); break; case 60: printf("undefined named block: "); break; case 61: printf("within named block: "); break; case 62: printf("no dimensions specified for REDIM\n"); break; case 63: printf("too many dimensions specified\n"); break; case 64: printf("array too small for requested REDIM\n"); break; case 65: printf("zero or negative dimension\n"); break; case 66: printf("argument not an array\n"); break; case 67: printf("first argument in REDIM is not an array\n"); break; case 68: printf("undefined function: "); break; case 69: printf("too many arguments passed to user function\n"); break; case 70: printf("string argument required\n"); break; case 71: printf("subscripted variable on lhs is not an array\n"); break; case 72: printf("too many subscripts in lhs of INSERT statement\n"); break; case 73: printf("illegal subscript in lhs of INSERT statement\n"); break; case 74: printf("negative subscript\n"); break; case 75: printf("illegal mixture in INSERT statement\n"); break; case 76: printf("argument is not a square 2-D matrix\n"); break; case 77: printf("dimensions of arrays are incompatiable\n"); break; case 78: printf("illegal power specified for poly. fit (range 1-10)\n"); break; case 79: printf("incompatiable LU decomp and rhs in dsolve\n"); break; case 80: printf("inner dimen. byte count isn't a multiple of element length \n"); break; case 81: printf("reversal specified for non-existent dimension\n"); break; case 82: printf("duplicate index in REVERSE\n"); break; case 83: printf("illegal variable type\n"); break; case 84: printf("error opening file\n"); break; case 85: printf("out of range lun\n"); break; case 86: printf("lun already in use\n"); break; case 87: printf("more than 1 dimension implied for a string\n"); break; case 88: printf("compress or rearrange not supported for strings or symbol arrays\n"); break; case 89: printf("non-integer counter in NCASE\n"); break; case 90: printf("error writing file\n"); break; case 91: printf("hit EOF while reading\n"); break; case 92: printf("only 1-D or 2-D arrays accepted\n"); break; case 93: printf("malloc failure for pointer array in COMPRESS\n"); break; case 94: printf("LUN not open\n"); break; case 95: printf("REGRID array must be a non-trivial 2-D array\n"); break; case 96: printf("REGRID grids must be non-trivial 2-D arrays\n"); break; case 97: printf("x and y grids must be of same size\n"); break; case 98: printf("requested index exceeds dimension of array\n"); break; case 99: printf("error in argument list\n"); break; case 100: printf("argument must be a 3x3 array\n"); break; case 101: printf("argument not a 2-D array\n"); break; case 102: printf("displacement grid not in correct format\n"); break; case 103: printf("input arrays must match\n"); break; case 104: printf("argument destined to be returned is not atomic\n"); break; case 105: printf("fcwrite only accepts I*1 or I*2 arrays (I*4 on some)\n"); break; case 106: printf("file open for read only\n"); break; case 107: printf("argument must be a 1-D vector\n"); break; case 108: printf("bad expression\n"); break; case 109: printf("bad $CONTOURS array\n"); break; case 110: printf("INSERT only accepts 1 or 2 D arrays\n"); break; case 111: printf("I*2 input array required\n"); break; case 112: printf("error in associated variable index\n"); break; case 113: printf("failure in assoc var input (record too big?)\n"); break; case 114: printf("assoc. var (output) does not match array\n"); break; case 115: printf("failure in assoc var output\n"); break; case 116: printf("attempt to redefine a protected symbol\n"); break; case 117: printf("bad year in ephemeris call, must be 19xx or xx\n"); break; case 118: printf("I*1 input array required\n"); break; case 119: printf("I*2 or I*1 input array required\n"); break; case 120: printf("F*4 input array required\n"); break; case 121: printf("illegal format specified\n"); break; case 122: printf("malloc failure in ck_format_vars\n"); break; case 123: printf("malloc failure while creating temporary\n"); break; case 124: printf("arguments must be of same size\n"); break; case 125: printf("lookup table must be 256 long\n"); break; case 126: printf("error in string pointer insert\n"); break; case 127: printf("error in string pointer extract\n"); break; case 128: printf("summation not supported for string pointer subscripts\n"); break; case 129: printf("sprintf: argument for * field not a scalar\n"); break; case 130: printf("sprintf: more format specifiers than variable\n"); break; case 131: printf("sprintf: argument is not a scalar\n"); break; case 132: printf("internal error extending an array\n"); break; case 133: printf("I*4 input array required\n"); break; case 134: printf("error reading file\n"); break; case 135: printf("argument is not a symarr\n"); break; case 136: printf("argument is not a data cube or symarr\n"); break; case 137: printf("\n"); break; case 138: printf("\n"); break; default: printf("(X)undefined error code\n"); break; } return -1; } /*end of execute_error */ /*------------------------------------------------------------------------- */ int escaper(i) /*handle error and special escape exits */ int i; { if (i <= 0 ) return i; if (i > 2 ) return i-2; else return 1; } /*end of escaper */ /*------------------------------------------------------------------------- */ int execute(nsym) /* main execution routine */ /* nsym is the passed symbol to execute */ int nsym; { int i,j,iq,jq, *apout, narg, *arg_syms; unsigned short *aps; /* is someone trying to stop execution ? */ if (rupt_flag) { fprintf(stderr, "soft interupt, returning to top level\n"); rupt_flag = 0; return 0x1004; /* this causes a retall */ } //printf("nsym in execute = %d\n", nsym); if (nsym <= 0 ) return nsym; /* bounce errors through */ narg = (int) sym[nsym].xx; /*check if code and get type */ /*note, may need future support for execution strings here */ if (sym[nsym].class != 200) { printf("nsym = %d\n", nsym); printf("sym[nsym].class = %d (%#x)\n", sym[nsym].class); return execute_error(1); } clear_temps(); clear_sps(); //printf("sym[nsym].type = %d\n", sym[nsym].type); switch (sym[nsym].type) { case 0: return 1; /*no op case */ case 1: /*block of code */ next_level iq = (int) sym[nsym].xx; /*line count */ get_evb_ptr(nsym) /*a macro that gets narg and arg ptr */ /*loaded backwards, so pull out from the end */ aps = ap+(narg-1); while (narg) { if ( (iq = execute( (int) *aps-- )) != 1 ) /*normal return is 1 */ { down_level if ( iq >= 0x1000 ) return iq; else return escaper(iq); } /*printf("iq %d, level %d, line %d\n",iq, level, line_count[level]);*/ next_line narg--; } down_level; return 1; case 2: /*replace */ /*always 2 args, first is RHS and must be a evb or atomic */ iq = (int) sym[nsym].spec.evb.args[1]; /*lhs */ jq = eval ( (int) sym[nsym].spec.evb.args[0]); /*rhs */ if (jq < 0) return -1; return ana_replace(iq,jq); case 3: /*internal subr */ /*eval all the args and put in ana_arg_syms array, the subr is called with the # of args as the only arg, it then reads the symbols off the list */ get_evb_ptr(nsym) /*a macro that gets narg and arg ptr */ /*the last arg is the subr #, fetch it */ aps = ap+(narg-1); i = (int) *aps; /*i is subroutine # */ aps--; /*point to next to last in edb, args were loaded backwards, so this is first for subr*/ /*everybody needs his own private list of input symbols */ iq = --narg; /* actual # for subroutine call */ /* check arg count against tabulated allowed values */ if (narg < ana_subr[i].minargs || narg > ana_subr[i].maxargs) return subroutine_error(55, i); if (narg > 0) { if ( (arg_syms = (int *) malloc( narg * sizeof (int) )) == NULL) return execute_error(23); /*printf("malloc in execute, ptr = %d\n",arg_syms);*/ apout = arg_syms; while (iq) { /*eval all the arguments */ *apout = eval (*aps); /*printf("arg sym # %d\n",*apout);*/ aps--; apout++; iq--; } iq = (*ana_subr[i].ptr) (narg, arg_syms); /*call the subroutine */ /*printf("free in execute, ptr = %d\n",arg_syms);*/ free ( arg_syms ); /*free input symbol list */ } else { /*no argument case */ iq = (*ana_subr[i].ptr) (narg, &narg ); /*call the subroutine with narg=0 */ } if ( iq < 1 ) return subroutine_error(0, i); return iq; case 4: /*for loop */ /*a special case, has 5 arguments, used narg for the first */ return for_loop(nsym); case 5: /*insert */ /*a lhs with subscripts and a rhs */ return ana_insert(nsym); case 6: /*if statement */ iq = (int) sym[nsym].spec.evb.args[2]; /*condition */ if ( (j = test_it(iq)) < 0 ) return -1; /*check for error */ if ( j ) { /*test_it returns scalar value */ jq =(int) sym[nsym].spec.evb.args[1]; /*true case*/ return execute( jq ); } else { jq =(int) sym[nsym].spec.evb.args[0]; /*else case*/ if (jq ==0 ) return 1; return execute( jq ); } case 7: /*user subr */ return user_subr_exec(nsym); case 8: /*while ... do */ /*printf("start while\n");*/ jq = eval ( (int) sym[nsym].spec.evb.args[0]); /*statement */ /*printf("statement sym # %d\n",jq);*/ iq = (int) sym[nsym].spec.evb.args[1]; /*condition */ /*printf("condition sym # %d\n",iq);*/ while ( (j=test_it(iq))==1 ) { /*test_it returns scalar value */ i = execute( jq ); /*do the statement */ if ( i != 1 ) { /*check for escapes and errors */ if ( i == 0x1000 ) return 1; if ( i >= 0x1000 ) return i; return escaper(i); } } if ( j < 0 ) return -1; /*check for error */ return 1; case 9: /*do ... while */ jq = eval ( (int) sym[nsym].spec.evb.args[1]); /*statement */ iq = (int) sym[nsym].spec.evb.args[0]; /*condition */ do { i = execute( jq ); /*do the statement */ if ( i != 1 ) { /*check for escapes and errors */ if ( i == 0x1000 ) return 1; if ( i >= 0x1000 ) return i; return escaper(i); } } while ( (j=test_it(iq)) == 1 ); if ( j < 0 ) return -1; /*check for error */ return 1; case 10: /*return */ if ( (iq = sym[nsym].spec.evb.args[0]) == 0x1004 ) return -1; /*the 0x1004 case is retall, treat like an error without as much noise */ return iq; /*pass on */ case 11: /*case */ return ana_case(nsym); case 12: /*ncase */ return ana_ncase(nsym); case 13: /*repeat ... until */ /*like do ... while except continue if false */ jq = eval ( (int) sym[nsym].spec.evb.args[1]); /*statement */ iq = (int) sym[nsym].spec.evb.args[0]; /*condition */ do { i = execute( jq ); /*do the statement */ if ( i != 1 ) { /*check for escapes and errors */ if ( i == 0x1000 ) return 1; if ( i >= 0x1000 ) return i; return escaper(i); } } while ( (j=test_it(iq)) == 0 ); if ( j < 0 ) return -1; /*check for error */ return 1; case 14: /*named block */ return user_code_exec(nsym); } /*end of outer switch*/ } /*end of execute */ /*------------------------------------------------------------------------- */ int subroutine_error(k, fn) /* notifies about an error in a subroutine and identifies the name */ int k, fn; { if (k) execute_error(k); /*print message if number passed */ printf("*** error in subroutine %s\n", ana_subr[fn].name); return -1; } /*------------------------------------------------------------------------- */ int test_it(nsym) /*used for logical tests, atomizes nsym and returns a 0 or 1 or gens an error */ int nsym; { int iq; iq = eval ( nsym ); if ( sym[iq].class == 8 ) iq = class8_to_1(iq); if ( sym[iq].class != 1 ) { /*must eval to a scalar */ return execute_error(6); } switch (sym[iq].type) { case 0: return (sym[iq].spec.scalar.b!=0); case 1: return (sym[iq].spec.scalar.w!=0); case 2: return (sym[iq].spec.scalar.l!=0); case 3: return (sym[iq].spec.scalar.f!=0); case 4: return (sym[iq].spec.scalar.d!=0); default: return execute_error(5); } } /*------------------------------------------------------------------------- */ int ana_ncase(nsym) /*ncase execution */ int nsym; { int iq,jq,i, narg; unsigned short *ap, *aps; union scalar first, inc, last; get_evb_ptr(nsym) /*a macro that gets narg and arg ptr */ aps = ap + narg; /* get a scalar integer from the last arg in list (list is backwards) */ iq = eval( *(--aps) ); switch (sym[iq].class) { default: return execute_error(10); case 8: iq = class8_to_1(iq); case 1: /*scalar */ if (sym[iq].type !=2 ) iq = ana_long(1,&iq); } /* get the value for the case */ i = sym[iq].spec.scalar.l; /*printf("resultant i = %d\n",i);*/ if (i >= 0 && i < (narg-2) ) /* valid case */ return execute( *(aps - i -1) ); /* was there an else ? */ if ( *ap != 0 ) return execute(*ap); return 1; /* otherwise do nothing */ } /*------------------------------------------------------------------------- */ int ana_case(nsym) /*case execution */ int nsym; { int iq,jq,i, narg; unsigned short *ap, *aps; union scalar first, inc, last; get_evb_ptr(nsym) /*a macro that gets narg and arg ptr */ aps = ap + narg; /* loop through from the beginning (remember these are loaded backwards) */ narg = (narg - 1) / 2; while (narg--) { if ( i = test_it( *(--aps) ) == 1) return execute( * (--aps) ); if ( i < 0 ) return i; --aps; } /* was there an else ? */ if ( *ap != 0 ) return execute(*ap); return 1; /* otherwise do nothing */ } /*------------------------------------------------------------------------- */ int for_loop(nsym) /*for loop execution */ int nsym; { int iq,i, inctype, firsttype, lasttype, toptype; unsigned int jq; union scalar first, inc, last; /*first, eval and keep the inc and last value -- these are not allowed to change during the loop */ if ( get_scalar_val((int) sym[nsym].spec.evb.args[0], &inc.l, &inctype) != 1 ) return execute_error(15); if ( get_scalar_val((int) sym[nsym].spec.evb.args[1], &last.l, &lasttype) != 1 ) return execute_error(16); if ( get_scalar_val((int) sym[nsym].spec.evb.args[2],&first.l,&firsttype) != 1 ) return execute_error(14); /*find the top type */ toptype = (firsttype > lasttype ) ? firsttype : lasttype; if ( inctype > toptype ) toptype = inctype; /*convert to toptype */ if ( inctype != toptype ) ana_convert( &inc, inctype, toptype); if ( lasttype != toptype ) ana_convert( &last, lasttype, toptype); if ( firsttype != toptype ) ana_convert( &first, firsttype, toptype); /* set counter to initial value */ iq = sym[nsym].spec.evb.args[3]; /*counter */ if ( redef_scalar(iq, toptype, &first) != 1 ) return execute_error(14); /*set counter */ jq = eval ( (unsigned int) sym[nsym].xx); /*statement */ do { i = execute( jq ); /*do the statement */ if ( i != 1 ) { /*check for escapes and errors */ if ( i == 0x1000 ) return 1; if ( i >= 0x1000 ) return i; return escaper(i); } /*now bump the counter and check if we go on */ switch (toptype) { /*have to switch on type */ case 2: sym[iq].spec.scalar.l += inc.l; if (inc.l >= 0 ) i = (sym[iq].spec.scalar.l <= last.l ); else i = (sym[iq].spec.scalar.l >= last.l ); break; /* 2/11/93 changed fp conditions to match int, was there a reason for the differences ? */ case 3: sym[iq].spec.scalar.f += inc.f; /* if (inc.f >= 0 ) i = (sym[iq].spec.scalar.f < last.f ); else i = (sym[iq].spec.scalar.f > last.f ); */ if (inc.f >= 0 ) i = (sym[iq].spec.scalar.f <= last.f ); else i = (sym[iq].spec.scalar.f >= last.f ); break; case 4: sym[iq].spec.scalar.d += inc.d; /* if (inc.d >= 0 ) i = (sym[iq].spec.scalar.d < last.d ); else i = (sym[iq].spec.scalar.d > last.d ); */ if (inc.d >= 0 ) i = (sym[iq].spec.scalar.d <= last.d ); else i = (sym[iq].spec.scalar.d >= last.d ); break; } } while (i); return 1; } /*end of for_loop */ /*------------------------------------------------------------------------- */ int get_scalar_val( nsym, val, ntype) /*get value and type of a scalar symbol, return 1 if OK, 0 if not the value will always be i*4, float, or double, no bytes or I*2 */ int nsym, *ntype; union scalar *val; { int iq; nsym = eval (nsym); if ( sym[nsym].class == 8 ) nsym = class8_to_1(nsym); if ( sym[nsym].class != 1) return 0; switch (sym[nsym].type) { case 2: val->l = sym[nsym].spec.scalar.l; *ntype = 2; return 1; case 0: val->l = (int) sym[nsym].spec.scalar.b; *ntype = 2; return 1; case 1: val->l = (int) sym[nsym].spec.scalar.w; *ntype = 2; return 1; case 3: val->f = sym[nsym].spec.scalar.f; *ntype = 3; return 1; case 4: val->d = sym[nsym].spec.scalar.d; *ntype = 4; return 1; default: return execute_error(46); } } /*end of get_scalar_val */ /*------------------------------------------------------------------------- */ int ana_convert(p1, type1, type2) /*convert type1 scalar in p1 to type2*/ union scalar *p1; int type1, type2; { switch (type2) { case 2: switch (type1) { case 2: break; case 3: p1->l =(int) (p1->f); break; case 1: p1->l =(int) (p1->w); break; case 0: p1->l =(int) (p1->b); break; case 4: p1->l =(int) (p1->d); break; } break; case 3: switch (type1) { case 3: break; case 2: p1->f =(float) (p1->l); break; case 1: p1->f =(float) (p1->w); break; case 0: p1->f =(float) (p1->b); break; case 4: p1->f =(float) (p1->d); break; } break; case 1: switch (type1) { case 1: break; case 3: p1->w =(short) (p1->f); break; case 2: p1->w =(short) (p1->l); break; case 0: p1->w =(short) (p1->b); break; case 4: p1->w =(short) (p1->d); break; } break; case 0: switch (type1) { case 0: break; case 1: p1->b = (byte) (p1->w); break; case 3: p1->b = (byte) (p1->f); break; case 2: p1->b = (byte) (p1->l); break; case 4: p1->b = (byte) (p1->d); break; } break; case 4: switch (type1) { case 4: break; case 3: p1->d = (double) (p1->f); break; case 0: p1->d = (double) (p1->b); break; case 1: p1->d = (double) (p1->w); break; case 2: p1->d = (double) (p1->l); break; } break; } return 1; } /*------------------------------------------------------------------------- */ int ana_array_convert(q1, q2, type1, type2, n) /* more general conversion, converts data starting at q1 of type1 to type2 data starting at q2, n count */ /* note that indices are bumped even when count is one */ union types_ptr *q1,*q2; int type1, type2, n; { switch (type2) { case 0: switch (type1) { case 0: while (n) { *q2->b++ = (*q1->b++);n--;} break; case 1: while (n) { *q2->b++ = (byte) (*q1->w++);n--;} break; case 2: while (n) { *q2->b++ = (byte) (*q1->l++);n--;} break; case 3: while (n) { *q2->b++ = (byte) (*q1->f++);n--;} break; case 4: while (n) { *q2->b++ = (byte) (*q1->d++);n--;} break; } case 1: switch (type1) { case 1: while (n) { *q2->w++ = (*q1->w++);n--;} break; case 0: while (n) { *q2->w++ = (short) (*q1->b++);n--;} break; case 2: while (n) { *q2->w++ = (short) (*q1->l++);n--;} break; case 3: while (n) { *q2->w++ = (short) (*q1->f++);n--;} break; case 4: while (n) { *q2->w++ = (short) (*q1->d++);n--;} break; } break; case 2: switch (type1) { case 2: while (n) { *q2->l++ = (*q1->l++);n--;} break; case 1: while (n) { *q2->l++ = (int) (*q1->w++);n--;} break; case 0: while (n) { *q2->l++ = (int) (*q1->b++);n--;} break; case 3: while (n) { *q2->l++ = (int) (*q1->f++);n--;} break; case 4: while (n) { *q2->l++ = (int) (*q1->d++);n--;} break; } break; case 3: switch (type1) { case 3: while (n) { *q2->f++ = (*q1->f++);n--;} break; case 2: while (n) { *q2->f++ = (float) (*q1->l++);n--;} break; case 1: while (n) { *q2->f++ = (float) (*q1->w++);n--;} break; case 0: while (n) { *q2->f++ = (float) (*q1->b++);n--;} break; case 4: while (n) { *q2->f++ = (float) (*q1->d++);n--;} break; } break; case 4: switch (type1) { case 4: while (n) { *q2->d++ = (*q1->d++);n--;} break; case 3: while (n) { *q2->d++ = (double) (*q1->f++);n--;} break; case 2: while (n) { *q2->d++ = (double) (*q1->l++);n--;} break; case 1: while (n) { *q2->d++ = (double) (*q1->w++);n--;} break; case 0: while (n) { *q2->d++ = (double) (*q1->b++);n--;} break; } break; } return 1; } /*------------------------------------------------------------------------- */ int ana_replace(iq,jq) /*replace statement */ /*replace symbol iq with jq if legal*/ int iq,jq; { union scalar xq; struct ahead *h; int mq; /*printf("in replace, lhs = %d %d %d, rhs = %d %d %d\n",iq,sym[iq].class, sym[iq].type, jq,sym[jq].class,sym[jq].type); */ /* check for x = x constructions */ if ( jq == iq) { return 1; } /* check if legal to change this symbol */ if ( iq <= vfix_top ) return execute_error(4); /*may need to add other tests for legal */ /* check if lhs is a transfer symbol, and resolve if so */ while (sym[iq].class == 5) { iq = (int) sym[iq].spec.evb.args[0]; } /* now switch on the rhs class for details of transfer */ switch (sym[jq].class) { case SCAL_PTR: jq = class8_to_1(jq); case SCALAR: /*scalar */ /*rhs is a scalar, have to check if lhs is a class 8 because these are treated differently. Class 8 is used when we have a pointer to a scalar and we can't change the type though we can change the value. The major examples are subscripted locations in an array (we want to just change one value in the array) and internal status or option variables that point to a fixed location in memory (and are used in the C code). */ if (sym[iq].class == 8) { /*copy contents of rhs scalar */ bcopy((char *) &sym[jq].spec.scalar.l, (char *) &xq, ana_type_size[sym[jq].type]); ana_convert( &xq, sym[jq].type, sym[iq].type); /*convert to lhs type */ /*copy converted scalar to location of the class 8 value */ bcopy((char *) &xq, (char *) sym[iq].spec.array.ptr, ana_type_size[sym[iq].type]); return 1; } else return redef_scalar(iq, sym[jq].type, &sym[jq].spec.scalar); /*end of scalar */ case STRING: /*string */ case COMPILE_STR: /*compile string */ case ARRAY: /*array */ case ASSOC: /*assoc variable */ case SYM_PTR: /*symbol pointers */ case STRING_PTR: /*string pointer */ case SYM_ARR: /*symbol array */ /*iq is lhs and jq is rhs */ /* if this is an internal variable, this operation is illegal in all situations */ if ( iq < num_internal_syms) { printf("symbol # and name:%d %s\n", iq, find_sym_name(iq) ); return execute_error(116); } /* if a temp, we don't have to copy contents */ if ( jq >= temp_base ) { /*rhs a temp ? */ /* must always delete the lhs symbol if making just a ptr transfer */ if ( delete_symbol(iq) != 1 ) return execute_error(17); sym[iq].class=sym[jq].class; sym[iq].type=sym[jq].type; sym[iq].spec.array.bstore = sym[jq].spec.array.bstore; /*just grab all the temps attributes and pointer */ sym[iq].spec.array.ptr = sym[jq].spec.array.ptr; sym[jq].spec.array.bstore = 0; /*so it won't get deallocated with temp */ return 1; } /* not a temp, have to copy the whole thing, but may already have the proper amount of memory in lhs, check to avoid unneeded calloc/free cycle */ mq = sym[jq].spec.array.bstore; /* note that we always delete STR_PTR's and SYM_ARR's since the contents would have to be freed anyway; re-using just the pointer memory space is not worth the extra hassle */ if (mq != sym[iq].spec.array.bstore || (sym[iq].class != STRING && sym[iq].class != ARRAY)) { if ( delete_symbol(iq) != 1 ) return execute_error(17); sym[iq].spec.array.bstore = sym[jq].spec.array.bstore; if ( (sym[iq].spec.array.ptr = (int *) malloc(mq) ) == NULL ) return execute_error(13); /*printf("malloc in replace, ptr = %d\n",sym[iq].spec.array.ptr);*/ } sym[iq].class=sym[jq].class; sym[iq].type=sym[jq].type; /* printf("before bcopy\n"); printf("@rhs = %d\n", * (byte *)sym[jq].spec.array.ptr); printf("@lhs = %d\n", * (byte *)sym[iq].spec.array.ptr); */ bcopy( (char *)sym[jq].spec.array.ptr, (char *)sym[iq].spec.array.ptr, mq); /* if a string array or a symbol array, we aren't done yet */ if (sym[jq].class == STRING_PTR) { /* need to copy all the strings we point to */ int n, nd, j; char **p, **q; h = (struct ahead *) sym[jq].spec.array.ptr; nd = h->ndim; n = 1; for (j=0;jdims[j]; q = (char **) ((char *) h + sizeof(struct ahead)); /* now the destination */ p = (char **) ((char *) sym[iq].spec.array.ptr + sizeof(struct ahead)); while (n--) { if (*q) *p = strsave(*q); p++; q++; } } if (sym[jq].class == SYM_ARR) { /* need to copy all the symbols in the symbol array, arduous */ int n, nd, j, stat; struct sym_desc *p, *q; h = (struct ahead *) sym[jq].spec.array.ptr; nd = h->ndim; n = 1; for (j=0;jdims[j]; q = (struct sym_desc *) ((char *) h + sizeof(struct ahead)); /* now the destination */ p = (struct sym_desc *) ((char *) sym[iq].spec.array.ptr + sizeof(struct ahead)); /* All the sym_desc are already copied, any defined ones must also have the data copied if they are arrays (which is normal). Scalars have values in the sym_desc already. Don't have to worry about SCAL_PTR class here (I think) because there should be no way that one could get into a SYM_ARR. */ while (n--) { stat = symbol_clone_via_ptr(p, q, 0); if (stat != 1) return stat; p++; q++; } } return 1; default: printf("class = %d\n", sym[jq].class); return execute_error(56); } /*end of class switch*/ } /*end of replace */ /*------------------------------------------------------------------------- */ void insert_error(iq, offset) int iq, offset; { printf("insert error\n"); printf("lhs array name: %s, index %d\n",find_sym_name(iq), offset); } /*------------------------------------------------------------------------- */ int ana_insert(nsym) /*insert statement */ int nsym; { int i,iq,jq,narg,inc, inc_size,nelem,nd,j,subarg[8],offset,n,n2, *in; union types_ptr q1,q2; char *p1, *p2; unsigned short *ap; struct ahead *h; get_evb_ptr(nsym) /*a macro that gets narg and arg ptr */ /* the arguments are as follows: rhs sym#, subscripts, lhs sym # */ narg = narg - 2; /*now the # of subscripts */ if (narg < 0 || narg > 8 ) return execute_error(72); jq = *ap++; /*get rhs sym # */ /* don't eval rhs until we check that lhs sym is legal, etc */ iq = * ( ap + narg ); /* this is lhs */ /*check if legal to change this symbol */ if ( iq <= vfix_top ) return execute_error(4); /*check if lhs is a transfer symbol, and resolve if so */ while (sym[iq].class == 5) { iq = (int) sym[iq].spec.evb.args[0]; } /*check if lhs legal and get ptr and nelem */ switch (sym[iq].class) { /* switch on lhs class */ case SCAL_PTR: case 1: /*scalars are illegal here */ case 3: /*compile strings not supported yet */ return execute_error(71); case ASSOC: /*assoc variables go to files.c */ if (narg != 1) return execute_error(112); jq = eval( jq ); /*eval the rhs */ j = eval( (int) *ap); return ana_assoc_output(iq, jq, j); case STRING_PTR: /*strarr lhs */ { char **p, **pin; h = (struct ahead *) sym[iq].spec.array.ptr; p = (char **) ((char *)h + sizeof(struct ahead)); nd = h->ndim; nelem = 1; for (j=0;jdims[j]; /*# of elements */ jq = eval( jq ); /*eval the rhs */ /* should be a string or a string pointer, check now */ if (sym[jq].class != STRING && sym[jq].class != STRING_PTR) return execute_error(124); offset = 0; switch (narg) { case 0: break; /* treat no subscript as a zero */ case 1: /* single subscript case */ i = eval ( (int) *ap ); switch (sym[i].class) { case 8: i = class8_to_1( i); case 1: offset = int_arg( i ); /*single scalar, most common case */ if ( offset >= nelem ) { insert_error(iq, offset); return execute_error(35); } if (offset < 0 ) { insert_error(iq, offset); return execute_error(74); } break; case 4: /*index is an array, treat as list to load */ /*only one array (if two, caught below) */ /* code does a return within this case, which is a complicated one */ if (sym[i].type != 2) i = ana_long(1, &i ); /*make a long version */ h = (struct ahead *) sym[i].spec.array.ptr; in = (int *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; /*# of elements in subsc */ /* the rhs could be a single string or a string array, in the former case we want to load all targets with the single string */ switch (sym[jq].class) { case STRING: /* similar to scalar case for arrays, load all with the same string */ nd = n; /* use nd to count rejects */ while (n--) { j = *in++; /* j is now offset */ if (j>=0 && jndim; n2 = 1; for (j=0;jdims[j]; n = (n < n2) ? n : n2; /*min of n and n2 */ nd = n; /*use nd to count rejects */ while (n--) { j = *in++; if (j>=0 && j 0) printf("WARNING - %d out of range subscripts in lhs index for %s\n",nd, find_sym_name(iq)); return 1; /*end of index array cases */ } default: /* more than one subscript, all must be scalars */ j = 0; inc = 1; offset = 0; ap += narg; while (narg--) { i = eval ( (int) *(--ap) ); if (sym[i].class == 8) i = class8_to_1(i); if (sym[i].class != 1 ) return execute_error(73); i = int_arg( i ); if ( i >=h->dims[j] ) { insert_error(iq, i); return execute_error(35); } if (i < 0 ) return execute_error(74); offset += inc * i; inc = inc * h->dims[j++]; } break; } /* get here if a single offset, either from one or several dimensions */ /* how many we load depends on rhs (jq) */ /* check if offset in range */ if (offset < 0 || offset >= nelem) return execute_error(124); p = p + offset; switch (sym[jq].class) { /*switch on rhs class */ case STRING: /* get the pointer location and free anything there*/ p2 = *p; if (p2) free(p2); /* copy the string */ p1 = (char *) sym[jq].spec.array.ptr; *p = strsave(p1); return 1; case STRING_PTR: { char **q; h = (struct ahead *) sym[jq].spec.array.ptr; q = (char **) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; if ( (n + offset) > nelem ) n = nelem - offset; while (n--) { p2 = *p; if (p2) free(p2); p1 = *(q++); if (p1) *p = strsave(p1); else *p = NULL; p++; } } return 1; default: return execute_error(75); } } /* end of str_ptr lhs case */ case SYM_ARR: /*sym pointer lhs */ { struct sym_desc *p, *pin, *q; int stat; h = (struct ahead *) sym[iq].spec.array.ptr; p = (struct sym_desc *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; nelem = 1; for (j=0;jdims[j]; /*# of elements */ jq = eval( jq ); /*eval the rhs */ offset = 0; switch (narg) { case 0: break; /* treat no subscript as a zero */ case 1: /* single subscript case */ i = eval ( (int) *ap ); switch (sym[i].class) { case 8: i = class8_to_1( i); case 1: offset = int_arg( i ); /*single scalar, most common case */ if ( offset >= nelem ) { insert_error(iq, offset); return execute_error(35); } if (offset < 0 ) { insert_error(iq, offset); return execute_error(74); } break; case 4: /*index is an array, treat as list to load */ /*only one array (if two, caught below as error) */ /* code does a return within this case */ if (sym[i].type != 2) i = ana_long(1, &i ); /* make a long version */ h = (struct ahead *) sym[i].spec.array.ptr; in = (int *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; /* # of elements in subsc */ /* the rhs can be any symbol */ /* the operation here just duplicates the symbol and the descriptor */ if (sym[jq].class == SYM_ARR) { /* the # loaded will be the lesser of the sizes of subsc and rhs */ struct sym_desc *q; h = (struct ahead *) sym[jq].spec.array.ptr; q = (struct sym_desc *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n2 = 1; for (j=0;jdims[j]; n = (n < n2) ? n : n2; /*min of n and n2 */ nd = n; /*use nd to count rejects */ while (n--) { j = *in++; if (j>=0 && j=0 && j 0) printf("WARNING - %d out of range subscripts in lhs index for %s\n",nd, find_sym_name(iq)); return 1; /*end of */ } default: /* more than one subscript, all must be scalars */ j = 0; inc = 1; offset = 0; ap += narg; while (narg--) { i = eval ( (int) *(--ap) ); if (sym[i].class == 8) i = class8_to_1(i); if (sym[i].class != 1 ) return execute_error(73); i = int_arg( i ); if ( i >=h->dims[j] ) { insert_error(iq, i); return execute_error(35); } if (i < 0 ) return execute_error(74); offset += inc * i; inc = inc * h->dims[j++]; } break; } /* only get here if a single offset, either from one or several dimensions */ /* how many we load depends on rhs (jq) */ /* check if offset in range */ if (offset < 0 || offset >= nelem) return execute_error(124); p = p + offset; /* if the rhs is anything except another symbol array, we just copy the single symbol. If another symbol array, we insert the component symbols starting at offset, just like a regular array. */ if (sym[jq].class == SYM_ARR) { struct sym_desc *q; h = (struct ahead *) sym[jq].spec.array.ptr; q = (struct sym_desc *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; if ( (n + offset) > nelem ) n = nelem - offset; while (n--) { stat = delete_symbol_via_ptr(p); if (stat != 1) return stat; stat = symbol_clone_via_ptr(p, q, 1); if (stat != 1) return stat; p++; q++; } return 1; } else { /* just a simple insert, destroy anything already at this position and replace with the rhs symbol */ q = &sym[jq]; stat = delete_symbol_via_ptr(p); if (stat != 1) return stat; stat = symbol_clone_via_ptr(p, q, 1); if (stat != 1) return stat; return 1; } } /* end of sym_ptr lhs case */ case STRING: /*string lhs */ p1 = (char *) sym[iq].spec.array.ptr; nelem = sym[iq].spec.array.bstore - 1; nd = 1; inc_size = 1; break; case ARRAY: /*array lhs */ h = (struct ahead *) sym[iq].spec.array.ptr; p1 = (char *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; nelem = 1; for (j=0;jdims[j]; /*# of elements */ inc_size = ana_type_size[sym[iq].type]; offset = 0; break; } /* both arrays and strings handled here, but not string arrays which are finished above */ /*p1 is pointer to first element of array, nelem is #, nd is dimension*/ jq = eval( jq ); /*eval the rhs */ switch (narg) { case 0: break; /* treat no subscript as a zero */ case 1: /* single subscript case */ i = eval ( (int) *ap ); switch (sym[i].class) { case 8: i = class8_to_1( i); case 1: i = int_arg( i ); /*single scalar, most common case */ if ( i >= nelem ) { printf("lhs array name: %s, index %d\n",find_sym_name(iq),i); return execute_error(35); } if (i < 0 ) return execute_error(74); offset = i; break; case 4: /*index is an array, treat as list to load */ /*only one array (if two, caught below) */ /* code does a return within this case, which is a complicated one */ q1.b = (byte *) p1; if (sym[i].type != 2) i = ana_long(1, &i ); /*make a long version */ h = (struct ahead *) sym[i].spec.array.ptr; in = (int *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; /*# of elements in subsc */ /*because of the complicated inner loop, we make (if necessary) a copy of rhs with same type as lhs */ /*but also need to check for consenting strings */ if (sym[jq].class == 2 || sym[iq].class == 2) { if (sym[jq].class != sym[iq].class) return execute_error(75); } else { if (sym[iq].type != sym[jq].type) { switch (sym[iq].type) { case 0: jq = ana_byte(1,&jq); break; case 1: jq = ana_word(1,&jq); break; case 2: jq = ana_long(1,&jq); break; case 3: jq = ana_float(1,&jq); break; case 4: jq = ana_double(1,&jq); break; } } } /* the rhs could be a scalar or an array or string */ switch (sym[jq].class) { case 8: jq = class8_to_1(jq); case 1: /*scalar */ nd = n; /*use nd to count rejects */ switch (sym[iq].type) { case 0: while (n--) { j = *in++; if (j>=0 && j=0 && j=0 && j=0 && j=0 && j=0 && jndim; n2 = 1; for (j=0;jdims[j]; n = (n < n2) ? n : n2; /*min of n and n2 */ nd = n; /*use nd to count rejects */ switch (sym[iq].type) { case 0: while (n--) { j = *in++; if (j>=0 && j=0 && j=0 && j=0 && j=0 && j 0) printf("WARNING - %d out of range subscripts in lhs index\n",nd); return 1; /*end of index array cases */ /*catch some of the funnies here */ default: return execute_error(73); } break; default: /*more than one subscript, all must be scalars*/ j = 0; inc = 1; offset = 0; ap += narg; while (narg--) { i = eval ( (int) *(--ap) ); if (sym[i].class == 8) i = class8_to_1(i); if (sym[i].class != 1 ) return execute_error(73); i = int_arg( i ); if ( i >=h->dims[j] ) { printf("lhs array name: %s, index %d\n", find_sym_name(iq), i ); return execute_error(35); } if (i < 0 ) return execute_error(74); offset += inc * i; inc = inc * h->dims[j++]; } break; } /* if we get here, the above resulted in a single starting position for lhs array, how many we load depends on rhs (jq) */ p1 += inc_size * offset; /*starting address */ switch (sym[jq].class) { /*switch on rhs class */ case 8: jq = class8_to_1(jq); case 1: /*scalar */ q1.l = &sym[jq].spec.scalar.l; ana_array_convert(&q1.l, &p1,sym[jq].type,sym[iq].type, 1); return 1; /* done */ case 3: /* compile strings not supported yet */ case 6: /* assoc variables not supported yet on both sides */ return execute_error(71); case 2: /* string rhs */ p2 = (char *) sym[jq].spec.array.ptr; n = sym[jq].spec.array.bstore - 1; if ( (n + offset) > nelem ) n = nelem - offset; while (n--) { *p1++ = *p2++;} return 1; case 4: /* array rhs */ h = (struct ahead *) sym[jq].spec.array.ptr; p2 = (char *) ((char *)h + sizeof(struct ahead)); nd = h->ndim; n = 1; for (j=0;jdims[j]; /* # of elements */ break; default: return execute_error(75); } /*if we haven't already returned, we had an array rhs to be loaded at a starting address p1, also check for overflow */ if ( (n + offset) > nelem ) n = nelem - offset; ana_array_convert(&p2, &p1, sym[jq].type, sym[iq].type, n); return 1; } /*------------------------------------------------------------------------- */ int user_subr_exec(nsym) /*user subroutine */ /* execute a user subroutine */ int nsym; { extern int symbol_context; unsigned short *aps, *ap; unsigned short *pq, *pf; int i,j,k,iq,narg,nargsub,codesym, save_context; int nscript; unsigned short *ptr, *evalptr; struct user_subr_table *np; struct sym_desc *script_ptr; get_evb_ptr(nsym) /*a macro that gets narg and arg ptr ap */ /*the last arg is the subr # for this subr, fetch it */ aps = ap+(narg-1); i = narg; /*while (i--) printf("i, *(aps - i) %d %d\n", i, *(aps - i));*/ iq = --narg; /*# of input arguments */ i = (int) *aps - num_ana_subr; /*i is subroutine # */ /*printf("subr # = %d\n",i);*/ /*get pointer to descriptor block */ ptr = user_subr_ptrs[i]; np = user_subrs_nf[i]; /*defined ? */ if ( ptr == 0 ) { /* look for it in the library */ /*printf("checking library files for %s\n", np->name);*/ if ( sblib(np->name, 0) == -1 ) { execute_error(41); printf("%s\n",np->name); return -1; } /* found it and parsed something, if we got it the ptr should now be valid */ ptr = user_subr_ptrs[i]; /*printf("i, ptr = %d %d\n", i,ptr);*/ if (ptr == 0) { /* still no joy */ printf("found the file but subroutine still not compiled, a mistake ?\n"); printf("%s\n",np->name); return -1; } } /*check for recursion and set flag, if an error, reset flag for future */ if ( *ptr != 0 ) { *ptr = 0; /* sometimes we just want to ignore recursions without a fuss */ if (mention_recursives) return execute_error(42); else return 1; } else *ptr++ = 1; /*get number of formal arguments */ nargsub = (int) *ptr++; if ( narg > nargsub ) { * (ptr-2) = 0; execute_error(43); printf("%s\n",np->name); return -1;} /*too many ? */ codesym = (int) *ptr; /*code body */ ptr = ptr + nargsub; /*point to first formal arg */ evalptr = ptr + 1; /*place saved for eval's */ pf = ptr; pq = evalptr; /*note that formals were loaded backwards */ aps--; /*point to next to last in edb, args were loaded backwards, so this is first input for subr*/ /*loop over input args */ while (iq--) { *pq = (unsigned short) eval ( (int) *aps); aps--; pq++; } narg_user = narg; /*set user variable */ /*loop over the now eval'ed inputs and setup formals */ /* pq is eval'ed ptr, and pf is formal ptr */ pq = evalptr; iq = narg; while (iq--) { /*printf("input # %d, formal # %d\n", *pq, *pf );*/ /* make everybody a transfer symbol except temps and scripts */ if ( *pq >= sps_base ) { /* a temp type, steal attributes */ delete_symbol(*pf); /* delete any prior use */ sym[*pq].xx = sym[*pf].xx; /* preserve name */ bcopy( &sym[*pq], &sym[*pf], sizeof(struct sym_desc) ); sym[*pq].class=255; /* to keep memory from getting deleted */ } else { /* make formal a transfer */ sym[*pf].class = 5; sym[*pf].spec.evb.args[0] = *pq; } pq++; pf--; /* bump pointers */ } /* make any unused formal arguments undefined and delete memory */ if ( nargsub > narg ) { iq = nargsub - narg; /*printf("unused formal arg count %d\n", iq);*/ while (iq--) { delete_symbol(*pf--); } } /* in case we do any eval'ing, set the eval_context */ save_context = symbol_context; symbol_context = i + 1; /* call routine */ codesym = execute( codesym ); /*return status in codesym (recycle ) */ symbol_context = save_context; /*re-set recursive flag */ ptr = user_subr_ptrs[i]; *ptr = 0; /* check the return status */ switch (codesym) { case 0x1002: case 0x1000: case 1: return 1; /* success return */ } /* something bad or funny */ printf("error in user subroutine %s (# %d), code %#x\n", np->name,i,codesym); /*if (codesym > 0x1002 ) { printf("strange return status = 0x%x\n",codesym);}*/ /* assume these are all errors */ execute_error(45); printf("%s\n",np->name); return -1; } /*------------------------------------------------------------------------- */ int user_func_exec(nsym) /*user function */ /* execute a user function, more complicated than a subroutine */ int nsym; { extern int symbol_context; unsigned short *aps, *ap; unsigned short *pq, *pf; int i,j,k,iq,narg,nargsub,codesym, save_context; int nscript, ntemp, return_sym, *old_return_ptr; unsigned short *ptr, *evalptr; struct user_subr_table *np; struct sym_desc *script_ptr, *temp_ptr; /*printf("user func in execute\n");*/ /*be careful not to use get_evb_ptr here */ narg = (int) sym[nsym].type; if (narg<5) ap= &sym[nsym].spec.evb.args[0]; else ap = (unsigned short *) sym[nsym].spec.array.ptr; i = (int) sym[nsym].xx - num_ana_func; /* user func # */ aps = ap+(narg-1); iq = narg; /*# of input arguments */ /*printf("func # = %d\n",i);*/ /*get pointer to descriptor block */ ptr = user_func_ptrs[i]; np = user_funcs_nf[i]; /*printf("function name: %s\n",np->name);*/ /*defined ? */ if ( ptr == 0 ) { return execute_error(3); } /*check for recursion and set flag, if an error, reset flag for future */ if ( *ptr != 0 ) { *ptr = 0; return execute_error(42);} else *ptr++ = 1; /*get number of formal arguments */ nargsub = (int) *ptr++; narg_user = narg; if ( narg > nargsub ) { * (ptr-2) = 0; execute_error(69); printf("%s\n",np->name); return -1;} /*too many ? */ codesym = (int) *ptr; /*code body */ ptr = ptr + nargsub; /*point to first formal arg */ evalptr = ptr + 1; /*place saved for eval's */ pf = ptr; pq = evalptr; /*note that formals were loaded backwards */ /*loop over input args */ while (iq--) { *pq = (unsigned short) eval ( (int) *aps); aps--; pq++; } /* narg_user may have been changed in eval loop above */ narg_user = narg; /*loop over the now eval'ed inputs and setup formals */ /* pq is eval'ed ptr, and pf is formal ptr */ pq = evalptr; iq = narg; while (iq--) { /*printf("input # %d, formal # %d\n", *pq, *pf );*/ /* make everybody a transfer symbol except temps and scripts */ if ( *pq >= sps_base ) { /* a temp type, steal attributes */ delete_symbol(*pf); /* delete any prior use */ sym[*pq].xx = sym[*pf].xx; /* preserve name */ bcopy( &sym[*pq], &sym[*pf], sizeof(struct sym_desc) ); sym[*pq].class=255; /* to keep memory from getting deleted */ } else { /* make formal a transfer */ delete_symbol(*pf); /* delete any prior use */ sym[*pf].class = 5; sym[*pf].spec.evb.args[0] = *pq; } pq++; pf--; /* bump pointers */ } /* make any unused formal arguments undefined and delete memory */ if ( nargsub > narg ) { iq = nargsub - narg; while (iq--) { delete_symbol(*pf--); } } /*note - the above eval's may have included other user functions which will have saved any temps or subsc ptrs in the list before proceeding with any calls to execute (which zaps these lists), for this func these saves are done now */ /* we don't really have to save the subsc's and temp's that were copied above (often all of them) but it is easy to save all currently outstanding cases with single block transfers (only the symbol def's are copied, not any array contents) so it is done that way below - to avoid saving unnecessary cases, check each to see if it is really defined but remember to restore it back to the original slot (which means saving the sym # for each as well) */ /* check for any subscript pointers, we have to save them for functions */ if ( (nscript = max_sp - sps_base) > 0 ) { /*if true, got some */ iq = nscript * sizeof(struct sym_desc); if ( (script_ptr = (struct sym_desc *) malloc(iq)) == NULL) { *user_func_ptrs[i]=0; return execute_error(13); } /*printf("malloc in user_fun_exec, ptr = %d\n", script_ptr);*/ bcopy( &sym[sps_base], script_ptr, iq); /*copy to a safe place */ max_sp = sps_base; /*hide them */ } /* check for any temps, we have to save them for functions */ if ( (ntemp = max_temp - temp_base) > 0 ) { /*if true, got some */ iq = ntemp * sizeof(struct sym_desc); if ( (temp_ptr = (struct sym_desc *) malloc(iq)) == NULL) { *user_func_ptrs[i]=0; return execute_error(13); } /*printf("malloc in user_fun_exec, ptr = %d\n", temp_ptr);*/ bcopy( &sym[temp_base], temp_ptr, iq); /* copy to a safe place */ max_temp = temp_base; /* hide them */ } /* setup the return symbol situation */ old_return_ptr = return_sym_ptr; return_sym_ptr = &return_sym; return_sym = 0; /* default return */ /* in case we do any eval'ing, set the eval_context */ save_context = symbol_context; symbol_context = i + 1 +MAX_USER_SUBRS; /* call function */ codesym = execute ( codesym ); /*return status in codesym (recycle ) */ symbol_context = save_context; /*printf("return status of user function # %d (name = %s) is 0x%x\n",i, np->name,codesym); printf("return_sym = %d\n",return_sym);*/ pf = ptr; /*re-set recursive flag */ ptr = user_func_ptrs[i]; *ptr = 0; return_sym_ptr = old_return_ptr; /* the return_sym may be (and often is) a temp which we must save */ if (return_sym >= sps_base) { if (return_sym != (max_temp - 1)) { /* not the last temp, copy essence if a temp */ iq = find_next_temp(); bcopy( &sym[return_sym], &sym[iq], sizeof(struct sym_desc) ); sym[return_sym].spec.array.bstore = 0; /* hide */ sym[return_sym].class = 255; /* undefine */ return_sym = iq; } /* now check if our temp restore would overwrite us */ iq = MAX(return_sym, temp_base + ntemp); /* copy if we have to */ if ( return_sym != iq ) { bcopy( &sym[return_sym], &sym[iq], sizeof(struct sym_desc) ); sym[return_sym].spec.array.bstore = 0; /* hide */ sym[return_sym].class = 255; /* undefine */ return_sym = iq; } max_temp--; /* this keeps our return_sym from being cleared below */ } /*if return_sym was a temp, it should now be safe from a clear and a restore*/ clear_temps(); /*clear all the other temps */ clear_sps(); /*and the subsc ptrs */ /* restore temps */ /* allow for a temp return sym in setting max_temp since more temps may be created before we need this result */ max_temp = MAX(temp_base + ntemp, return_sym + 1); if ( ntemp ) { /*if true, got some */ iq = ntemp * sizeof(struct sym_desc); bcopy( temp_ptr, &sym[temp_base], iq); /* copy back to temp space */ /*printf("free in user_func_exec, ptr = %d\n", temp_ptr);*/ free (temp_ptr); /* recover memory */ } /* restore sps */ max_sp = sps_base + nscript; if ( nscript ) { /*if true, got some */ iq = nscript * sizeof(struct sym_desc); bcopy( script_ptr, &sym[sps_base], iq); /* copy back to temp space */ /*printf("free in user_func_exec (2), ptr = %d\n", script_ptr);*/ free (script_ptr); /* recover memory */ } /* functions might return fixed literals, and if these are used as arguments in other functions or subroutines, they may be changed. Since this is undesirable for the next call, we must check for this possibility and make a copy. Note that internal func or subr symbols could also be changed this way but we don't prevent that. Hence, be careful if counting on an internal symbol to remain invariate for the next call! */ /* printf("return symbol # %d\n", return_sym); printf("context for return sym = %d\n",get_context(return_sym)); printf("i, MAX_USER_SUBRS = %d %d\n", i, MAX_USER_SUBRS); */ if (return_sym >= edb2_base && return_sym < sps_base) { /* this catches fixed literals and code symbols in main and subr space*/ iq = find_next_temp(); if ( ana_replace ( iq, return_sym ) != 1) { printf("(X) problem copying result symbol %d to %d\n",return_sym,iq); printf("in user func %s\n",np->name); return -1; } return_sym = iq; } else if ( get_context(return_sym) == (i+MAX_USER_SUBRS+1) ) { /* 8/10/92, if the return symbol is an internal to the function, it must be stashed in a temporary against the possibility that the function is used several times in a line, we don't copy to avoid the extra memory and time, can't be a literal of course so this is in else case of literal check */ iq = find_next_temp(); bcopy( &sym[return_sym], &sym[iq], sizeof(struct sym_desc) ); sym[return_sym].spec.array.bstore = 0; /* hide */ sym[return_sym].class = 255; /* undefine */ return_sym = iq; } /* check the return status */ /*printf("final returned symbol = %d\n", return_sym);*/ switch (codesym) { case 0x1002: case 0x1000: return return_sym; /* success return */ case 1: printf("user function %s ended without a RETURN\n", np->name); default: /* something bad or funny */ printf("strange return status = 0x%x\n",codesym); /* assume these are all errors */ execute_error(45); printf("%s\n",np->name); return -1; } } /*------------------------------------------------------------------------- */ int user_code_exec(nsym) /*named block execution */ /* execute a user block */ int nsym; { int iq, codesym; unsigned short *ptr; struct user_subr_table *np; iq = eval ( (int) sym[nsym].spec.evb.args[0]); /*block # */ /*printf("running named block # %d\n",iq);*/ ptr = user_code_ptrs[iq]; np = user_code_nf[iq]; /*printf("block name: %s\n",np->name);*/ /*defined ? */ if ( ptr == 0 ) { printf("undefined named block, # = %d, name = %s\n",iq, np->name); return -1; } codesym = * (ptr + 2); /* don't need some things in this structure */ /* codesym is symbol of code block associated with this name */ /*printf("block codesym = %d\n",codesym);*/ iq = execute( codesym ); switch (iq) { case 0x1002: case 0x1000: case 1: return 1; /* success return */ } if (iq <= 0) { execute_error(61); printf("%s\n",np->name); return -1; } return iq; }