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
uv_init(ut)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
varinit()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
uv_clean(ut)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
varclean(ut)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
gtfun(fname)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
gtusr(vname)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
funval(i)286 char *PASCAL NEAR funval(i)
287
288 int i;
289
290 {
291 return(funcs[i].f_name);
292 }
293
envval(i)294 char *PASCAL NEAR envval(i)
295
296 int i;
297
298 {
299 return(envars[i]);
300 }
301
binary(key,tval,tlength,klength)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
gtenv(vname)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
fixnull(s)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
getkill()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
trimstr(s)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
setvar(f,n)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
global_var(f,n)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
local_var(f,n)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
findvar(var,vd,size,scope)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
svar(var,value)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
asc_int(st)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
int_asc(i)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
long_asc(num)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
gettyp(token)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
getval(token)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
stol(val)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
ltos(val)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
mkupper(str)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
mklower(str)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
absv(x)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
ernd()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
sindex(source,pattern)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
xlat(source,lookup,trans)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
setwlist(wclist)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 NULL;
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 NULL;
1496 }
1497
1498 /* getwlist: place in a buffer a list of characters
1499 considered "in a word" */
1500
getwlist(buf)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
is_num(st)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
dispvar(f,n)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
desvars(f,n)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
desfunc(f,n)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
pad(s,len)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