home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / CMDS / memacs400_src.lzh / MEMACS400 / SRC / eval.c < prev    next >
Text File  |  1996-04-25  |  43KB  |  1,765 lines
  1. /*    EVAL.C: Expresion evaluation functions for
  2.         MicroEMACS
  3.  
  4.     written 1993 by Daniel Lawrence             */
  5.  
  6. #include    <stdio.h>
  7. #include    "estruct.h"
  8. #include    "eproto.h"
  9. #include    "edef.h"
  10. #include    "elang.h"
  11. #include    "evar.h"
  12.  
  13. /* initialize the entries in one user variable table */
  14.  
  15. VOID PASCAL NEAR uv_init(ut)
  16.  
  17. UTABLE *ut;    /* user variable table to initialize */
  18.  
  19. {
  20.     register int i;
  21.  
  22.     for (i=0; i < ut->size; i++) {
  23.         ut->uv[i].u_name[0] = 0;
  24.         ut->uv[i].u_value = (char *)NULL;
  25.     }
  26. }
  27.  
  28. VOID PASCAL NEAR varinit()    /* initialize the global user variable table */
  29.  
  30. {
  31.     /* allocate the global user variable table */
  32.     uv_global = uv_head =
  33.         (UTABLE *)room(sizeof(UTABLE) + MAXVARS * sizeof(UVAR));
  34.  
  35.     /* and set up its fields */
  36.     uv_head->next = (UTABLE *)NULL;
  37.     uv_head->size = MAXVARS;
  38.     uv_head->bufp = (BUFFER *)NULL;
  39.     uv_init(uv_head);
  40. }
  41.  
  42. VOID PASCAL NEAR uv_clean(ut)    /* discard the contents of a user variable table */
  43.  
  44. UTABLE *ut;    /* ptr to table to clear */
  45.  
  46. {
  47.     register int i;
  48.  
  49.     /* now clear the entries in this one */
  50.     for (i=0; i < ut->size; i++)
  51.         if (ut->uv[i].u_name[0] != 0)
  52.             free(ut->uv[i].u_value);
  53. }
  54.  
  55. VOID PASCAL NEAR varclean(ut)    /* discard and clear all user variable tables */
  56.  
  57. UTABLE *ut;    /* table to clear */
  58.  
  59. {
  60.     /* first clean all the ones under this one */
  61.     if (ut->next != (UTABLE *)NULL)
  62.         varclean(ut->next);
  63.  
  64.     /* clear the contents of this table */
  65.     uv_clean(ut);
  66.  
  67.     /* and then deallocate the this table itself */
  68.     free(ut);
  69. }
  70.  
  71. char *PASCAL NEAR gtfun(fname)    /* evaluate a function */
  72.  
  73. char *fname;        /* name of function to evaluate */
  74.  
  75. {
  76.     register int fnum;        /* index to function to eval */
  77.     register int arg;        /* value of some arguments */
  78.     BUFFER *bp;            /* scratch buffer pointer */
  79.     char arg1[NSTRING];        /* value of first argument */
  80.     char arg2[NSTRING];        /* value of second argument */
  81.     char arg3[NSTRING];        /* value of third argument */
  82.     static char result[2 * NSTRING];    /* string result */
  83.  
  84.     /* look the function up in the function table */
  85.     mklower(fname); /* and let it be upper or lower case */
  86.     fnum = binary(fname, funval, NFUNCS, MINFLEN);
  87.  
  88.     /* return errorm on a bad reference */
  89.     if (fnum == -1) {
  90.         mlwrite(TEXT244, fname);
  91. /*            "%%No such function as '%s'" */
  92.         return(errorm);
  93.     }
  94.  
  95.     /* if needed, retrieve the first argument */
  96.     if (funcs[fnum].f_type >= MONAMIC) {
  97.         if (macarg(arg1) != TRUE)
  98.             return(errorm);
  99.  
  100.         /* if needed, retrieve the second argument */
  101.         if (funcs[fnum].f_type >= DYNAMIC) {
  102.             if (macarg(arg2) != TRUE)
  103.                 return(errorm);
  104.  
  105.             /* if needed, retrieve the third argument */
  106.             if (funcs[fnum].f_type >= TRINAMIC)
  107.                 if (macarg(arg3) != TRUE)
  108.                     return(errorm);
  109.         }
  110.     }
  111.  
  112.  
  113.     /* and now evaluate it! */
  114.     switch (fnum) {
  115.         case UFABBREV:    return(fixnull(ab_lookup(arg1)));
  116.         case UFABS:    return(int_asc(absv(asc_int(arg1))));
  117.         case UFADD:    return(int_asc(asc_int(arg1) + asc_int(arg2)));
  118.         case UFAND:    return(ltos(stol(arg1) && stol(arg2)));
  119.         case UFASCII:    return(int_asc((int)arg1[0]));
  120.         case UFBAND:    return(int_asc(asc_int(arg1) & asc_int(arg2)));
  121.         case UFBIND:    return(transbind(arg1));
  122.         case UFBNOT:    return(int_asc(~asc_int(arg1)));
  123.         case UFBOR:    return(int_asc(asc_int(arg1) | asc_int(arg2)));
  124.         case UFBXOR:    return(int_asc(asc_int(arg1) ^ asc_int(arg2)));
  125.         case UFCALL:    /* construct buffer name to execute */
  126.                 result[0] = '[';
  127.                 strcpy(&result[1], arg1);
  128.                 strcat(result, "]");
  129.  
  130.                 /* find it, return ERROR if it does not exist */
  131.                 bp = bfind(result, FALSE, 0);
  132.                 if (bp == NULL)
  133.                     return(errorm);
  134.  
  135.                 /* execute it and return whats in the $rval */
  136.                 dobuf(bp);
  137.                 return(fixnull(rval));
  138.         case UFCAT:    strcpy(result, arg1);
  139.                 strncat(result, arg2, NSTRING);
  140.                 result[NSTRING - 1] = 0;
  141.                 return(result);
  142.  
  143.         case UFCHR:    result[0] = asc_int(arg1);
  144.                 result[1] = 0;
  145.                 return(result);
  146.         case UFDIV:    if ((arg = asc_int(arg2)) != 0)
  147.                     return(int_asc(asc_int(arg1) / arg));
  148.                 else {
  149.                     mlwrite(TEXT245);
  150. /*                        "%%Division by Zero is illegal" */
  151.                     return(errorm);
  152.                 }
  153.         case UFENV:
  154. #if    ENVFUNC
  155.                 return(fixnull(getenv(arg1)));
  156. #else
  157.                 return("");
  158. #endif
  159.         case UFEQUAL:    return(ltos(asc_int(arg1) == asc_int(arg2)));
  160.         case UFEXIST:    return(ltos(fexist(arg1)));
  161.         case UFFIND:
  162.                 return(fixnull(flook(arg1, TRUE)));
  163.         case UFGREATER: return(ltos(asc_int(arg1) > asc_int(arg2)));
  164.         case UFGROUP:
  165.                 arg = asc_int(arg1);
  166. #if    MAGIC
  167.                 if (arg < 0 || arg >= MAXGROUPS)
  168.                     return(bytecopy(result, errorm, NSTRING * 2));
  169.                     
  170.                 return(bytecopy(result, fixnull(grpmatch[arg]),
  171.                      NSTRING * 2));
  172. #else
  173.                 if (arg == 0)
  174.                     bytecopy(result, patmatch, NSTRING * 2);
  175.                 else
  176.                     return(bytecopy(result, errorm, NSTRING * 2));
  177.                 return(result);
  178. #endif
  179.         case UFGTCMD:    return(cmdstr(getcmd(), result));
  180.         case UFGTKEY:    result[0] = tgetc();
  181.                 result[1] = 0;
  182.                 return(result);
  183.         case UFIND:    return(strcpy(result, fixnull(getval(arg1))));
  184.         case UFISNUM:    return(ltos(is_num(arg1)));
  185.         case UFLEFT:    return(bytecopy(result, arg1, asc_int(arg2)));
  186.         case UFLENGTH:    return(int_asc(strlen(arg1)));
  187.         case UFLESS:    return(ltos(asc_int(arg1) < asc_int(arg2)));
  188.         case UFLOWER:    return(mklower(arg1));
  189.         case UFMID:    arg = asc_int(arg2);
  190.                 if (arg > strlen(arg1))
  191.                     arg = strlen(arg1);
  192.                 return(bytecopy(result, &arg1[arg-1],
  193.                     asc_int(arg3)));
  194.         case UFMKCOL:    if ((arg = asc_int(arg1)) < 0 || arg >= NMARKS ||
  195.                     curwp->w_markp[arg] == NULL)
  196.                 {
  197.                     mlwrite(TEXT11, arg);
  198.                     return (int_asc(-1));
  199.                 }
  200.                 return(int_asc(findcol(curwp->w_markp[arg], curwp->w_marko[arg])));
  201.         case UFMKLINE:    if ((arg = asc_int(arg1)) < 0 || arg >= NMARKS ||
  202.                     curwp->w_markp[arg] == NULL)
  203.                 {
  204.                     mlwrite(TEXT11, arg);
  205.                     return (int_asc(0));
  206.                 }
  207.                 return(long_asc(getlinenum(curbp, curwp->w_markp[arg])));
  208.         case UFMOD:    if ((arg = asc_int(arg2)) != 0)
  209.                     return(int_asc(asc_int(arg1) % arg));
  210.                 else {
  211.                     mlwrite(TEXT245);
  212. /*                        "%%Division by Zero is illegal" */
  213.                     return(errorm);
  214.                 }
  215.         case UFNEG:    return(int_asc(-asc_int(arg1)));
  216.         case UFNOT:    return(ltos(stol(arg1) == FALSE));
  217.         case UFOR:    return(ltos(stol(arg1) || stol(arg2)));
  218.         case UFREVERSE: return(strrev(bytecopy(result, arg1, NSTRING * 2)));
  219.         case UFRIGHT:    arg = asc_int(arg2);
  220.                 if (arg > strlen(arg1))
  221.                     arg = strlen(arg1);
  222.                 return(strcpy(result,
  223.                     &arg1[strlen(arg1) - arg]));
  224.         case UFRND:    return(int_asc((int)(ernd() % (long)absv(asc_int(arg1))) + 1L));
  225.         case UFSEQUAL:    return(ltos(strcmp(arg1, arg2) == 0));
  226.         case UFSGREAT:    return(ltos(strcmp(arg1, arg2) > 0));
  227.         case UFSINDEX:    return(int_asc(sindex(arg1, arg2)));
  228.         case UFSLESS:    return(ltos(strcmp(arg1, arg2) < 0));
  229.         case UFSLOWER:    return(setlower(arg1, arg2), "");
  230.         case UFSUB:    return(int_asc(asc_int(arg1) - asc_int(arg2)));
  231.         case UFSUPPER:    return(setupper(arg1, arg2), "");
  232.         case UFTIMES:    return(int_asc(asc_int(arg1) * asc_int(arg2)));
  233.         case UFTRIM:    return(trimstr(arg1));
  234.         case UFTRUTH:    return(ltos(asc_int(arg1) == 42));
  235.         case UFUPPER:    return(mkupper(arg1));
  236.         case UFXLATE:    return(xlat(arg1, arg2, arg3));
  237.     }
  238.  
  239.     meexit(-11);    /* never should get here */
  240. }
  241.  
  242. char *PASCAL NEAR gtusr(vname)    /* look up a user var's value */
  243.  
  244. char *vname;        /* name of user variable to fetch */
  245.  
  246. {
  247.     register int vnum;    /* ordinal number of user var */
  248.     register char *vptr;    /* temp pointer to function value */
  249.     register UTABLE *ut;    /* ptr to the current variable table */
  250.  
  251.     /* limit comparisons to significant length */
  252.     if (strlen(vname) >= NVSIZE)    /* "%" counts, but is not passed */
  253.         vname[NVSIZE] = '\0';
  254.     
  255.     /* scan through each user variable table starting with the
  256.        most local and going to the global table */
  257.     ut = uv_head;
  258.     while (ut) {
  259.  
  260.         /* scan this table looking for the user var name */
  261.         for (vnum = 0; vnum < ut->size; vnum++) {
  262.  
  263.             /* out of entries? */
  264.             if (ut->uv[vnum].u_name[0] == 0)
  265.                 goto next_ut;
  266.  
  267.             /* is this the one? */
  268.             if (strcmp(vname, ut->uv[vnum].u_name) == 0) {
  269.  
  270.                 /* return its value..... */
  271.                 vptr = ut->uv[vnum].u_value;
  272.                 if (vptr)
  273.                     return(vptr);
  274.                 else
  275.                     return(errorm);
  276.             }
  277.         }
  278.  
  279. next_ut:    ut = ut->next;
  280.     }
  281.  
  282.     /* return errorm if we run off the end */
  283.     return(errorm);
  284. }
  285.  
  286. char *PASCAL NEAR funval(i)
  287.  
  288. int i;
  289.  
  290. {
  291.     return(funcs[i].f_name);
  292. }
  293.  
  294. char *PASCAL NEAR envval(i)
  295.  
  296. int i;
  297.  
  298. {
  299.     return(envars[i]);
  300. }
  301.  
  302. PASCAL NEAR binary(key, tval, tlength, klength)
  303.  
  304. char *key;        /* key string to look for */
  305. char *(PASCAL NEAR *tval)();    /* ptr to function to fetch table value with */
  306. int tlength;        /* length of table to search */
  307. int klength;        /* maximum length of string to compare */
  308.  
  309. {
  310.     int l, u;    /* lower and upper limits of binary search */
  311.     int i;        /* current search index */
  312.     int cresult;    /* result of comparison */
  313.  
  314.     /* set current search limit as entire list */
  315.     l = 0;
  316.     u = tlength - 1;
  317.  
  318.     /* get the midpoint! */
  319.     while (u >= l) {
  320.         i = (l + u) >> 1;
  321.  
  322.         /* do the comparison */
  323.         cresult = strncmp(key, (*tval)(i), klength);
  324.         if (cresult == 0)
  325.             return(i);
  326.         if (cresult < 0)
  327.             u = i - 1;
  328.         else
  329.             l = i + 1;
  330.     }
  331.     return(-1);
  332. }
  333.  
  334. char *PASCAL NEAR gtenv(vname)
  335.  
  336. char *vname;        /* name of environment variable to retrieve */
  337.  
  338. {
  339.     register int vnum;    /* ordinal number of var refrenced */
  340.     static char result[2 * NSTRING];    /* string result */
  341.  
  342.     /* scan the list, looking for the referenced name */
  343.     vnum = binary(vname, envval, NEVARS, NVSIZE);
  344.  
  345.     /* return errorm on a bad reference */
  346.     if (vnum == -1)
  347.         return(errorm);
  348.  
  349.     /* otherwise, fetch the appropriate value */
  350.     switch (vnum) {
  351.         case EVABBELL:    return(ltos(ab_bell));
  352.         case EVABCAP:    return(ltos(ab_cap));
  353.         case EVABQUICK:    return(ltos(ab_quick));
  354.         case EVACOUNT:    return(int_asc(gacount));
  355.         case EVASAVE:    return(int_asc(gasave));
  356.         case EVBUFHOOK: return(fixnull(getfname(&bufhook)));
  357.         case EVCBFLAGS: return(int_asc(curbp->b_flag));
  358.         case EVCBUFNAME:return(curbp->b_bname);
  359.         case EVCFNAME:    return(curbp->b_fname);
  360.         case EVCMDHK:    return(fixnull(getfname(&cmdhook)));
  361.         case EVCMODE:    return(int_asc(curbp->b_mode));
  362.         case EVCURCHAR:
  363.             return(lused(curwp->w_dotp) ==
  364.                     curwp->w_doto ? int_asc('\r') :
  365.                 int_asc(lgetc(curwp->w_dotp, curwp->w_doto)));
  366.         case EVCURCOL:    return(int_asc(getccol(FALSE)));
  367.         case EVCURLINE: return(long_asc(getlinenum(curbp, curwp->w_dotp)));
  368.         case EVCURWIDTH:return(int_asc(term.t_ncol));
  369.         case EVCURWIND: return(int_asc(getcwnum()));
  370.         case EVCWLINE:    return(int_asc(getwpos()));
  371.         case EVDEBUG:    return(ltos(macbug));
  372.         case EVDESKCLR: return(cname[deskcolor]);
  373.         case EVDIAGFLAG:return(ltos(diagflag));
  374.         case EVDISCMD:    return(ltos(discmd));
  375.         case EVDISINP:    return(ltos(disinp));
  376.         case EVDISPHIGH:return(ltos(disphigh));
  377.         case EVDISPUNDO:return(ltos(dispundo));
  378.         case EVEXBHOOK: return(fixnull(getfname(&exbhook)));
  379.         case EVEXITHOOK:return(fixnull(getfname(&exithook)));
  380.         case EVFCOL:    return(int_asc(curwp->w_fcol));
  381.         case EVFILLCOL: return(int_asc(fillcol));
  382.         case EVFLICKER: return(ltos(flickcode));
  383.         case EVFMTLEAD: return(fmtlead);
  384.         case EVGFLAGS:    return(int_asc(gflags));
  385.         case EVGMODE:    return(int_asc(gmode));
  386.         case EVHARDTAB: return(int_asc(tabsize));
  387.         case EVHILITE:    return(int_asc(hilite));
  388.         case EVHJUMP:    return(int_asc(hjump));
  389.         case EVHSCRLBAR: return(ltos(hscrollbar));
  390.         case EVHSCROLL: return(ltos(hscroll));
  391.         case EVISTERM:    return(cmdstr(isterm, result));
  392.         case EVKILL:    return(getkill());
  393.         case EVLANG:    return(LANGUAGE);
  394.         case EVLASTKEY: return(int_asc(lastkey));
  395.         case EVLASTMESG:return(lastmesg);
  396.         case EVLINE:    return(getctext(result));
  397.         case EVLTERM:    return(lterm);
  398.         case EVLWIDTH:    return(int_asc(lused(curwp->w_dotp)));
  399.         case EVMATCH:    return(fixnull(patmatch));
  400.         case EVMMOVE:    return(int_asc(mouse_move));
  401.         case EVMODEFLAG:return(ltos(modeflag));
  402.         case EVMSFLAG:    return(ltos(mouseflag));
  403.         case EVNEWSCRN:    return(ltos(newscreenflag));
  404.         case EVNUMWIND: return(int_asc(gettwnum()));
  405.         case EVORGCOL:    return(int_asc(term.t_colorg));
  406.         case EVORGROW:    return(int_asc(term.t_roworg));
  407.         case EVOS:    return(os);
  408.         case EVOVERLAP: return(int_asc(overlap));
  409.         case EVPAGELEN: return(int_asc(term.t_nrow + 1));
  410.         case EVPALETTE: return(palstr);
  411.         case EVPARALEAD:return(paralead);
  412.         case EVPENDING:
  413. #if    TYPEAH || WINDOW_MSWIN
  414.                 return(ltos(typahead()));
  415. #else
  416.                 return(falsem);
  417. #endif
  418.         case EVPOPFLAG: return(ltos(popflag));
  419.         case EVPOPWAIT: return(ltos(popwait));
  420.         case EVPOSFLAG: return(ltos(posflag));
  421.         case EVPROGNAME:return(PROGNAME);
  422.         case EVRAM:    return(int_asc((int)(envram / 1024l)));
  423.         case EVREADHK:    return(fixnull(getfname(&readhook)));
  424.         case EVREGION:    return(getreg(result));
  425.         case EVREPLACE: return((char *)rpat);
  426.         case EVRVAL:    return(rval);
  427.         case EVSCRNAME: return(first_screen->s_screen_name);
  428.         case EVSEARCH:    return((char *)pat);
  429.         case EVSEARCHPNT:    return(int_asc(searchtype));
  430.         case EVSEED:    return(int_asc((int)seed));
  431.         case EVSOFTTAB: return(int_asc(stabsize));
  432.         case EVSRES:    return(sres);
  433.         case EVSSAVE:    return(ltos(ssave));
  434.         case EVSSCROLL: return(ltos(sscroll));
  435.         case EVSTATUS:    return(ltos(cmdstatus));
  436.         case EVSTERM:    return(cmdstr(sterm, result));
  437.         case EVTARGET:    saveflag = lastflag;
  438.                 return(int_asc(curgoal));
  439.         case EVTIME:    return(timeset());
  440.         case EVTIMEFLAG: return(ltos(timeflag));
  441.         case EVTPAUSE:    return(int_asc(term.t_pause));
  442.         case EVUNDOFLAG: return(ltos(undoflag));
  443.         case EVVERSION: return(VERSION);
  444.         case EVVSCRLBAR: return(ltos(vscrollbar));
  445.         case EVWCHARS:    return(getwlist(result));
  446.         case EVWLINE:    return(int_asc(curwp->w_ntrows));
  447.         case EVWRAPHK:    return(fixnull(getfname(&wraphook)));
  448.         case EVWRITEHK: return(fixnull(getfname(&writehook)));
  449.         case EVXPOS:    return(int_asc(xpos));
  450.         case EVYANKFLAG: return(ltos(yankflag));
  451.         case EVYPOS:    return(int_asc(ypos));
  452.     }
  453.     meexit(-12);    /* again, we should never get here */
  454. }
  455.  
  456. char *PASCAL NEAR fixnull(s)    /* Don't return NULL pointers! */
  457.  
  458. char *s;
  459.  
  460. {
  461.     if (s == NULL)
  462.         return("");
  463.     else
  464.         return(s);
  465. }
  466.  
  467. /* return some of the contents of the kill buffer */
  468.  
  469. char *PASCAL NEAR getkill()
  470.  
  471. {
  472.     register int size;    /* max number of chars left to return */
  473.     register char *sp;    /* ptr into KILL block data chunk */
  474.     register char *vp;    /* ptr into return value */
  475.     KILL *kptr;        /* ptr to the current KILL block */
  476.     int counter;        /* index into data chunk */
  477.     static char value[NSTRING];    /* temp buffer for value */
  478.  
  479.     /* no kill buffer....just a null string */
  480.     if (kbufh[kill_index] == (KILL *)NULL) {
  481.         value[0] = 0;
  482.         return(value);
  483.     }
  484.  
  485.     /* set up the output buffer */
  486.     vp = value;
  487.     size = NSTRING - 1;
  488.  
  489.     /* backed up characters? */
  490.     if (kskip[kill_index] > 0) {
  491.         kptr = kbufh[kill_index];
  492.         sp = &(kptr->d_chunk[kskip[kill_index]]);
  493.         counter = kskip[kill_index];
  494.         while (counter++ < KBLOCK) {
  495.             *vp++ = *sp++;
  496.             if (--size == 0) {
  497.                 *vp = 0;
  498.                 return(value);
  499.             }
  500.         }
  501.         kptr = kptr->d_next;
  502.     } else {
  503.         kptr = kbufh[kill_index];
  504.     }
  505.  
  506.     if (kptr != (KILL *)NULL) {
  507.         while (kptr != kbufp[kill_index]) {
  508.             sp = kptr->d_chunk;
  509.             for (counter = 0; counter < KBLOCK; counter++) {
  510.                 *vp++ = *sp++;
  511.                 if (--size == 0) {
  512.                     *vp = 0;
  513.                     return(value);
  514.                 }
  515.             }
  516.             kptr = kptr->d_next;
  517.         }
  518.         counter = kused[kill_index];
  519.         sp = kptr->d_chunk;
  520.         while (counter--) {
  521.             *vp++ = *sp++;
  522.             if (--size == 0) {
  523.                 *vp = 0;
  524.                 return(value);
  525.             }
  526.         }
  527.     }
  528.         
  529.     /* and return the constructed value */
  530.     *vp = 0;
  531.     return(value);
  532. }
  533.  
  534. char *PASCAL NEAR trimstr(s)    /* trim whitespace off the end of a string */
  535.  
  536. char *s;    /* string to trim */
  537.  
  538. {
  539.     char *sp;    /* backward index */
  540.  
  541.     sp = s + strlen(s) - 1;
  542.     while ((sp >= s) && (*sp == ' ' || *sp == '\t'))
  543.         --sp;
  544.     *(sp+1) = 0;
  545.     return(s);
  546. }
  547.  
  548. int PASCAL NEAR setvar(f, n)        /* set a variable */
  549.  
  550. int f;        /* default flag */
  551. int n;        /* numeric arg (can overide prompted value) */
  552.  
  553. {
  554.     register int status;    /* status return */
  555.     VDESC vd;        /* variable num/type */
  556.     char var[NVSIZE+1];    /* name of variable to fetch */
  557.     char value[NSTRING];    /* value to set variable to */
  558.  
  559.     /* first get the variable to set.. */
  560.     if (clexec == FALSE) {
  561.         status = mlreply(TEXT51, &var[0], NVSIZE+1);
  562. /*                 "Variable to set: " */
  563.         if (status != TRUE)
  564.             return(status);
  565.     } else {    /* macro line argument */
  566.         /* grab token and skip it */
  567.         execstr = token(execstr, var, NVSIZE + 1);
  568.     }
  569.  
  570.     /* check the legality and find the var */
  571.     findvar(var, &vd, NVSIZE + 1, VT_GLOBAL);
  572.         
  573.     /* if its not legal....bitch */
  574.     if (vd.v_type == -1) {
  575.         mlwrite(TEXT52, var);
  576. /*            "%%No such variable as '%s'" */
  577.         return(FALSE);
  578.     }
  579.  
  580.     /* get the value for that variable */
  581.     if (f == TRUE)
  582.         strcpy(value, int_asc(n));
  583.     else {
  584.         status = mlreply(TEXT53, &value[0], NSTRING);
  585. /*                 "Value: " */
  586.         if (status == ABORT)
  587.             return(status);
  588.     }
  589.  
  590.     /* and set the appropriate value */
  591.     status = svar(&vd, value);
  592.  
  593.     /* if $debug == TRUE, every assignment will echo a statment to
  594.        that effect here. */
  595.         
  596.     if (macbug && (strcmp(var, "%track") != 0)) {
  597.         strcpy(outline, "(((");
  598.  
  599.         strcat(outline, var);
  600.         strcat(outline, " <- ");
  601.  
  602.         /* and lastly the value we tried to assign */
  603.         strcat(outline, value);
  604.         strcat(outline, ")))");
  605.  
  606.         /* write out the debug line */
  607.         mlforce(outline);
  608.         update(TRUE);
  609.  
  610.         /* and get the keystroke to hold the output */
  611.         if (get_key() == abortc) {
  612.             mlforce(TEXT54);
  613. /*                "[Macro aborted]" */
  614.             status = FALSE;
  615.         }
  616.     }
  617.  
  618.     /* and return it */
  619.     return(status);
  620. }
  621.  
  622. int PASCAL NEAR global_var(f, n)    /* declare a global variable */
  623.  
  624. int f;        /* default flag */
  625. int n;        /* numeric arg (ignored here) */
  626.  
  627. {
  628.     register int status;    /* status return */
  629.     VDESC vd;        /* variable num/type */
  630.     char var[NVSIZE+1];    /* name of variable to fetch */
  631.  
  632.     /* first get the variable to set.. */
  633.     if (clexec == FALSE) {
  634.         status = mlreply(TEXT249, &var[0], NVSIZE+1);
  635. /*                 "Global variable to declare: " */
  636.         if (status != TRUE)
  637.             return(status);
  638.     } else {    /* macro line argument */
  639.         /* grab token and skip it */
  640.         execstr = token(execstr, var, NVSIZE + 1);
  641.     }
  642.  
  643.     /* check the legality and find the var */
  644.     findvar(var, &vd, NVSIZE + 1, VT_GLOBAL);
  645.         
  646.     /* if its not legal....bitch */
  647.     if (vd.v_type == -1) {
  648.         mlwrite(TEXT52, var);
  649. /*            "%%No such variable as '%s'" */
  650.         return(FALSE);
  651.     }
  652.  
  653.     /* and set the appropriate value */
  654.     status = svar(&vd, "");
  655.  
  656.     /* if $debug == TRUE, every assignment will echo a statment to
  657.        that effect here. */
  658.         
  659.     if (macbug && (strcmp(var, "%track") != 0)) {
  660.         strcpy(outline, "(((Globally declare ");
  661.  
  662.         strcat(outline, var);
  663.         strcat(outline, ")))");
  664.  
  665.         /* write out the debug line */
  666.         mlforce(outline);
  667.         update(TRUE);
  668.  
  669.         /* and get the keystroke to hold the output */
  670.         if (get_key() == abortc) {
  671.             mlforce(TEXT54);
  672. /*                "[Macro aborted]" */
  673.             status = FALSE;
  674.         }
  675.     }
  676.  
  677.     /* and return it */
  678.     return(status);
  679. }
  680.  
  681. int PASCAL NEAR local_var(f, n)    /* declare a local variable */
  682.  
  683. int f;        /* default flag */
  684. int n;        /* numeric arg (ignored here) */
  685.  
  686. {
  687.     register int status;    /* status return */
  688.     VDESC vd;        /* variable num/type */
  689.     char var[NVSIZE+1];    /* name of variable to fetch */
  690.  
  691.     /* first get the variable to set.. */
  692.     if (clexec == FALSE) {
  693.         status = mlreply(TEXT250, &var[0], NVSIZE+1);
  694. /*                 "Local variable to declare: " */
  695.         if (status != TRUE)
  696.             return(status);
  697.     } else {    /* macro line argument */
  698.         /* grab token and skip it */
  699.         execstr = token(execstr, var, NVSIZE + 1);
  700.     }
  701.  
  702.     /* check the legality and find the var */
  703.     findvar(var, &vd, NVSIZE + 1, VT_LOCAL);
  704.         
  705.     /* if its not legal....bitch */
  706.     if (vd.v_type == -1) {
  707.         mlwrite(TEXT52, var);
  708. /*            "%%No such variable as '%s'" */
  709.         return(FALSE);
  710.     }
  711.  
  712.     /* and set the appropriate value */
  713.     status = svar(&vd, "");
  714.  
  715.     /* if $debug == TRUE, every assignment will echo a statment to
  716.        that effect here. */
  717.         
  718.     if (macbug && (strcmp(var, "%track") != 0)) {
  719.         strcpy(outline, "(((Locally declare ");
  720.  
  721.         strcat(outline, var);
  722.         strcat(outline, ")))");
  723.  
  724.         /* write out the debug line */
  725.         mlforce(outline);
  726.         update(TRUE);
  727.  
  728.         /* and get the keystroke to hold the output */
  729.         if (get_key() == abortc) {
  730.             mlforce(TEXT54);
  731. /*                "[Macro aborted]" */
  732.             status = FALSE;
  733.         }
  734.     }
  735.  
  736.     /* and return it */
  737.     return(status);
  738. }
  739.  
  740. /* find a variables type and name */
  741.  
  742. VOID PASCAL NEAR findvar(var, vd, size, scope)
  743.  
  744. char *var;    /* name of var to get */
  745. VDESC *vd;    /* structure to hold type and ptr */
  746. int size;    /* size of var array */
  747. int scope;    /* intended scope of any created user variables */
  748.  
  749. {
  750.     register int vnum;    /* subscript in varable arrays */
  751.     register int vtype;    /* type to return */
  752.     register UTABLE *vut;    /* user var table to search */
  753.  
  754. fvar:    vtype = -1;
  755.     vut = uv_head;
  756.  
  757.     switch (var[0]) {
  758.  
  759.         case '$': /* check for legal enviromnent var */
  760.             if ((vnum = binary(&var[1], envval, NEVARS, NVSIZE)) != -1)
  761.                 vtype = TKENV;
  762.             break;
  763.  
  764.         case '%': /* check for existing legal user variable */
  765.             while (vut) {
  766.                 for (vnum = 0; vnum < vut->size; vnum++)
  767.                     if (strcmp(&var[1],
  768.                         vut->uv[vnum].u_name) == 0) {
  769.                         vtype = TKVAR;
  770.                         goto retvar;
  771.                     }
  772.                 vut = vut->next;
  773.                 if (scope == VT_LOCAL)
  774.                     break;
  775.             }
  776.  
  777.             /* if we should not define one.... */
  778.             if (scope == VT_NONE)
  779.                 break;
  780.  
  781.             /* scope it as requested */
  782.             if (scope == VT_LOCAL)
  783.                 vut = uv_head;
  784.             else
  785.                 vut = uv_global;
  786.  
  787.             /* no room left in requested user var table? */
  788.             if (vnum < vut->size)
  789.                 break;
  790.  
  791.             /* create a new variable */
  792.             for (vnum = 0; vnum < vut->size; vnum++)
  793.                 if (vut->uv[vnum].u_name[0] == 0) {
  794.                     vtype = TKVAR;
  795.                     memset((char *)&vut->uv[vnum].u_name[0], '\0', NVSIZE);
  796.                     strncpy(vut->uv[vnum].u_name, &var[1], NVSIZE);
  797.                     vut->uv[vnum].u_value = NULL;
  798.                     break;
  799.                 }
  800.             break;
  801.  
  802.         case '&':    /* indirect operator? */
  803.             var[4] = 0;
  804.             if (strcmp(&var[1], "ind") == 0) {
  805.                 /* grab token, and eval it */
  806.                 execstr = token(execstr, var, size);
  807.                 strcpy(var, fixnull(getval(var)));
  808.                 goto fvar;
  809.             }
  810.     }
  811.  
  812.     /* return the results */
  813. retvar:    vd->v_num = vnum;
  814.     vd->v_type = vtype;
  815.     vd->v_ut = vut;
  816.     return;
  817. }
  818.  
  819. int PASCAL NEAR svar(var, value)    /* set a variable */
  820.  
  821. VDESC *var;    /* variable to set */
  822. char *value;    /* value to set to */
  823.  
  824. {
  825.     register int vnum;    /* ordinal number of var refrenced */
  826.     register int vtype;    /* type of variable to set */
  827.     register UTABLE *vut;    /* user table pointer */
  828.     register int status;    /* status return */
  829.     register int c;     /* translated character */
  830.     register char *sp;    /* scratch string pointer */
  831.  
  832.     /* simplify the vd structure (we are gonna look at it a lot) */
  833.     vnum = var->v_num;
  834.     vtype = var->v_type;
  835.     vut = var->v_ut;
  836.  
  837.     /* and set the appropriate value */
  838.     status = TRUE;
  839.     switch (vtype) {
  840.     case TKVAR: /* set a user variable */
  841.         if (vut->uv[vnum].u_value != NULL)
  842.             free(vut->uv[vnum].u_value);
  843.         sp = room(strlen(value) + 1);
  844.         if (sp == NULL)
  845.             return(FALSE);
  846.         strcpy(sp, value);
  847.         vut->uv[vnum].u_value = sp;
  848.  
  849.         /* setting a variable to error stops macro execution */
  850.         if (strcmp(value, errorm) == 0)
  851.             status = FALSE;
  852.  
  853.         break;
  854.  
  855.     case TKENV: /* set an environment variable */
  856.         status = TRUE;    /* by default */
  857.  
  858.         switch (vnum) {
  859.         case EVABBELL:    ab_bell = stol(value);
  860.                 break;
  861.         case EVABCAP:    ab_cap = stol(value);
  862.                 break;
  863.         case EVABQUICK:    ab_quick = stol(value);
  864.                 break;
  865.         case EVACOUNT:    gacount = asc_int(value);
  866.                 break;
  867.         case EVASAVE:    gasave = asc_int(value);
  868.                 break;
  869.         case EVBUFHOOK: set_key(&bufhook, value);
  870.                 break;
  871.         case EVCBFLAGS: c = asc_int(value);
  872.                 curbp->b_flag = (curbp->b_flag & ~(BFCHG|BFINVS))
  873.                     | (c & (BFCHG|BFINVS));
  874.                 if ((c & BFCHG) == BFCHG)
  875.                     lchange(WFMODE);
  876.                 break;
  877.         case EVCBUFNAME:strcpy(curbp->b_bname, value);
  878.                 curwp->w_flag |= WFMODE;
  879.                 break;
  880.         case EVCFNAME:    strcpy(curbp->b_fname, value);
  881. #if    WINDOW_MSWIN
  882.                 fullpathname(curbp->b_fname, NFILEN);
  883. #endif
  884.                 curwp->w_flag |= WFMODE;
  885.                 break;
  886.         case EVCMDHK:    set_key(&cmdhook, value);
  887.                 break;
  888.         case EVCMODE:    curbp->b_mode = asc_int(value);
  889.                 curwp->w_flag |= WFMODE;
  890.                 break;
  891.         case EVCURCHAR: ldelete(1L, FALSE);    /* delete 1 char */
  892.                 c = asc_int(value);
  893.                 if (c == '\r')
  894.                     lnewline();
  895.                 else
  896.                     linsert(1, (char)c);
  897.                 backchar(FALSE, 1);
  898.                 break;
  899.         case EVCURCOL:    status = setccol(asc_int(value));
  900.                 break;
  901.         case EVCURLINE: status = gotoline(TRUE, asc_int(value));
  902.                 break;
  903.         case EVCURWIDTH:status = newwidth(TRUE, asc_int(value));
  904.                 break;
  905.         case EVCURWIND: nextwind(TRUE, asc_int(value));
  906.                 break;
  907.         case EVCWLINE:    status = forwline(TRUE,
  908.                         asc_int(value) - getwpos());
  909.                 break;
  910.         case EVDEBUG:    macbug = stol(value);
  911.                 break;
  912.         case EVDESKCLR: c = lookup_color(mkupper(value));
  913.                 if (c != -1) {
  914.                     deskcolor = c;
  915. #if    WINDOW_TEXT
  916.                     refresh_screen(first_screen);
  917. #endif
  918.                 }
  919.                 break;
  920.         case EVDIAGFLAG:diagflag = stol(value);
  921.                 break;
  922.         case EVDISCMD:    discmd = stol(value);
  923.                 break;
  924.         case EVDISINP:    disinp = stol(value);
  925.                 break;
  926.         case EVDISPHIGH:
  927.                 c = disphigh;
  928.                 disphigh = stol(value);
  929.                 if (c != disphigh)
  930.                     upwind();
  931.                 break;
  932.         case EVDISPUNDO:
  933.                 dispundo = stol(value);
  934.                 break;
  935.         case EVEXBHOOK: set_key(&exbhook, value);
  936.                 break;
  937.         case EVEXITHOOK:set_key(&exithook, value);
  938.                 break;
  939.         case EVFCOL:    curwp->w_fcol = asc_int(value);
  940.                 if (curwp->w_fcol < 0)
  941.                     curwp->w_fcol = 0;
  942.                 curwp->w_flag |= WFHARD | WFMODE;
  943.                 break;
  944.         case EVFILLCOL: fillcol = asc_int(value);
  945.                 break;
  946.         case EVFLICKER: flickcode = stol(value);
  947.                 break;
  948.         case EVFMTLEAD: bytecopy(fmtlead, value, NSTRING);
  949.                 break;
  950.         case EVGFLAGS:    gflags = asc_int(value);
  951.                 break;
  952.         case EVGMODE:    gmode = asc_int(value);
  953.                 break;
  954.         case EVHARDTAB: if ((c = asc_int(value)) >= 0)
  955.                 {
  956.                     tabsize = c;
  957.                     upwind();
  958.                 }
  959.                 break;
  960.         case EVHILITE:    hilite = asc_int(value);
  961.                 if (hilite > NMARKS)
  962.                     hilite = 255;
  963.                 break;
  964.         case EVHJUMP:    hjump = asc_int(value);
  965.                 if (hjump < 1)
  966.                     hjump = 1;
  967.                 if (hjump > term.t_ncol - 1)
  968.                     hjump = term.t_ncol - 1;
  969.                 break;
  970.         case EVHSCRLBAR: hscrollbar = stol(value);
  971.                 break;
  972.         case EVHSCROLL: hscroll = stol(value);
  973.                 lbound = 0;
  974.                 break;
  975.         case EVISTERM:    isterm = stock(value);
  976.                 break;
  977.         case EVKILL:    break;
  978.         case EVLANG:    break;
  979.         case EVLASTKEY: lastkey = asc_int(value);
  980.                 break;
  981.         case EVLASTMESG:strcpy(lastmesg, value);
  982.                 break;
  983.         case EVLINE:    putctext(value);
  984.                 break;
  985.         case EVLTERM:    bytecopy(lterm, value, NSTRING);
  986.                 break;
  987.         case EVLWIDTH:    break;
  988.         case EVMATCH:    break;
  989.         case EVMMOVE:    mouse_move = asc_int(value);
  990.                 if (mouse_move < 0) mouse_move = 0;
  991.                 if (mouse_move > 2) mouse_move = 2;
  992.                 break;
  993.         case EVMODEFLAG:modeflag = stol(value);
  994.                 upwind();
  995.                 break;
  996.         case EVMSFLAG:    mouseflag = stol(value);
  997.                 break;
  998.         case EVNEWSCRN:    newscreenflag = stol(value);
  999.                 break;
  1000.         case EVNUMWIND: break;
  1001.         case EVORGCOL:    status = new_col_org(TRUE, asc_int(value));
  1002.                 break;
  1003.         case EVORGROW:    status = new_row_org(TRUE, asc_int(value));
  1004.                 break;
  1005.         case EVOS:    break;
  1006.         case EVOVERLAP: overlap = asc_int(value);
  1007.                 break;
  1008.         case EVPAGELEN: status = newsize(TRUE, asc_int(value));
  1009.                 break;
  1010.         case EVPALETTE: bytecopy(palstr, value, 48);
  1011.                 spal(palstr);
  1012.                 break;
  1013.         case EVPARALEAD:bytecopy(paralead, value, NSTRING);
  1014.                 break;
  1015.         case EVPENDING: break;
  1016.         case EVPOPFLAG: popflag = stol(value);
  1017.                 break;
  1018.         case EVPOPWAIT: popwait = stol(value);
  1019.                 break;
  1020.         case EVPOSFLAG: posflag = stol(value);
  1021.                 upmode();
  1022.                 break;
  1023.         case EVPROGNAME:break;
  1024.         case EVRAM:    break;
  1025.         case EVREADHK:    set_key(&readhook, value);
  1026.                 break;
  1027.         case EVREGION:    break;
  1028.         case EVREPLACE: strcpy((char *)rpat, value);
  1029. #if    MAGIC
  1030.                 rmcclear();
  1031. #endif 
  1032.                 break;
  1033.         case EVRVAL:    strcpy(rval, value);
  1034.                 break;
  1035.         case EVSCRNAME: select_screen(lookup_screen(value), TRUE);
  1036.                 break;
  1037.         case EVSEARCH:    strcpy((char *)pat, value);
  1038.                 setjtable(); /* Set up fast search arrays  */
  1039. #if    MAGIC
  1040.                 mcclear();
  1041. #endif
  1042.                 break;
  1043.         case EVSEARCHPNT:    searchtype = asc_int(value);
  1044.                 if (searchtype < SRNORM  || searchtype > SREND)
  1045.                     searchtype = SRNORM;
  1046.                 break;
  1047.         case EVSEED:    seed = (long)abs(asc_int(value));
  1048.                 break;
  1049.         case EVSOFTTAB: stabsize = asc_int(value);
  1050.                 upwind();
  1051.                 break;
  1052.         case EVSRES:    status = TTrez(value);
  1053.                 break;
  1054.         case EVSSAVE:    ssave = stol(value);
  1055.                 break;
  1056.         case EVSSCROLL: sscroll = stol(value);
  1057.                 break;
  1058.         case EVSTATUS:    cmdstatus = stol(value);
  1059.                 break;
  1060.         case EVSTERM:    sterm = stock(value);
  1061.                 break;
  1062.         case EVTARGET:    curgoal = asc_int(value);
  1063.                 thisflag = saveflag;
  1064.                 break;
  1065.         case EVTIME:    break;
  1066.         case EVTIMEFLAG: timeflag = stol(value);
  1067.                 upmode();
  1068.                 break;
  1069.         case EVTPAUSE:    term.t_pause = asc_int(value);
  1070.                 break;
  1071.         case EVUNDOFLAG:if (undoflag != stol(value))
  1072.                     undo_dump();
  1073.                 undoflag = stol(value);
  1074.                 break;
  1075.         case EVVERSION: break;
  1076.         case EVVSCRLBAR: vscrollbar = stol(value);
  1077.                 break;
  1078.         case EVWCHARS:    setwlist(value);
  1079.                 break;
  1080.         case EVWLINE:    status = resize(TRUE, asc_int(value));
  1081.                 break;
  1082.         case EVWRAPHK:    set_key(&wraphook, value);
  1083.                 break;
  1084.         case EVWRITEHK: set_key(&writehook, value);
  1085.                 break;
  1086.         case EVXPOS:    xpos = asc_int(value);
  1087.                 break;
  1088.         case EVYANKFLAG:    yankflag = stol(value);
  1089.                 break;
  1090.         case EVYPOS:    ypos = asc_int(value);
  1091.                 break;
  1092.         }
  1093.         break;
  1094.     }
  1095.     return(status);
  1096. }
  1097.  
  1098. /*    asc_int:    ascii string to integer......This is too
  1099.         inconsistant to use the system's    */
  1100.  
  1101. int PASCAL NEAR asc_int(st)
  1102.  
  1103. char *st;
  1104.  
  1105. {
  1106.     int result;    /* resulting number */
  1107.     int sign;    /* sign of resulting number */
  1108.     char c;     /* current char being examined */
  1109.  
  1110.     result = 0;
  1111.     sign = 1;
  1112.  
  1113.     /* skip preceding whitespace */
  1114.     while (*st == ' ' || *st == '\t')
  1115.         ++st;
  1116.  
  1117.     /* check for sign */
  1118.     if (*st == '-') {
  1119.         sign = -1;
  1120.         ++st;
  1121.     }
  1122.     if (*st == '+')
  1123.         ++st;
  1124.  
  1125.     /* scan digits, build value */
  1126.     while ((c = *st++))
  1127.         if (c >= '0' && c <= '9')
  1128.             result = result * 10 + c - '0';
  1129.         else
  1130.             break;
  1131.  
  1132.     return(result * sign);
  1133. }
  1134.  
  1135. /*    int_asc:    integer to ascii string.......... This is too
  1136.             inconsistant to use the system's    */
  1137.  
  1138. char *PASCAL NEAR int_asc(i)
  1139.  
  1140. int i;    /* integer to translate to a string */
  1141.  
  1142. {
  1143.     register int digit;        /* current digit being used */
  1144.     register char *sp;        /* pointer into result */
  1145.     register int sign;        /* sign of resulting number */
  1146.     static char result[INTWIDTH+1]; /* resulting string */
  1147.  
  1148.     /* this is a special case */
  1149.     if (i == -32768) {
  1150.         strcpy(result, "-32768");
  1151.         return(result);
  1152.     }
  1153.  
  1154.     /* record the sign...*/
  1155.     sign = 1;
  1156.     if (i < 0) {
  1157.         sign = -1;
  1158.         i = -i;
  1159.     }
  1160.  
  1161.     /* and build the string (backwards!) */
  1162.     sp = result + INTWIDTH;
  1163.     *sp = 0;
  1164.     do {
  1165.         digit = i % 10;
  1166.         *(--sp) = '0' + digit;    /* and install the new digit */
  1167.         i = i / 10;
  1168.     } while (i);
  1169.  
  1170.     /* and fix the sign */
  1171.     if (sign == -1) {
  1172.         *(--sp) = '-';    /* and install the minus sign */
  1173.     }
  1174.  
  1175.     return(sp);
  1176. }
  1177.  
  1178. /*    long_asc:    long to ascii string.......... This is too
  1179.             inconsistant to use the system's    */
  1180.  
  1181. char *PASCAL NEAR long_asc(num)
  1182.  
  1183. long num;    /* integer to translate to a string */
  1184.  
  1185. {
  1186.     register int digit;        /* current digit being used */
  1187.     register char *sp;        /* pointer into result */
  1188.     register int sign;        /* sign of resulting number */
  1189.     static char result[LONGWIDTH+1]; /* resulting string */
  1190.  
  1191.     /* record the sign...*/
  1192.     sign = 1;
  1193.     if (num < 0L) {
  1194.         sign = -1;
  1195.         num = -num;
  1196.     }
  1197.  
  1198.     /* and build the string (backwards!) */
  1199.     sp = result + LONGWIDTH;
  1200.     *sp = 0;
  1201.     do {
  1202.         digit = num % 10;
  1203.         *(--sp) = '0' + digit;    /* and install the new digit */
  1204.         num = num / 10L;
  1205.     } while (num);
  1206.  
  1207.     /* and fix the sign */
  1208.     if (sign == -1) {
  1209.         *(--sp) = '-';    /* and install the minus sign */
  1210.     }
  1211.  
  1212.     return(sp);
  1213. }
  1214.  
  1215. int PASCAL NEAR gettyp(token)    /* find the type of a passed token */
  1216.  
  1217. char *token;    /* token to analyze */
  1218.  
  1219. {
  1220.     register char c;    /* first char in token */
  1221.  
  1222.     /* grab the first char (this is all we need) */
  1223.     c = *token;
  1224.  
  1225.     /* no blanks!!! */
  1226.     if (c == 0)
  1227.         return(TKNUL);
  1228.  
  1229.     /* a numeric literal? */
  1230.     if (c >= '0' && c <= '9')
  1231.         return(TKLIT);
  1232.  
  1233.     switch (c) {
  1234.         case '"':    return(TKSTR);
  1235.  
  1236.         case '!':    return(TKDIR);
  1237.         case '@':    return(TKARG);
  1238.         case '#':    return(TKBUF);
  1239.         case '$':    return(TKENV);
  1240.         case '%':    return(TKVAR);
  1241.         case '&':    return(TKFUN);
  1242.         case '*':    return(TKLBL);
  1243.  
  1244.         default:    return(TKCMD);
  1245.     }
  1246. }
  1247.  
  1248. char *PASCAL NEAR getval(token) /* find the value of a token */
  1249.  
  1250. char *token;        /* token to evaluate */
  1251.  
  1252. {
  1253.     register int status;    /* error return */
  1254.     register BUFFER *bp;    /* temp buffer pointer */
  1255.     register int blen;    /* length of buffer argument */
  1256.     static char buf[NSTRING];/* string buffer for some returns */
  1257.  
  1258.     switch (gettyp(token)) {
  1259.         case TKNUL:    return("");
  1260.  
  1261.         case TKARG:    /* interactive argument */
  1262.                 strcpy(token, fixnull(getval(&token[1])));
  1263.                 mlwrite("%s", token);
  1264.                 status = getstring(buf, NSTRING, ctoec(RETCHAR));
  1265.                 if (status == ABORT)
  1266.                     return(NULL);
  1267.                 return(buf);
  1268.  
  1269.         case TKBUF:    /* buffer contents fetch */
  1270.  
  1271.                 /* grab the right buffer */
  1272.                 strcpy(token, fixnull(getval(&token[1])));
  1273.                 bp = bfind(token, FALSE, 0);
  1274.                 if (bp == NULL)
  1275.                     return(NULL);
  1276.             
  1277.                 /* if the buffer is displayed, get the window
  1278.                    vars instead of the buffer vars */
  1279.                 if (bp->b_nwnd > 0) {
  1280.                     curbp->b_dotp = curwp->w_dotp;
  1281.                     curbp->b_doto = curwp->w_doto;
  1282.                 }
  1283.  
  1284.                 /* if we are at the end, return <END> */
  1285.                 if (bp->b_linep == bp->b_dotp)
  1286.                     return("<END>");
  1287.             
  1288.                 /* grab the line as an argument */
  1289.                 blen = lused(bp->b_dotp) - bp->b_doto;
  1290.                 if (blen > NSTRING)
  1291.                     blen = NSTRING;
  1292.                 bytecopy(buf, ltext(bp->b_dotp) + bp->b_doto,
  1293.                     blen);
  1294.                 buf[blen] = 0;
  1295.             
  1296.                 /* and step the buffer's line ptr ahead a line */
  1297.                 bp->b_dotp = lforw(bp->b_dotp);
  1298.                 bp->b_doto = 0;
  1299.  
  1300.                 /* if displayed buffer, reset window ptr vars*/
  1301.                 if (bp->b_nwnd > 0) {
  1302.                     curwp->w_dotp = curbp->b_dotp;
  1303.                     curwp->w_doto = 0;
  1304.                     curwp->w_flag |= WFMOVE;
  1305.                 }
  1306.  
  1307.                 /* and return the spoils */
  1308.                 return(buf);            
  1309.  
  1310.         case TKVAR:    return(gtusr(token+1));
  1311.         case TKENV:    return(gtenv(token+1));
  1312.         case TKFUN:    return(gtfun(token+1));
  1313.         case TKDIR:    return(NULL);
  1314.         case TKLBL:    return(NULL);
  1315.         case TKLIT:    return(token);
  1316.         case TKSTR:    return(token+1);
  1317.         case TKCMD:    return(token);
  1318.     }
  1319. }
  1320.  
  1321. int PASCAL NEAR stol(val)    /* convert a string to a numeric logical */
  1322.  
  1323. char *val;    /* value to check for stol */
  1324.  
  1325. {
  1326.     /* check for logical values */
  1327.     if (val[0] == 'F')
  1328.         return(FALSE);
  1329.     if (val[0] == 'T')
  1330.         return(TRUE);
  1331.  
  1332.     /* check for numeric truth (!= 0) */
  1333.     return((asc_int(val) != 0));
  1334. }
  1335.  
  1336. char *PASCAL NEAR ltos(val)    /* numeric logical to string logical */
  1337.  
  1338. int val;    /* value to translate */
  1339.  
  1340. {
  1341.     if (val)
  1342.         return(truem);
  1343.     else
  1344.         return(falsem);
  1345. }
  1346.  
  1347. char *PASCAL NEAR mkupper(str)    /* make a string upper case */
  1348.  
  1349. char *str;        /* string to upper case */
  1350.  
  1351. {
  1352.     char *sp;
  1353.  
  1354.     sp = str;
  1355.     while (*sp)
  1356.         uppercase((unsigned char *)sp++);
  1357.     return(str);
  1358. }
  1359.  
  1360. char *PASCAL NEAR mklower(str)    /* make a string lower case */
  1361.  
  1362. char *str;        /* string to lower case */
  1363.  
  1364. {
  1365.     char *sp;
  1366.  
  1367.     sp = str;
  1368.     while (*sp)
  1369.         lowercase((unsigned char *)sp++);
  1370.     return(str);
  1371. }
  1372.  
  1373. int PASCAL NEAR absv(x) /* take the absolute value of an integer */
  1374.  
  1375. int x;
  1376.  
  1377. {
  1378.     return(x < 0 ? -x : x);
  1379. }
  1380.  
  1381. long PASCAL NEAR ernd()    /* returns a random integer */
  1382.  
  1383. /* This function implements the "minimal standard" RNG
  1384.    from the paper "RNGs: Good Ones are Hard to Find" by Park and
  1385.    Miller, CACM, Volume 31, Number 10, October 1988. */
  1386.  
  1387. {
  1388.     long int a=16807L, m=2147483647L, q=127773L, r=2836L;
  1389.     long lo, hi, test;
  1390.  
  1391.     hi = seed / q;
  1392.     lo = seed % q;
  1393.     test = a * lo - r * hi;
  1394.     seed = (test > 0) ? test : test + m;
  1395.     return(seed);
  1396. }
  1397.  
  1398. int PASCAL NEAR sindex(source, pattern) /* find pattern within source */
  1399.  
  1400. char *source;    /* source string to search */
  1401. char *pattern;    /* string to look for */
  1402.  
  1403. {
  1404.     char *sp;    /* ptr to current position to scan */
  1405.     char *csp;    /* ptr to source string during comparison */
  1406.     char *cp;    /* ptr to place to check for equality */
  1407.  
  1408.     /* scanning through the source string */
  1409.     sp = source;
  1410.     while (*sp) {
  1411.         /* scan through the pattern */
  1412.         cp = pattern;
  1413.         csp = sp;
  1414.         while (*cp) {
  1415.             if (!eq(*cp, *csp))
  1416.                 break;
  1417.             ++cp;
  1418.             ++csp;
  1419.         }
  1420.  
  1421.         /* was it a match? */
  1422.         if (*cp == 0)
  1423.             return((int)(sp - source) + 1);
  1424.         ++sp;
  1425.     }
  1426.  
  1427.     /* no match at all.. */
  1428.     return(0);
  1429. }
  1430.  
  1431. /*    Filter a string through a translation table    */
  1432.  
  1433. char *PASCAL NEAR xlat(source, lookup, trans)
  1434.  
  1435. char *source;    /* string to filter */
  1436. char *lookup;    /* characters to translate */
  1437. char *trans;    /* resulting translated characters */
  1438.  
  1439. {
  1440.     register char *sp;    /* pointer into source table */
  1441.     register char *lp;    /* pointer into lookup table */
  1442.     register char *rp;    /* pointer into result */
  1443.     static char result[NSTRING];    /* temporary result */
  1444.  
  1445.     /* scan source string */
  1446.     sp = source;
  1447.     rp = result;
  1448.     while (*sp) {
  1449.         /* scan lookup table for a match */
  1450.         lp = lookup;
  1451.         while (*lp) {
  1452.             if (*sp == *lp) {
  1453.                 *rp++ = trans[lp - lookup];
  1454.                 goto xnext;
  1455.             }
  1456.             ++lp;
  1457.         }
  1458.  
  1459.         /* no match, copy in the source char untranslated */
  1460.         *rp++ = *sp;
  1461.  
  1462. xnext:        ++sp;
  1463.     }
  1464.  
  1465.     /* terminate and return the result */
  1466.     *rp = 0;
  1467.     return(result);
  1468. }
  1469.  
  1470. /*    setwlist:    Set an alternative list of character to be
  1471.             considered "in a word */
  1472.  
  1473. PASCAL NEAR setwlist(wclist)
  1474.  
  1475. char *wclist;    /* list of characters to consider "in a word" */
  1476.  
  1477. {
  1478.     register int index;
  1479.  
  1480.     /* if we are turning this facility off, just flag so */
  1481.     if (wclist == NULL || *wclist == 0) {
  1482.         wlflag = FALSE;
  1483.         return;
  1484.     }
  1485.  
  1486.     /* first clear the table */
  1487.     for (index = 0; index < 256; index++)
  1488.         wordlist[index] = FALSE;
  1489.  
  1490.     /* and for each character in the new value, set that element
  1491.        of the word character list */
  1492.     while (*wclist)
  1493.         wordlist[(unsigned char)(*wclist++)] = TRUE;    /* ep */
  1494.     wlflag = TRUE;
  1495.     return;
  1496. }
  1497.  
  1498. /*    getwlist:    place in a buffer a list of characters
  1499.             considered "in a word"            */
  1500.  
  1501. char *PASCAL NEAR getwlist(buf)
  1502.  
  1503. char *buf;    /* buffer to place list of characters */
  1504.  
  1505. {
  1506.     register int index;
  1507.     register char *sp;
  1508.  
  1509.     /* if we are defaulting to a standard word char list... */
  1510.     if (wlflag == FALSE)
  1511.         return("");
  1512.  
  1513.     /* build the string of characters in the return buffer */
  1514.     sp = buf;
  1515.     for (index = 0; index < 256; index++)
  1516.         if (wordlist[index])
  1517.             *sp++ = index;
  1518.     *sp = 0;
  1519.     return(buf);
  1520. }
  1521.  
  1522. /*    is_num: ascii string is integer......This is too
  1523.         inconsistant to use the system's    */
  1524.  
  1525. int PASCAL NEAR is_num(st)
  1526.  
  1527. char *st;
  1528.  
  1529. {
  1530.     int period_flag;    /* have we seen a period yet? */
  1531.  
  1532.     /* skip preceding whitespace */
  1533.     while (*st == ' ' || *st == '\t')
  1534.         ++st;
  1535.  
  1536.     /* check for sign */
  1537.     if ((*st == '-') || (*st == '+'))
  1538.         ++st;
  1539.  
  1540.     /* scan digits */
  1541.     period_flag = FALSE;
  1542.     while ((*st >= '0') && (*st <= '9') ||
  1543.            (*st == '.' && period_flag == FALSE)) {
  1544.         if (*st == '.')
  1545.             period_flag = TRUE;
  1546.         st++;
  1547.     }
  1548.  
  1549.     /* scan rest of line for just white space */
  1550.     while (*st) {
  1551.         if ((*st != '\t') && (*st != ' '))
  1552.             return(FALSE);
  1553.         st++;
  1554.     }
  1555.     return(TRUE);
  1556. }
  1557.  
  1558. int PASCAL NEAR dispvar(f, n)        /* display a variable's value */
  1559.  
  1560. int f;        /* default flag */
  1561. int n;        /* numeric arg (can overide prompted value) */
  1562.  
  1563. {
  1564.     register int status;    /* status return */
  1565.     VDESC vd;        /* variable num/type */
  1566.     char var[NVSIZE+1];    /* name of variable to fetch */
  1567.  
  1568.     /* first get the variable to display.. */
  1569.     if (clexec == FALSE) {
  1570.         status = mlreply(TEXT55, &var[0], NVSIZE+1);
  1571. /*                 "Variable to display: " */
  1572.         if (status != TRUE)
  1573.             return(status);
  1574.     } else {    /* macro line argument */
  1575.         /* grab token and skip it */
  1576.         execstr = token(execstr, var, NVSIZE + 1);
  1577.     }
  1578.  
  1579.     /* check the legality and find the var */
  1580.     findvar(var, &vd, NVSIZE + 1, VT_NONE);
  1581.         
  1582.     /* if its not legal....bitch */
  1583.     if (vd.v_type == -1) {
  1584.         mlwrite(TEXT52, var);
  1585. /*            "%%No such variable as '%s'" */
  1586.         return(FALSE);
  1587.     }
  1588.  
  1589.     /* and display the value */
  1590.     strcpy(outline, var);
  1591.     strcat(outline, " = ");
  1592.  
  1593.     /* and lastly the current value */
  1594.     strcat(outline, fixnull(getval(var)));
  1595.  
  1596.     /* write out the result */
  1597.     mlforce(outline);
  1598.     update(TRUE);
  1599.  
  1600.     /* and return */
  1601.     return(TRUE);
  1602. }
  1603.  
  1604. /*    describe-variables    Bring up a fake buffer and list the contents
  1605.                 of all the environment variables
  1606. */
  1607.  
  1608. PASCAL NEAR desvars(f, n)
  1609.  
  1610. int f,n;    /* prefix flag and argument */
  1611.  
  1612. {
  1613.     register BUFFER *varbuf;/* buffer to put variable list into */
  1614.     register int uindex;    /* index into uvar table */
  1615.     UTABLE *ut;        /* user variable table pointer */
  1616.     PARG *cur_arg;        /* ptr to buffers argument list */
  1617.     char outseq[256];    /* output buffer for keystroke sequence */
  1618.  
  1619.     /* and get a buffer for it */
  1620.     varbuf = bfind(TEXT56, TRUE, BFINVS);
  1621. /*           "Variable list" */
  1622.     if (varbuf == NULL || bclear(varbuf) == FALSE) {
  1623.         mlwrite(TEXT57);
  1624. /*            "Can not display variable list" */
  1625.         return(FALSE);
  1626.     }
  1627.  
  1628.     /* let us know this is in progress */
  1629.     mlwrite(TEXT58);
  1630. /*        "[Building variable list]" */
  1631.  
  1632.     /* build the environment variable list */
  1633.     for (uindex = 0; uindex < NEVARS; uindex++) {
  1634.  
  1635.         /* add in the environment variable name */
  1636.         strcpy(outseq, "$");
  1637.         strcat(outseq, envars[uindex]);
  1638.         pad(outseq, 14);
  1639.             
  1640.         /* add in the value */
  1641.         strcat(outseq, gtenv(envars[uindex]));
  1642.  
  1643.         /* and add it as a line into the buffer */
  1644.         if (addline(varbuf, outseq) != TRUE)
  1645.             return(FALSE);
  1646.     }
  1647.  
  1648.     /* build all the user variable lists */
  1649.     ut = uv_head;
  1650.     while (ut) {
  1651.  
  1652.         /* a blank line, please.... */
  1653.         if (addline(varbuf, "") != TRUE)
  1654.             return(FALSE);
  1655.  
  1656.         /* make a header for this list */
  1657.         strcpy(outseq, "----- ");
  1658.         if (ut->bufp == (BUFFER *)NULL)
  1659.             strcat(outseq, "Global User Variables");
  1660.         else {
  1661.             strcat(outseq, "Defined in ");
  1662.             strcat(outseq, ut->bufp->b_bname);
  1663.             if (ut->bufp->b_numargs > 0) {
  1664.                 strcat(outseq, "(");
  1665.                 cur_arg = ut->bufp->b_args;
  1666.                 while (cur_arg) {
  1667.                     if (cur_arg != ut->bufp->b_args)
  1668.                         strcat(outseq, ", ");
  1669.                     strcat(outseq, cur_arg->name);
  1670.                     cur_arg = cur_arg->next;
  1671.                 }
  1672.                 strcat(outseq, ")");
  1673.             }
  1674.         }
  1675.         strcat(outseq, " -----");
  1676.  
  1677.         /* and add it as a line into the buffer */
  1678.         if (addline(varbuf, outseq) != TRUE)
  1679.             return(FALSE);
  1680.  
  1681.         /* build this list */
  1682.         for (uindex = 0; uindex < ut->size; uindex++) {
  1683.             if (ut->uv[uindex].u_name[0] == 0)
  1684.                 break;
  1685.     
  1686.             /* add in the user variable name */
  1687.             strcpy(outseq, "%");
  1688.             strcat(outseq, ut->uv[uindex].u_name);
  1689.             pad(outseq, 14);
  1690.                 
  1691.             /* add in the value */
  1692.             strcat(outseq, ut->uv[uindex].u_value);
  1693.     
  1694.             /* and add it as a line into the buffer */
  1695.             if (addline(varbuf, outseq) != TRUE)
  1696.                 return(FALSE);
  1697.         }
  1698.         ut = ut->next;
  1699.     }
  1700.  
  1701.     /* display the list */
  1702.     wpopup(varbuf);
  1703.     mlerase();    /* clear the mode line */
  1704.     return(TRUE);
  1705. }
  1706.  
  1707. /*    describe-functions    Bring up a fake buffer and list the
  1708.                 names of all the functions
  1709. */
  1710.  
  1711. int PASCAL NEAR desfunc(f, n)
  1712.  
  1713. int f,n;    /* prefix flag and argument */
  1714.  
  1715. {
  1716.     register BUFFER *fncbuf;/* buffer to put function list into */
  1717.     register int uindex;    /* index into funcs table */
  1718.     char outseq[80];    /* output buffer for keystroke sequence */
  1719.  
  1720.     /* get a buffer for the function list */
  1721.     fncbuf = bfind(TEXT211, TRUE, BFINVS);
  1722. /*           "Function list" */
  1723.     if (fncbuf == NULL || bclear(fncbuf) == FALSE) {
  1724.         mlwrite(TEXT212);
  1725. /*            "Can not display function list" */
  1726.         return(FALSE);
  1727.     }
  1728.  
  1729.     /* let us know this is in progress */
  1730.     mlwrite(TEXT213);
  1731. /*        "[Building function list]" */
  1732.  
  1733.     /* build the function list */
  1734.     for (uindex = 0; uindex < NFUNCS; uindex++) {
  1735.  
  1736.         /* add in the environment variable name */
  1737.         strcpy(outseq, "&");
  1738.         strcat(outseq, funcs[uindex].f_name);
  1739.  
  1740.         /* and add it as a line into the buffer */
  1741.         if (addline(fncbuf, outseq) != TRUE)
  1742.             return(FALSE);
  1743.     }
  1744.  
  1745.     if (addline(fncbuf, "") != TRUE)
  1746.         return(FALSE);
  1747.  
  1748.     /* display the list */
  1749.     wpopup(fncbuf);
  1750.     mlerase();    /* clear the mode line */
  1751.     return(TRUE);
  1752. }
  1753.  
  1754. VOID PASCAL NEAR pad(s, len)    /* pad a string to indicated length */
  1755.  
  1756. char *s;    /* string to add spaces to */
  1757. int len;    /* wanted length of string */
  1758.  
  1759. {
  1760.     while (strlen(s) < len) {
  1761.                 strcat(s, "          ");
  1762.         s[len] = 0;
  1763.     }
  1764. }
  1765.