Annotation of freem/src/expr.c, revision 1.18
1.1 snw 1: /*
1.18 ! snw 2: * $Id: expr.c,v 1.17 2025/05/01 03:56:29 snw Exp $
1.1 snw 3: * expression parser
4: *
5: *
1.4 snw 6: * Author: Serena Willis <snw@coherent-logic.com>
1.1 snw 7: * Copyright (C) 1998 MUG Deutschland
1.5 snw 8: * Copyright (C) 2020, 2023, 2025 Coherent Logic Development LLC
1.1 snw 9: *
10: *
11: * This file is part of FreeM.
12: *
13: * FreeM is free software: you can redistribute it and/or modify
14: * it under the terms of the GNU Affero Public License as published by
15: * the Free Software Foundation, either version 3 of the License, or
16: * (at your option) any later version.
17: *
18: * FreeM is distributed in the hope that it will be useful,
19: * but WITHOUT ANY WARRANTY; without even the implied warranty of
20: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21: * GNU Affero Public License for more details.
22: *
23: * You should have received a copy of the GNU Affero Public License
24: * along with FreeM. If not, see <https://www.gnu.org/licenses/>.
25: *
1.6 snw 26: * $Log: expr.c,v $
1.18 ! snw 27: * Revision 1.17 2025/05/01 03:56:29 snw
! 28: * -m
! 29: *
1.17 snw 30: * Revision 1.16 2025/04/30 20:03:09 snw
31: * Work on entryref parser
32: *
1.16 snw 33: * Revision 1.15 2025/04/30 14:41:03 snw
34: * Further debugger work
35: *
1.15 snw 36: * Revision 1.14 2025/04/14 23:20:23 snw
37: * Restore support for any 8-bit character in
38: *
1.14 snw 39: * Revision 1.13 2025/04/13 04:22:43 snw
40: * Fix snprintf calls
41: *
1.13 snw 42: * Revision 1.12 2025/04/10 01:24:38 snw
43: * Remove C++ style comments
44: *
1.12 snw 45: * Revision 1.11 2025/03/30 01:36:58 snw
46: * Make it easier to bring back fma_gedit, fix double-free in global handler, limit $CHAR to 7-bit ASCII
47: *
1.11 snw 48: * Revision 1.10 2025/03/24 04:13:11 snw
49: * Replace action macro dat with fra_dat to avoid symbol conflict on OS/2
50: *
1.10 snw 51: * Revision 1.9 2025/03/24 01:32:22 snw
52: * Guard declaration of time function in expr.c for portability
53: *
1.9 snw 54: * Revision 1.8 2025/03/22 04:47:18 snw
55: * Silently truncate long names in STRING exprs when evaluates to an obsolete MDC standard
56: *
1.8 snw 57: * Revision 1.7 2025/03/22 03:39:23 snw
58: * Fix reverse query polyfill call-in from C side and make NAME exprs silently truncate long names in obsolete MDC dialects
59: *
1.7 snw 60: * Revision 1.6 2025/03/22 03:05:19 snw
61: * Comply with X11-96/13 portable length of names
62: *
1.6 snw 63: * Revision 1.5 2025/03/09 19:14:24 snw
64: * First phase of REUSE compliance and header reformat
65: *
1.5 snw 66: *
67: * SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
68: * SPDX-License-Identifier: AGPL-3.0-or-later
1.1 snw 69: **/
70:
71: #if !defined(__osf__)
72: #include <sys/types.h>
73: #endif
74: #if !defined(__OpenBSD__) && !defined(__FreeBSD__)
75: # include <sys/timeb.h>
76: #endif
77: #include <stdlib.h>
78: #include <string.h>
79: #include <ctype.h>
80:
81: /* mumps expression evaluator */
82:
83: #include "mpsdef.h"
84: #include "transact.h"
85: #include "merr.h"
86: #include "mtok.h"
87: #include "version.h"
88: #if defined(HAVE_STDINT_H)
89: # include <stdint.h>
90: #endif
91: #if !defined(__osf__) && !defined(_AIX)
92: # define _XOPEN_SOURCE
93: #endif
94:
95: #if defined(USE_SYS_TIME_H) && !defined(MSDOS) && !defined(__osf__)
96: # include <sys/time.h>
97: #else
98: # include <time.h>
99: #endif
100:
101: #if defined(MSDOS) || defined(__linux__)
102: # include <time.h>
103: char *strptime(const char *restrict s, const char *restrict format, struct tm *restrict tm);
104: #endif
105:
106: #include "mref.h"
107: #include "journal.h"
108: #include "datatypes.h"
109: #include "objects.h"
110:
111: #define OPERAND 1
112: #define ARRAY 2
113: #define FNUMBER 3
114: #define REVERSE 4
115: #define TRANSLATE 5
116: #define QLENGTH 6
117: #define QSUBSCRIPT 7
118: #define TYPE 31
119: #define INSTANCEOF 32
120:
121: #define ZCRC 8
122: #define ZDATA 9
123: #define ZLSD 11
124: #define ZNEXT 12
125: #define ZPREVIOUS 17
126: #define ZTRAP 18
127:
128: #define SVNsystem 19
129: #define SVNtimezone 20
130: #define SVNtlevel 22
131: #define SVNtrollback 23
132: #define SVNecode 24
133: #define SVNestack 25
134: #define SVNetrap 26
135: #define SVNstack 27
136: #define SVNpdisplay 28
137: #define SVNdialect 29
138: #define SVNzut 30
139:
140: #define OR '!'
141: #define MODULO '#'
142: #define DIVIDE '/'
143: #define AND '&'
144: #define NOT '\''
145: #define XOR '~'
146: #define MULTIPLY '*'
147: #define POWER ' '
148: #define PLUS '+'
149: #define MINUS '-'
150: #define LESS '<'
151: #define EQUAL '='
152: #define GREATER '>'
153: #define PATTERN '?'
154: #define INDIRECT '@'
155: #define CONTAINS '['
156: #define INTDIVIDE '\\'
157: #define FOLLOWS ']'
158: #define CONCATENATE '_'
159: #define SORTSAFTER '.'
160: #define EQFOLLOWS ','
161: #define EQSORTS ';'
162: #define MAXOP ':'
163: #define MINOP '%'
164:
165: #define GET 'Y'
166: #define GETX ':'
167:
1.18 ! snw 168: #if !defined(__OpenBSD__) && !defined(_AIX) && !defined(__osf__) && !defined(MSDOS) && !defined(__vax__) && !defined(__OS2__) && !defined(__linux__)
1.1 snw 169: long time ();
170: #endif
1.2 snw 171: void cond_round (char *a, int digits);
172: void zkey (char *a, long type);
173: int levenshtein (char *word1, char *word2);
1.1 snw 174: time_t horolog_to_unix (char *horo);
175: extern int xecline(int typ);
176: short rbuf_slot_from_name(char *);
177:
178:
179: short obj_field = FALSE;
180: char object_instance[50];
181: char object_class[50];
182:
183:
184: /*
185: * expr(): expression parser
186: * extyp: type of expression; one of:
187: * STRING
188: * NAME
189: * LABEL
190: * OFFSET
191: * ARGIND
192: */
193: void expr (short extyp)
194: {
195: char op_stck[PARDEPTH + 1]; /* operator/operandflag stack */
196: short spx; /* stack pointer: */
197: short zexflag; /* z 'intrinsic' function flag */
198: int atyp, btyp; /* DM/EUR currency types */
199: char *a; /* pointer to current (left) argument */
200: char *b; /* pointer to right hand argument */
201: char tmp[256];
202: int refsx; /* zref/zloc stack_counter */
203: char *refsav[PARDEPTH]; /* zref/zloc stack */
204:
205:
206: register int i = 0;
207: register int j = 0;
208: register int f = 0;
209: volatile int ch = 0;
210:
211: short group; /* flag to scan grouped patterns */
1.6 snw 212:
213: int max_namlen = 255;
214:
215: if ((rtn_dialect () == D_MDS) || (rtn_dialect () == D_M5) || (rtn_dialect () == D_FREEM)) {
216: max_namlen = 255;
217: }
218: else {
219: max_namlen = 8;
220: }
1.1 snw 221:
222: #ifdef DEBUG_NEWPTR
223: int loop;
224: #endif
225:
226: refsx = 0;
227:
228: if (extyp == NAME) {
229:
230: f = *codptr;
231: varnam[0] = f;
232:
233: if ((f >= 'A' && f <= 'Z') || (f >= 'a' && f <= 'z') || f == '^' || f == '$' || f == '%') {
234:
235: i = 1;
236:
237: while (((ch = *++codptr) >= 'A' && ch <= 'Z') ||
238: (ch >= 'a' && ch <= 'z') ||
239: (ch >= '0' && ch <= '9' && (i > 1 || f != '^')) ||
240: f == '^' &&
241: (((ch == '%' || ch == '$') && i == 1) ||
242: (ch == '|') ||
243: (standard == 0 &&
244: (ch == '.' ||
245: (ch == '/' && i == 1) ||
246: (((ch == '/' && varnam[i - 1] != '/') ||
247: (ch == '%' && varnam[i - 1] == '/')) &&
248: (varnam[1] == '.' || varnam[1] == '/'))))) || (f != '^') && (ch == '.')) {
249:
1.6 snw 250: if ((i + 1) <= max_namlen) {
251: varnam[i++] = ch;
252: }
253: else {
1.7 snw 254: if ((rtn_dialect () == D_M77) ||
255: (rtn_dialect () == D_M84) ||
256: (rtn_dialect () == D_M90) ||
257: (rtn_dialect () == D_M95)) {
258: /* silently truncate... yeah, the standard is stupid af */
259: continue;
260: }
261: else {
262: merr_raise (M56);
263: return;
264: }
1.6 snw 265: }
1.1 snw 266:
267: }
268:
1.7 snw 269: varnam[i] = EOL;
270:
271: #if 0
272: {
273: char gooby[256];
274: stcpy (gooby, varnam);
275: stcnv_m2c (gooby);
276: printf ("name = '%s'\r\n", gooby);
277: }
278: #endif
1.1 snw 279:
280: if (ch == '(') { /* it's an array */
281:
282: op_stck[0] = 0;
283: op_stck[1] = ARRAY;
284: spx = 1;
285: a = argptr;
286:
287: if ((argstck[1] = a) >= s) {
288:
289: char *bak;
290:
291: bak = partition;
292:
293: if (getpmore () == 0) {
294: merr_raise (STKOV);
295: return;
296: }
297:
298: a = a - bak + partition;
299: b = b - bak + partition;
300:
301: }
302:
303: a += stcpy (a, varnam) + 1;
304:
305: arg = 1;
306: codptr++;
307:
308: goto nextchr;
309: }
310:
311: codptr--;
312:
313: if (i == 1 && f == '^') {
314: merr_raise (INVEXPR);
315: }
316:
317: return;
318:
319: }
320:
321: if (f != '@') {
322: merr_raise (INVREF);
323: return;
324: }
325:
326: } /* end if (extyp ==NAME) */
327:
328: arg = 0;
329: spx = 0; /* initialisation */
330: op_stck[0] = 0;
331: a = argptr;
332:
333: nextchr:
334: ch = *codptr;
335:
336: if ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '%') {
337:
338:
339: scan_name:
340:
341: varnam[0] = ch;
342: i = 1;
343:
344: if (ch == '^') { /* global variable name */
345:
346: int vb_ct;
347: int qt_ct;
348: char lastch;
349: char nextch;
350:
351: vb_ct = 0;
352: qt_ct = 0;
353:
354: lastch = ' ';
355:
356: while (((ch = *++codptr) >= 'A' && ch <= 'Z') ||
357: (ch >= 'a' && ch <= 'z') ||
358: (ch >= '0' && ch <= '9' && i > 1) ||
359: (ch == '|') || (ch == '%') || (ch == '\"') ||
360: (((ch == '%' || ch == '$') && i == 1) ||
361: (standard == 0 &&
362: (ch == '.' ||
363: (ch == '/' && i == 1) ||
364: (((ch == '/' && varnam[i - 1] != '/') ||
365: (ch == '%' && varnam[i - 1] == '/')) &&
366: (varnam[1] == '.' || varnam[1] == '/')))))) {
367:
368: nextch = *(codptr + 1);
369:
370: if (ch == '|') vb_ct++;
371:
372: if (ch == '\"') {
373: qt_ct++;
374:
375: if ((lastch != '|') && (nextch != '|')) {
376: merr_raise (INVEXPR);
377: return;
378: }
379:
380: }
381:
382: if ((ch == '|') && ((nextch != '\"') && (lastch != '\"'))) {
383:
384: if ((qt_ct == 1) && (vb_ct == 2)) {
385: merr_raise (QUOTER);
386: return;
387: }
388: else if ((vb_ct == 2) && (qt_ct == 1)){
389: merr_raise (INVEXPR);
390: return;
391: }
392:
393: }
394:
395: if (vb_ct > 2) {
396: merr_raise (INVEXPR);
397: return;
398: }
1.8 snw 399:
400: if ((i + 1) <= max_namlen) {
401: varnam[i++] = ch;
402: }
403: else {
404: if ((rtn_dialect () == D_M77) ||
405: (rtn_dialect () == D_M84) ||
406: (rtn_dialect () == D_M90) ||
407: (rtn_dialect () == D_M95)) {
408: /* silently truncate... yeah, the standard is stupid af */
409: continue;
410: }
411: else {
412: merr_raise (M56);
413: return;
414: }
415: }
1.1 snw 416:
417: lastch = ch;
418: }
419:
420: varnam[i] = EOL;
421:
422: if (i == 1 && ch != '(') {
423: merr_raise (INVEXPR);
424: return;
425: }
426:
427: }
428: else { /* local variable name */
429:
430: while (isalnum (ch = *++codptr)) {
1.8 snw 431:
432: if ((i + 1) <= max_namlen) {
433: varnam[i++] = ch;
434: }
435: else {
436: if ((rtn_dialect () == D_M77) ||
437: (rtn_dialect () == D_M84) ||
438: (rtn_dialect () == D_M90) ||
439: (rtn_dialect () == D_M95)) {
440: /* silently truncate... yeah, the standard is stupid af */
441: continue;
442: }
443: else {
444: merr_raise (M56);
445: return;
446: }
447: }
448:
1.1 snw 449: }
450:
451: varnam[i] = EOL;
452:
453:
454: if (*codptr == '.') {
455: if (*(codptr + 1) == '$') {
456: codptr++;
457:
458: obj_field = TRUE;
459: stcpy (object_instance, varnam);
460: stcnv_m2c (object_instance);
461: obj_get_attribute (object_instance, "CLASS", object_class);
462:
463: stcnv_m2c (object_instance);
464: stcnv_c2m (object_class);
465:
466: expr (STRING);
467: return;
468: }
469: else {
470: merr_raise (INVEXPR);
471: return;
472: }
473: }
474:
475: }
476:
477: if (ch == '(') { /* it's an array */
478:
479: if (extyp == LABEL) {
480: codptr--;
481: return;
482: }
483:
484: if (++spx >= PARDEPTH) {
485: merr_raise (STKOV);
486: return;
487: }
488:
489: op_stck[spx] = ARRAY;
490:
491: if ((argstck[++arg] = a) >= s) {
492:
493: char *bak;
494: bak = partition;
495:
496: if (getpmore () == 0) {
497: merr_raise (STKOV);
498: return;
499: }
500:
501: a = a - bak + partition;
502: b = b - bak + partition;
503:
504: }
505:
506: a += stcpy (a, varnam) + 1;
507: codptr++;
508:
509: goto nextchr;
510:
511: }
512:
513: if (spx == 0) {
514:
515: if (extyp != STRING && extyp != ARGIND && extyp != OFFSET) {
516: codptr--;
517: return;
518: }
519:
520: if (varnam[0] != '^') {
521: symtab (get_sym, varnam, a);
522: }
523: else if (varnam[1] != '$') {
524: global (get_sym, varnam, a);
525: }
526: else {
527: ssvn (get_sym, varnam, a);
528: }
529:
530: if (merr () != OK) {
531:
532: stcpy (varerr, varnam);
533:
534: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
535: arg = 1;
536: codptr--;
537:
538: goto undefglvn;
539: }
540:
541: }
542:
543: if (ch == EOL || ch == SP || (extyp == ARGIND) || ch == ',' || ch == ':' || ch == ')' || ch == '@' || (merr () > OK)) {
544: return;
545: }
546:
547: arg = 1;
548: argstck[1] = a;
549: f = OPERAND;
550: op_stck[1] = f;
551: spx = 2;
552:
553: goto op10; /* shortcut: following char is garbage or operator */
554:
555: }
556:
557: codptr--;
558:
559: if ((argstck[++arg] = a) >= s) {
560:
561: char *bak;
562: bak = partition;
563:
564: if (getpmore () == 0) {
565: merr_raise (STKOV);
566: return;
567: }
568:
569: a = a - bak + partition;
570: b = b - bak + partition;
571:
572: }
573:
574: /* evaluate glvn or $_(glvn) */
575:
576: var1:
577:
578: if (op_stck[spx] == '$') {
579:
580: f = op_stck[spx - 1];
581:
582:
583: switch (f) {
584:
585:
586: case 'd': /* $DATA */
587:
1.10 snw 588: ch = fra_dat;
1.1 snw 589:
590: glv_fcn:
591:
592: if (varnam[0] != '^') {
593: symtab (ch, varnam, a);
594: }
595: else if (varnam[1] != '$'){
596: global (ch, varnam, a);
597: }
598: else {
599: ssvn (ch, varnam, a);
600: }
601:
602: d_o_n:
603:
604: if (*++codptr != ')') merr_raise (INVEXPR);
605:
606: if (merr () > OK) {
607: stcpy (varerr, varnam);
608: return;
609: }
610:
611: spx -= 2;
612:
613: goto nxt_operator;
614:
615:
616: case 'o': /* $ORDER */
617:
618: if (rtn_dialect () == D_M77) {
619: merr_raise (NOSTAND);
620: return;
621: }
622:
623: ch = fra_order;
624: ordercnt = 1L;
625:
626: if (*(codptr + 1) != ',') {
627: ordercounter = 0;
628: goto glv_fcn;
629: }
630:
631: if (++spx > PARDEPTH) {
632: merr_raise (STKOV);
633: return;
634: }
635:
636: stcpy (a, varnam);
637:
638: op_stck[spx] = OPERAND;
639: codptr++;
640:
641: goto nextchr;
642:
643:
644: case 'n': /* $NEXT */
645:
646: ordercnt = 1L;
647: ordercounter = 0;
648:
649: if (varnam[0] != '^') {
650: symtab (fra_order, varnam, a);
651: }
652: else if (varnam[1] != '$') {
653: global (fra_order, varnam, a);
654: }
655: else {
656: ssvn (fra_order, varnam, a);
657: }
658:
659: if (a[0] == EOL) {
660: a[0] = '-';
661: a[1] = '1';
662: a[2] = EOL;
663: }
664:
665: goto d_o_n;
666:
667:
668: case 'q': /* $QUERY */
669: case 'O': /* $ZORDER */
670:
671: ch = fra_query;
672: ordercnt = 1L;
673:
674: if (*(codptr + 1) != ',') goto glv_fcn;
675:
676: if (++spx > PARDEPTH) {
677: merr_raise (STKOV);
678: return;
679: }
680:
681: stcpy (a, varnam);
682:
683: op_stck[spx] = OPERAND;
684: codptr++;
685:
686: goto nextchr;
687:
688:
689: case ZNEXT: /* $ZNEXT */
690:
691: ordercnt = 1L;
692:
693: if (varnam[0] != '^') {
694: symtab (fra_query, varnam, a);
695: }
696: else if (varnam[1] != '$') {
697: global (fra_query, varnam, a);
698: }
699: else {
700: ssvn (fra_query, varnam, a);
701: }
702:
703: if (a[0] == EOL) {
704: a[0] = '-';
705: a[1] = '1';
706: a[2] = EOL;
707: }
708:
709: goto d_o_n;
710:
711:
712: case 'N': /* $NAME */
713:
714: /* resolve naked reference */
715: if (varnam[0] == '^' && varnam[1] == DELIM) {
716:
717: stcpy (a, zref);
718: ch = stlen (a);
719:
720: while (a[ch--] != DELIM) {
721:
722: if (ch <= 0) {
723: merr_raise (NAKED);
724: return;
725: }
726:
727: }
728:
729: stcpy (&a[++ch], &varnam[1]);
730: stcpy (varnam, a);
731:
732: }
733:
734: if (*(codptr + 1) != ',') {
735: zname (a, varnam);
736: goto d_o_n;
737: }
738:
739: if (++spx > PARDEPTH) {
740: merr_raise (STKOV);
741: return;
742: }
743:
744: stcpy (a, varnam);
745:
746: op_stck[spx] = OPERAND;
747: codptr++;
748:
749: goto nextchr;
750:
751:
752: case ZPREVIOUS: /* $ZPREVIOUS */
753:
754: ordercnt = (-1L);
755: ordercounter = 0;
756: ch = fra_order;
757:
758: goto glv_fcn;
759:
760:
761: case ZDATA: /* $ZDATA */
762:
763: ch = zdata;
764: goto glv_fcn;
765:
766:
767: case 'g': /* $GET */
768:
769: if (varnam[0] != '^') {
770: symtab (get_sym, varnam, a);
771: }
772: else if (varnam[1] != '$') {
773: global (get_sym, varnam, a);
774: }
775: else {
776: ssvn (get_sym, varnam, a);
777: }
778:
779: if (merr () == M7 || merr () == M6) merr_raise (UNDEF);
780:
781: if (merr () > OK) {
782:
783: stcpy (varerr, varnam);
784:
785: if (merr () != UNDEF) return;
786: }
787:
788: if (merr () == UNDEF) {
789:
1.12 snw 790: /* smw 15 nov 2023 merr_raise (ierr < 0 ? OK - CTRLB : OK); */
1.1 snw 791: merr_clear ();
792:
793: if (*++codptr == ',') {
794:
795: if (standard) {
796: merr_raise (NOSTAND);
797: return;
798: }
799:
800: op_stck[spx - 1] = GET; /* dummy function for $GET */
801: arg--;
802: codptr++;
803:
804: goto nextchr;
805:
806: }
807: else {
808:
809: if (*codptr != ')') {
810: merr_raise (INVEXPR);
811: return;
812: }
813:
814: *a = EOL;
815:
816: }
817:
818: }
819: else { /* glvn was defined */
820:
821: if (*++codptr == ',') { /* skip second argument */
822:
823: i = 0; /* quote flag */
824: f = 0; /* bracket counter */
825:
826: for (;;) {
827:
828: ch = *++codptr;
829:
830: if (ch == EOL) {
831: merr_raise (INVEXPR);
832: return;
833: }
834:
835: if (ch == '"') {
836: i = !i;
837: continue;
838: }
839:
840: if (i) continue;
841:
842: if (ch == '(') {
843: f++;
844: continue;
845: }
846:
847: if (ch == ')') {
848: if (--f < 0) break;
849: }
850:
851: }
852:
853: }
854: else if (*codptr != ')') {
855: merr_raise (INVEXPR);
856: return;
857: }
858:
859: }
860:
861: spx -= 2;
862: goto nxt_operator;
863:
864: case 'i': /* $INCREMENT */
865:
866: if (varnam[0] != '^') {
867: symtab (getinc, varnam, a);
868: }
869: else {
870:
871: int setopsav;
872:
873: setopsav = setop;
874: setop = '+';
875: a[0] = '1';
876: a[1] = EOL;
877:
878: if (varnam[1] != '$') {
879: global (set_sym, varnam, a);
880: }
881: else {
882: ssvn (set_sym, varnam, a);
883: }
884:
885: setop = setopsav;
886:
887: }
888:
889: goto d_o_n;
890:
891:
892: case OPERAND: /* three arguments $TEXT */
893:
894: if (spx >= 6 && op_stck[spx - 5] == 't' && op_stck[spx - 4] == '$' && op_stck[spx - 2] == '$') {
895:
896: stcpy (a, &varnam[varnam[0]=='^']); /* third argument */
897:
898: if (++spx > PARDEPTH) {
899: merr_raise (STKOV);
900: return;
901: }
902:
903: op_stck[spx] = OPERAND;
904: codptr++;
905:
906: goto nextchr;
907:
908: }
909:
910: } /* end switch */
911: }
912:
913: /* retrieve look-up */
914:
915: if (varnam[0] != '^') {
916: symtab (get_sym, varnam, a);
917: }
918: else if (varnam[1] != '$') {
919: global (get_sym, varnam, a);
920: }
921: else {
922: ssvn (get_sym, varnam, a);
923: }
924:
925:
926: undefglvn:
927:
928:
929: if (merr ()) stcpy (varerr, varnam);
930:
931: if ((merr () == M6) || (merr () == M7) || (merr () == UNDEF)) {
932:
933: stcpy (tmp, codptr + 1);
934:
935: if (varnam[0] == '^') { /* is there a default expression?? */
936:
937: if (gvndefault[0] == EOL) return;
938:
939: stcpy (&code[1], gvndefault);
940:
941: }
942: else {
943:
944: if (lvndefault[0] == EOL) return;
945:
946: stcpy (&code[1], lvndefault);
947:
948: }
949:
950: /* simulate a $GET function */
951: code[0] = SP;
952:
953: stcat (code, ")\201");
954: stcat (code, tmp);
955:
956: codptr = &code[1];
957:
958: if (((++spx) + 1) > PARDEPTH) {
959: merr_raise (STKOV);
960: return;
961: }
962:
963: op_stck[spx] = GETX; /* dummy function for $GET */
964: op_stck[++spx] = '$';
965:
966: /* stack $ZREFERENCE and $ZLOCAL */
967: if ((refsav[refsx] = calloc (1, 2 * 256)) == NULL) {
968: merr_raise (STKOV);
969: return;
970: } /* could not allocate stuff... */
971:
972: stcpy (refsav[refsx], zref);
973: stcpy (refsav[refsx++] + 256, zloc);
974:
1.12 snw 975: ierr -= M7;
1.1 snw 976: arg--;
977:
978: goto nextchr;
979:
980: }
981:
982: if (merr () > OK) return;
983:
984: if (spx == 0) {
985:
986: if ((ch = *++codptr) == EOL || ch == SP || ch == ',' || ch == ':') return;
987:
988: if (++spx > PARDEPTH) {
989: merr_raise (STKOV);
990: return;
991: }
992:
993: op_stck[spx] = OPERAND;
994:
995: goto next10;
996:
997: }
998:
999: f = op_stck[spx];
1000:
1001: if (f == ARRAY || f == '(') {
1002:
1003: if (++spx > PARDEPTH) {
1004: merr_raise (STKOV);
1005: return;
1006: }
1007:
1008: op_stck[spx] = OPERAND;
1009: codptr++;
1010:
1011: goto nextchr;
1012:
1013: }
1014:
1015: if (f == INDIRECT && (extyp == STRING || extyp == ARGIND || extyp == OFFSET)) {
1016: spx--;
1017: goto indirect; /* VARIABLE indirection */
1018: }
1019:
1020: goto nxt_expr;
1021:
1022: }
1023:
1024: if (ch >= '0' && ch <= '9') {
1025:
1026: if (extyp == LABEL) goto scan_name; /* scan_label */
1027:
1028: /* scan number */
1029: i = 0; /* point flag */
1030: j = 0; /* exp flag */
1031: f = ch; /* first character */
1032:
1033: if ((argstck[++arg] = a) >= s) {
1034:
1035: char *bak;
1036: bak = partition;
1037:
1038: if (getpmore () == 0) {
1039: merr_raise (STKOV);
1040: return;
1041: }
1042:
1043: a = a - bak + partition;
1044:
1045: }
1046:
1047: b = a;
1048:
1049: p_entry: /* entry point if first character was a point */
1050:
1051: for (;;) {
1052:
1053: if (ch < '0') {
1054:
1055: if (ch != '.' || i || j) break;
1056:
1057: i++;
1058:
1059: }
1060: else if (ch > '9') {
1061:
1062: if (j) break;
1063: if (ch != 'E' && (lowerflag == FALSE || ch != 'e')) break;
1064:
1065: if (ch == 'E') {
1066: if ((*(codptr + 1) == 'U') && (*(codptr + 2) == 'R')) break;
1067: if ((*(codptr + 1) == 'S') && (*(codptr + 2) == 'P')) break;
1068: }
1069:
1070: j++;
1071:
1072: do {
1073:
1074: *b++ = ch;
1075: ch = *++codptr;
1076:
1077: } while (ch == '+' || ch == '-');
1078:
1079: }
1080:
1081: *b++ = ch;
1082: ch = *++codptr;
1083:
1084: }
1085:
1086: #ifdef EUR2DEM
1087:
1088: switch (ch) {
1089:
1090: case 'E':
1091:
1092: if ((*(codptr + 1) == 'U') && (*(codptr + 2) == 'R')) {
1093: *b++ = ch;
1094: *b++ = *++codptr;
1095: *b++ = *++codptr;
1096: ch = *++codptr;
1097: j = 1;
1098:
1099: break;
1100: }
1101:
1102: if ((*(codptr + 1) == 'S') && (*(codptr + 2) == 'P')) {
1103: *b++ = ch;
1104: *b++ = *++codptr;
1105: *b++ = *++codptr;
1106: ch = *++codptr;
1107: j = 1;
1108: }
1109:
1110: break;
1111:
1112:
1113: case 'D':
1114:
1115: if (*(codptr + 1) == 'M') {
1116: *b++ = ch;
1117: *b++ = *++codptr;
1118: ch = *++codptr;
1119: j = 1;
1120:
1121: break;
1122: }
1123:
1124: if (*(codptr + 1) == 'E' && *(codptr + 2) == 'M') {
1125: *b++ = ch;
1126: *b++ = *++codptr;
1127: *b++ = *++codptr;
1128: ch = *++codptr;
1129: j = 1;
1130: }
1131:
1132: break;
1133:
1134:
1135: case 'A':
1136:
1137: if (*(codptr + 1) == 'T' && *(codptr + 2) == 'S') {
1138: *b++ = ch;
1139: *b++ = *++codptr;
1140: *b++ = *++codptr;
1141: ch = *++codptr;
1142: j = 1;
1143: }
1144:
1145: break;
1146:
1147:
1148: case 'B':
1149:
1150: if (*(codptr + 1) == 'F' && *(codptr + 2) == 'R') {
1151: *b++ = ch;
1152: *b++ = *++codptr;
1153: *b++ = *++codptr;
1154: ch = *++codptr;
1155: j = 1;
1156: }
1157:
1158: break;
1159:
1160:
1161: case 'F':
1162:
1163: if (*(codptr + 1) == 'F') {
1164: *b++ = ch;
1165: *b++ = *++codptr;
1166: ch = *++codptr;
1167: j = 1;
1168:
1169: break;
1170: }
1171:
1172: if (*(codptr + 1) == 'M' && *(codptr + 2) == 'K') {
1173: *b++ = ch;
1174: *b++ = *++codptr;
1175: *b++ = *++codptr;
1176: ch = *++codptr;
1177: j = 1;
1178:
1179: break;
1180: }
1181:
1182: if (*(codptr + 1) == 'R' && *(codptr + 2) == 'F') {
1183: *b++ = ch;
1184: *b++ = *++codptr;
1185: *b++ = *++codptr;
1186: ch = *++codptr;
1187: j = 1;
1188: }
1189:
1190: break;
1191:
1192:
1193: case 'I':
1194:
1195: if (*(codptr + 1) == 'E' && *(codptr + 2) == 'P') {
1196: *b++ = ch;
1197: *b++ = *++codptr;
1198: *b++ = *++codptr;
1199: ch = *++codptr;
1200: j = 1;
1201:
1202: break;
1203: }
1204:
1205: if (*(codptr + 1) == 'T' && *(codptr + 2) == 'L') {
1206: *b++ = ch;
1207: *b++ = *++codptr;
1208: *b++ = *++codptr;
1209: ch = *++codptr;
1210: j = 1;
1211: }
1212:
1213: break;
1214:
1215:
1216: case 'N':
1217:
1218: if (*(codptr + 1) == 'L' && *(codptr + 2) == 'G') {
1219: *b++ = ch;
1220: *b++ = *++codptr;
1221: *b++ = *++codptr;
1222: ch = *++codptr;
1223: j = 1;
1224: }
1225:
1226: break;
1227:
1228:
1229: case 'P':
1230:
1231: if (*(codptr + 1) == 'T' && *(codptr + 2) == 'E') {
1232: *b++ = ch;
1233: *b++ = *++codptr;
1234: *b++ = *++codptr;
1235: ch = *++codptr;
1236: j = 1;
1237: }
1238:
1239:
1240: }
1241:
1242: #endif /* EUR2DEM */
1243:
1244: *b = EOL;
1245:
1246: if (j || f == '0' || (i && ((*(b - 1)) < '1'))) { /* <'1' eqiv. to '.' || '0' */
1247: atyp = numlit (a);
1248: if (atyp) stcat (a, WHR[atyp]);
1249: }
1250:
1251:
1252: if (spx) {
1253: codptr--;
1254: goto exec;
1255: }
1256:
1257: if (ch == EOL || ch == SP || ch == ',' || ch == ':' || (ch == '^' && extyp == OFFSET)) return;
1258:
1259: spx = 1;
1260: op_stck[1] = OPERAND;
1261:
1262: }
1263:
1264: if (ch != '"') goto next10;
1265:
1266: /* scan string */
1267: if ((argstck[++arg] = a) >= s) {
1268:
1269: char *bak;
1270:
1271: bak = partition;
1272:
1273: if (getpmore () == 0) {
1274: merr_raise (STKOV);
1275: return;
1276: }
1277:
1278: a = a - bak + partition;
1279: b = b - bak + partition;
1280:
1281: }
1282:
1283: i = 0;
1284:
1285: for (;;) {
1286:
1287: while ((ch = *++codptr) > '"') {
1288: a[i++] = ch;
1289: }
1290:
1291: /* we make use of the fact that */
1292: /* EOL < "any ASCII character" */
1293: if (ch == '"' && (ch = *++codptr) != '"') {
1294:
1295: if (ch == '_' && *(codptr + 1) == '"') {
1296: codptr++;
1297: continue;
1298: }
1299:
1300: a[i] = EOL;
1301:
1302: if (spx) {
1303: codptr--;
1304: goto exec;
1305: }
1306:
1307: if (ch == EOL || ch == SP || ch == ',' || ch == ':') return;
1308:
1309: spx = 1;
1310: op_stck[1] = OPERAND;
1311:
1312: goto next10;
1313:
1314: }
1315:
1316: if (ch == EOL) {
1317: merr_raise (QUOTER);
1318: return;
1319: }
1320:
1321: a[i++] = ch;
1322:
1323: }
1324:
1325: next05:
1326:
1327: ch = *(++codptr);
1328:
1329: next10:
1330:
1331: switch (ch) {
1332:
1333:
1334: case EOL:
1335: case SP:
1336:
1337: if (op_stck[1] == OPERAND && spx == 1) return;
1338:
1339: merr_raise (INVEXPR);
1340: return;
1341:
1342:
1343: case ',':
1344:
1345: if (spx == 0) {
1346: merr_raise (ARGER);
1347: return;
1348: }
1349:
1350:
1351: comma:
1352:
1353: f = op_stck[spx - 1];
1354:
1355: /* f= (spx>0 ? op_stck[spx-1] : 0);
1356: * if (f) */
1357: switch (f) {
1358:
1359: case '$': /* first arg of $function */
1360:
1361: if (op_stck[spx - 2] == 's') { /* we already have one valid arg */
1362:
1363: i = 0; /* quote *//* and skip rest of select */
1364: j = 0; /* bracket */
1365:
1366: for (;;) {
1367:
1368: ch = *++codptr;
1369:
1370: if (ch == '"') {
1371: toggle (i);
1372: continue;
1373: }
1374:
1375: if (i) {
1376: if (ch != EOL) continue;
1377:
1378: merr_raise (QUOTER);
1379: return;
1380: }
1381:
1382: if (ch == ')') {
1383:
1384: if (j--) continue;
1385:
1386: spx -= 3;
1387:
1388: goto nxt_operator;
1389: }
1390:
1391: if (ch == '(') {
1392: j++;
1393: continue;
1394: }
1395:
1396: if (ch == EOL) {
1397: merr_raise (SELER);
1398: return;
1399: }
1400: }
1401:
1402: }
1403:
1404: /* function argument */
1405: /* put comma on the stack */
1406: if (++spx > PARDEPTH) {
1407: merr_raise (STKOV);
1408: return;
1409: }
1410:
1411: op_stck[spx] = f; /* '$' */
1412:
1413: /* a+=stlen(a)+1; */
1414:
1415: while (*a++ != EOL);
1416:
1417: codptr++;
1418:
1419: goto nextchr;
1420:
1421:
1422: case ARRAY: /* array subscript */
1423:
1424: *(a - 1) = DELIM;
1425: arg--;
1426: spx--;
1427:
1428: while (*a++ != EOL) ;
1429:
1430: codptr++;
1431:
1432: goto nextchr;
1433:
1434:
1435: default:
1436:
1437: if ((extyp == NAME) || (spx > 1)) {
1438: merr_raise (INVEXPR);
1439: return;
1440: }
1441:
1442: return;
1443:
1444: }
1445:
1446: case '^':
1447:
1448: if (extyp == LABEL || extyp == OFFSET) break;
1449:
1450: uparrow:
1451:
1452: if (spx >= 5) { /* take care of $TEXT with three args */
1453:
1454: if (op_stck[spx - 4] == 't' && op_stck[spx - 3] == '$' && op_stck[spx - 1] == '$') {
1455:
1456: if (++spx > PARDEPTH) {
1457: merr_raise (STKOV);
1458: return;
1459: }
1460:
1461: op_stck[spx] = '$';
1462:
1463: while (*a++ != EOL);
1464:
1465: if (*(codptr+1)=='@') goto next05;
1466:
1467: }
1468:
1469: }
1470:
1471: goto scan_name;
1472:
1473:
1474: case '.':
1475:
1476: if ((ch = *++codptr) < '0' || ch > '9') {
1477: merr_raise (INVEXPR);
1478: return;
1479: }
1480:
1481: if ((argstck[++arg] = a) >= s) {
1482:
1483: char *bak;
1484: bak = partition;
1485:
1486: if (getpmore () == 0) {
1487: merr_raise (STKOV);
1488: return;
1489: }
1490:
1491: a = a - bak + partition;
1492: b = b - bak + partition;
1493:
1494: }
1495:
1496: i = 1; /* point flag */
1497: j = 0; /* exp flag */
1498: f = '.'; /* first character */
1499: b = a;
1500: *b++ = f;
1501:
1502: goto p_entry;
1503:
1504:
1505: case ')':
1506:
1507: if (spx <= 1) {
1508:
1509: if (setpiece) return;
1510:
1511: if (spx == 0) {
1512: merr_raise (BRAER);
1513: return;
1514: }
1515:
1516: }
1517:
1518: if (op_stck[spx] != OPERAND) {
1519: merr_raise (INVEXPR);
1520: return;
1521: }
1522:
1523: if ((f = op_stck[spx - 1]) == ARRAY) { /* array return */
1524:
1525: *--a = DELIM;
1526: stcpy (varnam, a = argstck[--arg]);
1527:
1528: if ((spx -= 2) <= 0 && extyp != STRING && extyp != ARGIND) return;
1529:
1530: goto var1;
1531:
1532: }
1533:
1534: /* precedence close parenthesis */
1535: if (f == '(') {
1536: spx -= 2;
1537: goto nxt_operator;
1538: }
1539:
1540: if (spx <= 2) {
1541: merr_raise (BRAER);
1542: return;
1543: } /* unmatched ')' */
1544:
1545:
1546: /**
1547: * *********** function evaluation ******************************************
1548: *
1549: * Note: Input for function() is found in 'partition':
1550: * There are 'f' arguments to be found at 'a'
1551: * The arguments are separated by an EOL character.
1552: * There is a list of the addresses of the arguments
1553: * in 'a==argstck[arg], argstck[arg+1], argstck[arg+f-1]'
1554: * Result is returned at a==argstck[arg]
1555: *
1556: */
1557: f = 1; /* f == number of arguments */
1558: if (op_stck[spx -= 2] == OPERAND) {
1559:
1560: do {
1561: f++;
1562: arg--;
1563: } while (op_stck[spx -= 2] == OPERAND);
1564:
1565: a = argstck[arg];
1566:
1567: }
1568:
1569: i = op_stck[spx--];
1570:
1571: switch (i) { /* function select */
1572:
1573:
1574: case 'e': /* $EXTRACT */
1575:
1576: switch (f) {
1577:
1578:
1579: case 1:
1580:
1581: a[1] = EOL;
1582: goto nxt_operator;
1583:
1584:
1585: case 2:
1586:
1587: b = argstck[arg + 1];
1588: i = intexpr (b) - 1; /* numeric value of 2nd argument */
1589:
1590: /*set_io (UNIX);
1591: printf ("i = %d a = '%s'\n", i, a[i]);
1592: set_io (MUMPS);*/
1593:
1594: if (merr () == MXNUM) {
1595: merr_raise (OK);
1596: if (i >= 0) i = 256;
1597: }
1598:
1599: f = b - a - 1; /* length of first argument */
1600:
1601: if (i > f || i < 0) {
1602: if (i > f) {
1603: a[0] = EOL;
1604: goto nxt_operator;
1605: }
1606: if (i < 0) {
1607: if (en_revstrf && !standard) {
1608: a[0] = a[f - (abs(i) - 1)];
1609: a[1] = EOL;
1610: }
1611: else {
1612: a[0] = EOL;
1613: }
1614: }
1615: }
1616: else {
1617: /* out of range */
1618: a[0] = a[i];
1619: a[1] = EOL;
1620: } /* get character */
1621:
1622: goto nxt_operator;
1623:
1624:
1625: case 3:
1626:
1627: {
1628: char tstr[STRLEN];
1629: long int e_length;
1630: long int e_start;
1631: long int e_end;
1632:
1633: stcpy (tstr, a);
1634:
1635: e_start = intexpr (argstck[arg + 1]) - 1;
1636: e_end = intexpr (argstck[arg + 2]);
1637: e_length = stlen(tstr);
1638:
1639: if (e_start < 0) {
1640:
1641: if (en_revstrf && !standard) {
1642: e_start = e_length - abs(e_start) + 1;
1643: }
1644: else {
1645: a[0] = EOL;
1646: goto nxt_operator;
1647: }
1648:
1649: }
1650:
1651: if (e_end < 0) {
1652:
1653: if (en_revstrf && !standard) {
1654: e_end = e_length - abs(e_end) + 1;
1655: }
1656: else {
1657: a[0] = EOL;
1658: goto nxt_operator;
1659: }
1660:
1661: }
1662:
1663: tstr[e_end] = EOL;
1664: stcpy (a, &(tstr[e_start]));
1665:
1666: goto nxt_operator;
1667:
1668: }
1669:
1670: default:
1671: merr_raise (FUNARG);
1672:
1673: {
1674: return;
1675: }
1676:
1677: }
1678:
1679: case 'a': /* $ASCII */
1680:
1681: if (f == 1) {
1682: intstr (a, (*a != EOL ? UNSIGN ((int) *a) : -1));
1683: goto nxt_operator;
1684: }
1685:
1686: if (f > 2) {
1687: merr_raise (FUNARG);
1688: return;
1689: }
1690:
1691: b = argstck[arg + 1];
1692: i = intexpr (b);
1693:
1694: /* ascii number of selected character or -1 if out of range */
1695: intstr (a, (i >= (b - a)) || i <= 0 ? -1 : UNSIGN ((int) a[i - 1]));
1696:
1697: goto nxt_operator;
1698:
1699:
1700: case 'c': /* $CHARACTER */
1701:
1.11 snw 1702: {
1.1 snw 1703: short l, l1, m, n;
1704:
1705: l1 = f;
1706: i = 0;
1707: f = 0;
1708: j = 0;
1709: m = 0;
1710: n = 1;
1711: l = 0;
1712:
1.11 snw 1713:
1.1 snw 1714: for (;;) {
1715:
1716: if ((ch = a[i++]) == EOL) {
1717:
1718: if (m == 0) {
1719:
1720: if (j > DEL) {
1721:
1722: if (standard) {
1723: merr_raise (NOSTAND);
1724: return;
1725: }
1726:
1727: if (eightbit) {
1728: j &= 0377;
1729: if ((((char) j) == EOL) || (((char) j) == DELIM)) j = NUL;
1730: }
1731: else {
1732: j &= 0177;
1733: }
1734:
1735: }
1736:
1737: if (f >= STRLEN) {
1738: a[f] = EOL;
1739: merr_raise (M75);
1740:
1741: return;
1742: }
1743:
1744: a[f++] = j;
1745:
1746: }
1747:
1748: if (++l >= l1) break;
1749:
1750: j = 0;
1751: m = 0;
1752: n = 1;
1753:
1754: continue;
1755:
1756: }
1757:
1758: if (n == 0) continue;
1759:
1760: if (ch >= '0' && ch <= '9') {
1761: j *= 10;
1762: j += ch - '0';
1763:
1764: continue;
1765: }
1766:
1767: if (ch == '-') {
1768: m |= 01;
1769: continue;
1770: }
1771:
1772: if (ch != '+') n = 0;
1773:
1774: }
1775:
1776: a[f] = EOL;
1777:
1778: }
1779:
1780: goto nxt_operator;
1781:
1782:
1783: case 'p': /* $PIECE */
1784:
1785: {
1786: long l, l1, m, n;
1787:
1788: b = argstck[arg + 1];
1789: l1 = b - a - 1; /* length of 1st argument */
1790:
1791: switch (f) {
1792:
1793:
1794: case 2:
1795:
1796: f = 1;
1797: l = 1;
1798:
1799: break;
1800:
1801:
1802: case 3:
1803:
1804: f = intexpr (argstck[arg + 2]);
1805:
1806: if (merr () == MXNUM) {
1807: merr_raise (OK);
1808: if (j >= 0) f = 256;
1809: }
1810:
1811: if (f <= 0) {
1812: a[0] = EOL;
1813: goto nxt_operator;
1814: }
1815:
1816: l = f;
1817:
1818: break;
1819:
1820:
1821: case 4:
1822:
1823: l = intexpr (argstck[arg + 3]);
1824:
1825: if (merr () == MXNUM) {
1826: merr_raise (OK);
1827: if (l >= 0) l = 256;
1828: }
1829:
1830: if ((f = intexpr (argstck[arg + 2])) <= 0) f = 1;
1831:
1832: if (merr () == MXNUM) {
1833: merr_raise (OK);
1834: if (f >= 0) f = 256;
1835: }
1836:
1837: if (f > l) {
1838: a[0] = EOL;
1839: goto nxt_operator;
1840: }
1841:
1842: break;
1843:
1844:
1845: default:
1846:
1847: merr_raise (FUNARG);
1848: return;
1849: }
1850:
1851: i = 0;
1852: m = 0;
1853: ch = 0;
1854:
1855: while (b[ch] != EOL) ch++; /* $l of 2nd arg */
1856:
1857: if (ch == 1) {
1858:
1859: ch = b[0];
1860: j = 1;
1861:
1862: if (f > 1) {
1863:
1864: while (i < l1) { /* scan 1st string ... */
1865:
1866: if (a[i++] != ch) continue; /* ... for occurence of 2nd */
1867:
1868: if (++j == f) {
1869: m = i;
1870: goto p10;
1871: }
1872:
1873: }
1874:
1875: a[0] = EOL;
1876: goto nxt_operator;
1877:
1878: }
1879:
1880: p10:
1881: for (; i < l1; i++) {
1882:
1883: if (a[i] != ch) continue;
1884:
1885: if (j == l) {
1886: a[i] = EOL;
1887: break;
1888: }
1889:
1890: j++;
1891:
1892: }
1893:
1894: if (m > 0) stcpy (a, &a[m]);
1895:
1896: goto nxt_operator;
1897:
1898: }
1899:
1900: if (ch == 0) {
1901: a[0] = EOL;
1902: goto nxt_operator;
1903: } /* 2nd arg is empty */
1904:
1905: /* else (ch>1) */
1906: n = 1;
1907:
1908: if (f > 1) {
1909:
1910: while (i < l1) { /* scan 1st string ... */
1911: j = 0;
1912:
1913: p20:
1914:
1915: if (a[i + j] != b[j]) {
1916: i++;
1917: continue;
1918: } /* ... for occurence of 2nd */
1919:
1920: if (++j < ch) goto p20;
1921:
1922: i += ch; /* skip delimiter */
1923:
1924: if (++n == f) {
1925: m = i;
1926: goto p30;
1927: }
1928: }
1929:
1930: a[0] = EOL;
1931:
1932: goto nxt_operator;
1933:
1934: }
1935: p30:
1936: while (i < l1) {
1937: j = 0;
1938:
1939: p40:
1940:
1941: if (a[i + j] != b[j]) {
1942: i++;
1943: continue;
1944: }
1945:
1946: if (++j < ch) goto p40;
1947:
1948: if (n == l) {
1949: a[i] = EOL;
1950: break;
1951: } /* last $piece: done! */
1952:
1953: i += ch;
1954: n++;
1955:
1956: }
1957:
1958: if (m > 0) stcpy (a, &a[m]);
1959:
1960: goto nxt_operator;
1961:
1962: }
1963:
1964: case 'l': /* $LENGTH */
1965:
1966: if (f == 1) {
1967: lintstr (a, stlen (a));
1968: goto nxt_operator;
1969: }
1970:
1971: if (f > 2) {
1972: merr_raise (FUNARG);
1973: return;
1974: }
1975:
1976: i = 0;
1977: j = 0;
1978: ch = 0;
1979: b = argstck[arg + 1];
1980:
1981: if ((f = stlen (b))) {
1982:
1983: f--;
1984:
1985: while ((i = find (&a[ch], b)) > 0) {
1986: j++;
1987: ch += i + f;
1988: }
1989:
1990: j++;
1991:
1992: }
1993:
1994: intstr (a, j);
1995:
1996: goto nxt_operator;
1997:
1998: case 'f': /* $FIND */
1999:
2000: {
2001: short l1;
2002:
2003: if (f < 2 || f > 3) {
2004: merr_raise (FUNARG);
2005: return;
2006: }
2007:
2008: if (f == 3) {
2009:
2010: i = intexpr (argstck[arg + 2]);
2011:
2012: if (merr () == MXNUM) {
2013:
2014: if (i > 0) i = 256;
2015:
2016: merr_raise (OK);
2017:
2018: /* important special case:
2019: * $FIND("","",number) ::= $S(number<1:1,1:integer(number))
2020: * needs special treatment so that it does not yield wrong
2021: * results on large values of number.
2022: */
2023: if ((argstck[arg + 1][0] == EOL) && (i > 0)) {
2024:
2025: numlit (argstck[arg + 2]);
2026:
2027: i = 0;
2028:
2029: while ((a[i] = argstck[arg + 2][i]) != EOL) {
2030:
2031: if (a[i] == '.') {
2032: a[i] = EOL;
2033: break;
2034: }
2035:
2036: i++;
2037:
2038: }
2039:
2040: goto nxt_operator;
2041:
2042: }
2043: }
2044:
2045: i--;
2046:
2047: if (i < 0) i = 0;
2048:
2049: }
2050: else {
2051: i = 0;
2052: }
2053:
2054: b = argstck[arg + 1];
2055: j = b - a - 1; /* length of first argument */
2056:
2057: if ((l1 = stlen (b)) == 0) {
2058: i++;
2059: goto f20;
2060: }
2061:
2062: for (f = i; f < j; f++) {
2063:
2064: for (ch = 0; ch < l1; ch++) {
2065: if (a[f + ch] != b[ch]) goto f10;
2066: }
2067:
2068: i = (++f) + l1;
2069:
2070: goto f20;
2071:
2072: f10:
2073: ; /* null statement to avoid compiler error
2074: due to having a label at the end of a
2075: block */
2076:
2077: }
2078:
2079: i = 0;
2080:
2081: f20:
2082:
2083: lintstr (a, i);
2084:
2085: }
2086:
2087: goto nxt_operator;
2088:
2089:
2090: case 'j': /* $JUSTIFY */
2091:
2092: if (f < 2 || f > 3) {
2093: merr_raise (FUNARG);
2094: return;
2095: }
2096:
2097: {
2098: long l, l1;
2099:
2100: l = intexpr (b = argstck[arg + 1]); /* 2nd arg */
2101: if (merr () == MXNUM) return; /* $J() arg number overflow */
2102:
2103: if (l > STRLEN) {
2104: /* $J() width string too long */
2105: merr_raise (M75);
2106: return;
2107: }
2108:
2109: if (f == 2) {
2110: f = b - a - 1;
2111: }
2112: else {
2113:
2114: f = intexpr (argstck[arg + 2]); /* 3rd arg */
2115:
2116: if (merr () == MXNUM) return; /* $J() arg number overflow */
2117:
2118: if (f > (STRLEN - 2)) {
2119: /* $J() .precision too long */
2120: merr_raise (M75);
2121: return;
2122: }
2123:
2124: numlit (a);
2125:
2126: if (f < 0) {
2127: merr_raise (ARGER);
2128: return;
2129: }
2130:
2131: /* s j=$l(a),i=$f(a,".")-1 */
2132: j = (a[0] == '-');
2133:
2134: if (a[j] == '.') { /* insert leading zero */
2135:
2136: i = j;
2137:
2138: while (a[i++] != EOL);
2139:
2140: while (i > j) {
2141: a[i] = a[i - 1];
2142: i--;
2143: }
2144:
2145: a[j] = '0';
2146:
2147: }
2148:
2149: i = (-1);
2150: j = 0;
2151:
2152: while (a[j] != EOL) {
2153: if (a[j] == '.') i = j;
2154: j++;
2155: }
2156:
2157: if (i < 0) {
2158: a[i = j] = '.';
2159: a[j + 1] = EOL;
2160: }
2161: else {
2162: j--;
2163: }
2164:
2165: if (j - i > f) { /* rounding required */
2166:
2167: if ((l1 = f + i + 1) > STRLEN) {
2168: merr_raise (M75);
2169: return;
2170: }
2171:
2172: if (a[l1] > '4') {
2173:
2174: do {
2175:
2176: if (a[--l1] == '.') l1--;
2177:
2178: if (l1 < (a[0] == '-')) {
2179:
2180: for (l1 = f + i + 1; l1 > 0; l1--) a[l1] = a[l1 - 1];
2181:
2182: a[a[0] == '-'] = '1';
2183: i++;
2184:
2185: break;
2186:
2187: }
2188:
2189: a[l1]++;
2190:
2191: if (a[l1] == ':') a[l1] = '0';
2192:
2193: } while (a[l1] == '0');
2194:
2195: }
2196:
2197: a[f + i + 1] = EOL;
2198:
2199: if (a[0] == '-' && a[1] == '0') {
2200:
2201: l1 = 2;
2202:
2203: while (a[l1] != EOL) {
2204:
2205: if (a[l1] >= '1' && a[l1] <= '9') {
2206: l1 = 0;
2207: break;
2208: }
2209:
2210: l1++;
2211:
2212: }
2213:
2214: if (l1) {
2215:
2216: i--;
2217: l1 = 0;
2218:
2219: while ((a[l1] = a[l1 + 1]) != EOL) l1++;
2220:
2221: }
2222: }
2223:
2224: }
2225: else { /* rounding not required */
2226:
2227: if (f + i + 1 > STRLEN) {
2228: merr_raise (M75);
2229: return;
2230: }
2231:
2232: while (j < f + i) a[++j] = '0';
2233:
2234: a[++j] = EOL;
2235:
2236: }
2237:
2238: if (f == 0) a[i] = EOL;
2239:
2240: } /* end of 3 arg-form */
2241:
2242: if (f < l) {
2243:
2244: i = stlen (a) + 1;
2245:
2246: if (++l <= i) goto nxt_operator;
2247:
2248: while (i >= 0) a[l--] = a[i--];
2249: while (l >= 0) a[l--] = SP;
2250:
2251: }
2252:
2253: }
2254:
2255: goto nxt_operator;
2256:
2257:
2258: /* case 'd': *//* $DATA */
2259: /* case 'g': *//* $GET */
2260: /* case 'i': *//* $INCREMENT */
2261: /* case 'n': *//* $NEXT */
2262: /* case ZNEXT: *//* $ZNEXT */
2263: /* case ZPREVIOUS: *//* $ZPREVIOUS */
2264: case 'o': /* $ORDER */
2265:
2266: if (f > 2) {
2267: merr_raise (FUNARG);
2268: return;
2269: }
2270:
2271: stcpy (varnam, argstck[arg]);
2272: ordercnt = intexpr (argstck[arg + 1]);
2273: ordercounter = 0;
2274:
2275: if (varnam[0] != '^') {
2276: symtab (fra_order, varnam, a);
2277: }
2278: else if (varnam[1] != '$') {
2279: global (fra_order, varnam, a);
2280: }
2281: else {
2282: ssvn (fra_order, varnam, a);
2283: }
2284:
2285: goto nxt_operator;
2286:
2287:
2288: case 'q': /* $QUERY */
2289:
2290: if (f > 2) {
2291: merr_raise (FUNARG);
2292: return;
2293: }
2294:
2295: stcpy (varnam, argstck[arg]);
2296: ordercnt = intexpr (argstck[arg + 1]);
2297:
2298: if (varnam[0] == '^' && varnam[1] == '$') {
2299: ssvn (fra_query, varnam, a);
2300: }
2301: else if (ordercnt == 1) {
2302: if (varnam[0] != '^') {
2303: symtab (fra_query, varnam, a);
2304: }
2305: else {
2306: global (fra_query, varnam, a);
2307: }
2308: }
2309: else {
2310: char qryarg_ext[256];
2311:
2312: freem_ref_t *revq_ref = (freem_ref_t *) malloc (sizeof (freem_ref_t));
2313:
2314: /* convert the $QUERY argument from internal to external format */
2315: mref_init (revq_ref, MREF_RT_GLOBAL, "scratch");
2316: internal_to_mref (revq_ref, varnam);
2317: mref_to_external (revq_ref, qryarg_ext);
2318:
2319: stcnv_c2m (qryarg_ext);
2320:
2321: /* put the $QUERY argument into the local variable %INT.REVQ */
1.7 snw 2322: symtab (set_sym, "%INTREVQ\201\201", qryarg_ext);
1.1 snw 2323:
2324: /* set up for calling into polyfill wrapper */
2325: code[0] = '\201';
2326: stcpy (code, "$^%ZREVQRY\201");
2327:
2328: codptr = code;
2329:
2330: f = '$';
2331:
2332: zexflag = TRUE;
2333:
2334: /* run the polyfill wrapper */
2335: goto extra_fun;
2336: }
2337:
2338: goto nxt_operator;
2339:
2340:
2341: case 'N': /* $NAME */
2342:
2343: if (f > 2) {
2344: merr_raise (FUNARG);
2345: return;
2346: }
2347:
2348: f = intexpr (argstck[arg + 1]);
2349:
2350: if (f < 0) {
2351: merr_raise (ARGER);
2352: return;
2353: }
2354:
2355: i = 0;
2356:
2357: while (a[++i] != EOL) {
2358: if (a[i] == DELIM && --f < 0) {
2359: break;
2360: }
2361: }
2362:
2363: a[i] = EOL;
2364:
2365: stcpy (varnam, a);
2366: zname (a, varnam);
2367:
2368: goto nxt_operator;
2369:
2370:
2371: case QLENGTH: /* $QLENGTH */
2372:
2373: if (f != 1) {
2374: merr_raise (FUNARG);
2375: return;
2376: }
2377:
2378: f = 0;
2379: i = 0;
2380:
2381: {
2382: int ch, quote;
2383:
2384: quote = 0;
2385:
2386: while ((ch = a[i++]) != EOL) {
2387:
2388: if (ch == '"') quote = !quote;
2389: if (quote) continue;
2390: if (ch == '(' && f == 0) f = 1;
2391: if (ch == ',') f++;
2392:
2393: }
2394:
2395: }
2396:
2397: intstr (a, f);
2398:
2399: goto nxt_operator;
2400:
2401:
2402: case QSUBSCRIPT: /* $QSUBSCRIPT */
2403:
2404: if (f != 2) {
2405: merr_raise (FUNARG);
2406: return;
2407: }
2408:
2409: if ((f = intexpr (argstck[arg+1])) < -1) {
2410: merr_raise (ARGER);
2411: return;
2412: }
2413:
2414: {
2415: int ch, env, quote, count, startsub;
2416:
2417: if (f == -1) { /* get environment */
2418:
2419: quote = 0;
2420: env = FALSE;
2421: count = 0;
2422: startsub = 0;
2423: i = 0;
2424:
2425: while ((ch = a[i++]) != EOL) {
2426:
2427: if (ch == '"') quote= !quote;
2428: if (quote) continue;
2429:
2430: if (ch == '|') {
2431:
2432: if (env) {
2433: a[i-1] = EOL;
2434: stcpy (a, &a[startsub]);
2435:
2436: break;
2437:
2438: }
2439: else {
2440: startsub = i;
2441: env = TRUE;
2442: }
2443:
2444: }
2445:
2446: }
2447:
2448: if (!env) *a= EOL;
2449:
2450: }
2451: else {
2452:
2453: quote = 0;
2454: env = FALSE;
2455: count = 0;
2456: startsub = 0;
2457: i = 0;
2458:
2459: while ((ch=a[i++])!=EOL) {
2460:
2461: if (ch == '"') quote = !quote;
2462: if (quote) continue;
2463:
2464: if (ch == '|' && count == 0) {
2465:
2466: if (env) {
2467:
2468: if (*a == '^') a[--i] = '^';
2469:
2470: startsub = i;
2471:
2472: }
2473: else {
2474: env = TRUE;
2475: }
2476:
2477: }
2478:
2479: if (ch == '(' || ch == ',' || ch == ')') {
2480:
2481: if (count == f) {
2482: a[i-1] = EOL;
2483: break;
2484: }
2485:
2486: count++;
2487: startsub = i;
2488:
2489: }
2490:
2491: }
2492:
2493: if (startsub) stcpy (a, &a[startsub]);
2494:
2495: if (count < f) *a = EOL;
2496:
2497: }
2498: if (a[0] == '"') { /* un-quote */
2499:
2500: quote = 1;
2501: i = 1;
2502: f = 0;
2503:
2504: while ((ch = a[i++]) != EOL) {
2505:
2506: if (ch == '"') quote = !quote;
2507:
2508: if (quote) a[f++] = ch;
2509:
2510: }
2511:
2512: a[f] = EOL;
2513:
2514: }
2515:
2516: }
2517:
2518: /* goto nxt_operator; */
2519:
2520:
2521: case 's': /* $SELECT */
2522:
2523: goto nxt_operator;
2524:
2525:
2526: case SVNstack: /* $STACK() */
2527:
2528: if (f > 2) {
2529: merr_raise (FUNARG);
2530: return;
2531: }
2532:
2533: if (f == 1) {
2534:
2535: char iex_buf[256];
2536: int iexp;
2537:
2538: stcpy (iex_buf, argstck[arg]);
2539: iexp = atoi (iex_buf);
2540:
2541: /*set_io (UNIX);
2542: printf ("iexp = %d\n", iexp);
2543: set_io (MUMPS);
2544: */
2545:
2546: if (iexp == -1) {
2547: intstr (a, merr_topstk);
2548: }
2549: else if (iexp == 0) {
2550: stcpy (a, stack0);
2551: }
2552: else if (iexp > 0 && iexp <= merr_topstk) {
2553:
2554: if (merr_topstk > nstx) {
2555: stcpy (a, merr_stack[merr_topstk].ECODE);
2556: }
2557: else {
2558: if (nestc[iexp] == '$') {
2559: stcpy (a, "$$\201");
2560: }
2561: else {
2562: if ((mtok_token_to_command (a, nestc[iexp])) != 1) {
2563: stcpy (a, "???");
2564: }
2565: }
2566: }
2567:
2568: }
2569: else {
2570: merr_raise (FUNARG);
2571: return;
2572: }
2573:
2574: }
2575:
2576: if (f == 2) {
2577:
2578: int stkidx;
2579: char sub[255];
2580: char indst[255];
2581: stcpy (indst, argstck[arg]);
2582: stcnv_m2c (indst);
2583:
2584: stkidx = atoi (indst);
2585:
2586: if (stkidx > NESTLEVLS || stkidx < 0) {
2587: merr_raise (FUNARG);
2588: return;
2589: }
2590:
2591: stcpy (sub, argstck[2]);
2592: stcnv_m2c (sub);
2593:
2594: if (strcmp (sub, "MCODE") == 0) {
2595: strcpy (a, merr_stack[stkidx].MCODE);
2596: }
2597: else if (strcmp (sub, "ECODE") == 0) {
2598: strcpy (a, merr_stack[stkidx].ECODE);
2599: }
2600: else if (strcmp (sub, "PLACE") == 0) {
2601: strcpy (a, merr_stack[stkidx].PLACE);
2602: }
2603: else {
2604: merr_raise (SYNTERR);
2605: return;
2606: }
2607:
2608: stcnv_c2m (a);
2609:
2610: }
2611:
2612:
2613: goto nxt_operator;
2614:
2615:
2616: case FNUMBER: /* $FNUMBER */
2617:
2618: if (f < 2 || f > 3) {
2619: merr_raise (FUNARG);
2620: return;
2621: }
2622:
2623: {
2624:
2625: short l1;
2626: short Pflag;
2627: short Tflag;
2628: short commaflag;
2629: short plusflag;
2630: short minusflag;
2631: short EuroFlag;
2632: short IsZero;
2633:
2634: Pflag = FALSE,
2635: Tflag = FALSE,
2636: commaflag = FALSE,
2637: plusflag = FALSE,
2638: minusflag = FALSE,
2639: EuroFlag = FALSE,
2640: IsZero = FALSE;
2641:
2642: b = argstck[arg + 1];
2643:
2644: while ((i = *b++) != EOL) { /* evaluate options */
2645:
2646: switch (i) {
2647:
2648:
2649: case 'P':
2650:
2651: Pflag = TRUE;
2652: continue;
2653:
2654:
2655: case 'p':
2656:
2657: if (lowerflag) Pflag = TRUE;
2658: continue;
2659:
2660:
2661: case 'T':
2662:
2663: Tflag = TRUE;
2664: continue;
2665:
2666:
2667: case 't':
2668:
2669: if (lowerflag) Tflag = TRUE;
2670: continue;
2671:
2672:
2673: case ',':
2674:
2675: commaflag = TRUE;
2676: continue;
2677:
2678:
2679: case '.':
2680:
2681: EuroFlag = TRUE;
2682: continue;
2683:
2684:
2685: case '+':
2686:
2687: plusflag = TRUE;
2688: continue;
2689:
2690:
2691: case '-':
2692:
2693: minusflag = TRUE;
2694:
2695:
2696: }
2697: }
2698:
2699: if (Pflag && (Tflag || plusflag || minusflag)) {
2700: merr_raise (ARGER);
2701: return;
2702: }
2703:
2704: if (f == 3) j = intexpr (argstck[arg + 2]); /* 3rd arg */
2705:
2706: if (merr () == MXNUM) {
2707:
2708: if (j >= 0) j = 256;
2709:
2710: merr_raise (OK);
2711:
2712: }
2713:
2714: numlit (a);
2715: IsZero = (a[0] == '0');
2716:
2717: if (f == 3) {
2718:
2719: f = j;
2720:
2721: if (f < 0) {
2722: merr_raise (ARGER);
2723: return;
2724: }
2725:
2726: if (f > STRLEN) {
2727: merr_raise (M75);
2728: return;
2729: }
2730:
2731: /* s j=$l(a),i=$f(a,".")-1 */
2732: j = (a[0] == '-');
2733:
2734: if (a[j] == '.') { /* insert leading zero */
2735:
2736: i = j;
2737:
2738: while (a[i++] != EOL);
2739:
2740: while (i > j) {
2741: a[i] = a[i - 1];
2742: i--;
2743: }
2744:
2745: a[j] = '0';
2746:
2747: }
2748:
2749: i = (-1);
2750: j = 0;
2751:
2752: while (a[j] != EOL) {
2753:
2754: if (a[j] == '.') i = j;
2755:
2756: j++;
2757:
2758: }
2759:
2760: if (i < 0) {
2761: a[i = j] = '.';
2762: a[j + 1] = EOL;
2763: }
2764: else {
2765: j--;
2766: }
2767:
2768: if (j - i > f) { /* rounding required */
2769:
2770: l1 = f + i + 1;
2771:
2772: if (a[l1] > '4') {
2773:
2774: do {
2775:
2776: if (a[--l1] == '.') l1--;
2777:
2778: if (l1 < 0) {
2779:
2780: for (l1 = f + i + 1; l1 > 0; l1--) {
2781: a[l1] = a[l1 - 1];
2782: }
2783:
2784: a[0] = '1';
2785: i++;
2786:
2787: break;
2788:
2789: }
2790:
2791: a[l1]++;
2792:
2793: if (a[l1] == ':') a[l1] = '0';
2794:
2795: } while (a[l1] == '0');
2796:
2797: }
2798:
2799: a[f + i + 1] = EOL;
2800:
2801: if (a[0] == '-' && a[1] == '0') {
2802:
2803: l1 = 2;
2804:
2805: while (a[l1] != EOL) {
2806:
2807: if (a[l1] >= '1' && a[l1] <= '9') {
2808: l1 = 0;
2809: break;
2810: }
2811:
2812: l1++;
2813:
2814: }
2815:
2816: if (l1) {
2817:
2818: i--;
2819: l1 = 0;
2820:
2821: while ((a[l1] = a[l1 + 1]) != EOL) l1++;
2822:
2823: }
2824:
2825: }
2826:
2827: }
2828: else {
2829:
2830: if (f + i > STRLEN) {
2831: merr_raise (M75);
2832: return;
2833: }
2834:
2835: while (j < f + i) a[++j] = '0';
2836:
2837: a[++j] = EOL;
2838: }
2839:
2840: if (f == 0) a[i] = EOL;
2841:
2842: } /* end of 3 arg-form */
2843:
2844: if (commaflag) {
2845:
2846: i = 0;
2847:
2848: while ((f = a[i]) != '.' && f != EOL) i++;
2849:
2850: if (a[0] == '-') {
2851:
2852: f = (i + 1) % 3;
2853: j = 1;
2854: i = 1;
2855: tmp[0] = '-';
2856:
2857: }
2858: else {
2859:
2860: f = (i + 2) % 3;
2861: j = 0;
2862: i = 0;
2863:
2864: }
2865:
2866: while ((tmp[j++] = a[i]) != EOL) {
2867:
2868: if (j >= STRLEN) {
2869: merr_raise (M75);
2870: return;
2871: }
2872:
2873: if (a[i++] == '.') f = -1; /* do not insert comma after point */
2874:
2875: if (f-- == 0 && a[i] != EOL && a[i] != '.') {
2876: f = 2;
2877: tmp[j++] = ',';
2878: }
2879:
2880: }
2881:
2882: stcpy (a, tmp);
2883:
2884: }
2885:
2886: if (EuroFlag && !standard) { /* exchange point and comma */
2887:
2888: i = 0;
2889:
2890: while ((f = a[i]) != EOL) {
2891:
2892: if (f == '.') a[i] = ',';
2893: if (f == ',') a[i] = '.';
2894:
2895: i++;
2896:
2897: }
2898:
2899: }
2900:
2901: if (Tflag) {
2902:
2903: i = stcpy (tmp, a);
2904:
2905: if (plusflag && tmp[0] != '-' && !IsZero) {
2906:
2907: tmp[i] = '+';
2908: tmp[++i] = EOL;
2909: stcpy (a, tmp);
2910:
2911: }
2912: else if (tmp[0] == '-') {
2913:
2914: tmp[i] = minusflag ? SP : '-';
2915: tmp[++i] = EOL;
2916: stcpy (a, &tmp[1]);
2917:
2918: }
2919: else {
2920:
2921: tmp[i] = SP;
2922: tmp[++i] = EOL;
2923: stcpy (a, tmp);
2924:
2925: }
2926:
2927: goto nxt_operator;
2928:
2929: }
2930:
2931: if (Pflag) {
2932:
2933: i = stcpy (&tmp[1], a);
2934:
2935: if (a[0] == '-') {
2936:
2937: a[0] = '(';
2938: a[i] = ')';
2939: a[++i] = EOL;
2940:
2941: }
2942: else {
2943:
2944: tmp[0] = SP;
2945: tmp[++i] = SP;
2946: tmp[++i] = EOL;
2947:
2948: stcpy (a, tmp);
2949: }
2950:
2951: goto nxt_operator;
2952:
2953: }
2954:
2955: if (plusflag && a[0] != '-' && !IsZero) {
2956: stcpy (tmp, a);
2957: a[0] = '+';
2958: stcpy (&a[1], tmp);
2959: }
2960:
2961: if (minusflag && a[0] == '-') {
2962: stcpy (tmp, &a[1]);
2963: stcpy (a, tmp);
2964: }
2965:
2966: }
2967:
2968: goto nxt_operator;
2969:
2970:
2971: case REVERSE: /* $REVERSE */
2972:
2973: if (f != 1) {
2974: merr_raise (FUNARG);
2975: return;
2976: }
2977:
2978: i = stlen (a) - 1;
2979: j = i / 2;
2980: i = i - j;
2981:
2982: while (j >= 0) {
2983: f = a[j];
2984: a[j--] = a[i];
2985: a[i++] = f;
2986: }
2987:
2988: goto nxt_operator;
2989:
2990:
2991: case 't': /* $TEXT */
2992:
2993: {
2994: long l1, rouoldc;
2995: short reload = FALSE;
1.16 snw 2996:
2997: /*
1.17 snw 2998: printf ("a = %s f = %d arg = %d\r\n", a, f, arg);
1.16 snw 2999: for (i = arg; i < arg + f; i++) {
3000: printf ("argstck[%d] = '%s'\r\n", i, argstck[i]);
3001: }
1.17 snw 3002:
3003: for (i = 0; i < strlen (a); i++)
3004: printf ("%c = %d\r\n", a[i], (unsigned char) a[i]);
1.16 snw 3005: */
1.15 snw 3006:
1.1 snw 3007: if (f > 3) {
3008: merr_raise (FUNARG);
3009: return;
3010: }
3011:
3012: i = 0;
3013:
3014: if (f > 1) {
3015: stcpy (tmp, argstck[arg + 1]);
3016: i = intexpr (tmp);
3017: }
3018:
3019: if (a[0] == EOL) {
3020:
3021: if (i < 0) {
3022: merr_raise (ARGER);
3023: return;
3024: }
3025:
3026: /* $T(+0) returns routine name */
3027: if (i == 0) {
3028:
3029: if (f != 3) {
3030: stcpy (a, rou_name);
3031: }
3032: else {
3033: stcpy (a, argstck[arg + 2]);
3034: }
3035:
3036: goto nxt_operator;
3037:
3038: }
3039:
3040: }
3041:
3042: if (f == 3) {
3043:
3044: reload = TRUE; /* load routine; */
3045: f = mcmnd;
3046: mcmnd = 'd'; /* make load use standard-path */
3047:
3048: stcpy (tmp, argstck[arg + 2]);
3049:
3050: rouoldc = roucur - rouptr;
3051:
3052: zload (tmp);
3053:
3054: mcmnd = f;
3055:
3056: if (merr () > OK) {
3057:
3058: zload (rou_name);
3059:
3060: if (merr () == NOPGM) {
3061: ierr -= NOPGM; /* smw 15 nov 2023 TODO HUH?? */
3062: *a = EOL;
3063:
3064: goto nxt_operator;
3065: }
3066:
3067: return;
3068:
3069: }
3070:
3071: }
3072:
3073: j = 0;
3074: f = 1;
3075:
3076: if (a[0] != EOL) { /* 1st arg == label */
3077:
3078: for (;;) {
3079:
3080: if (j >= (rouend - rouptr)) {
3081: a[0] = EOL;
3082: goto t_end;
3083: }
3084:
3085: l1 = j;
3086: f = 0;
3087:
3088: while (*(rouptr + (++l1)) == a[f++]);
3089:
3090: if (a[--f] == EOL && (*(rouptr + l1) == TAB || *(rouptr + l1) == SP || *(rouptr + l1) == '(')) break;
3091:
3092: j += (UNSIGN (*(rouptr + j)) + 2); /* skip line */
3093:
3094: }
3095:
3096: f = 0;
3097:
3098: }
3099:
3100: if (i > 0) {
3101:
3102: while (f < i) {
3103:
3104: if ((j = j + (UNSIGN (*(rouptr + j))) + 2) >= (rouend - rouptr)) {
3105: a[0] = EOL;
3106: goto t_end;
3107: }
3108:
3109: f++;
3110:
3111: }
3112:
3113: }
3114:
3115: if (i < 0) {
3116:
3117: j--;
3118:
3119: while (f != i) {
3120:
3121: while (*(rouptr + (--j)) != EOL && j >= 0);
3122:
3123: if (--f != i && j < 1) {
3124: a[0] = EOL;
3125: goto t_end;
3126: }
3127:
3128: }
3129:
3130: j++;
3131:
3132: }
3133:
3134: f = (-1);
3135: j++;
3136:
3137: while ((a[++f] = (*(rouptr + (j++)))) != EOL) {
3138: if (a[f] == TAB || a[f] == SP)
3139: break;
3140: }
3141:
3142: if (j >= (rouend - rouptr - 1)) {
3143: a[0] = EOL;
3144: }
3145: else {
3146:
3147: a[f] = SP;
3148:
3149: while ((*(rouptr + j)) == TAB || (*(rouptr + j)) == SP) {
3150: j++;
3151: a[++f] = SP;
3152: }
3153:
3154: stcpy (&a[++f], rouptr + j);
3155:
3156: }
3157:
3158: t_end:
3159: if (reload) {
3160: zload (rou_name);
3161: roucur = rouptr + rouoldc;
3162: } /* reload routine; */
3163:
3164: }
3165:
3166: goto nxt_operator;
3167:
3168:
3169: case TRANSLATE: /* $TRANSLATE */
3170:
3171: if (f > 3 || f < 2) {
3172: merr_raise (FUNARG);
3173: return;
3174: }
3175:
3176: {
3177: short l1, m;
3178: char *c;
3179:
3180: b = argstck[arg + 1];
3181: c = argstck[arg + 2];
3182:
3183: if (f == 2) {
3184: l1 = 0;
3185: }
3186: else {
3187: l1 = stlen (c); /* $l of 3rd arg */
3188: }
3189:
3190: m = 0;
3191: f = 0;
3192:
3193: while ((ch = a[f++]) != EOL) {
3194:
3195: j = 0;
3196:
3197: while (b[j] != EOL) {
3198:
3199: if (ch == b[j]) {
3200:
3201: if (j < l1) {
3202: ch = c[j];
3203: }
3204: else {
3205: ch = EOL;
3206: }
3207:
3208: break;
3209:
3210: }
3211:
3212: j++;
3213:
3214: }
3215:
3216: if (ch != EOL) a[m++] = ch;
3217:
3218: }
3219:
3220: a[m] = EOL;
3221:
3222: }
3223:
3224: goto nxt_operator;
3225:
3226: case TYPE:
3227: {
3228: char piv[255];
3229:
3230: if (f != 1) {
3231: merr_raise (FUNARG);
3232: return;
3233: }
3234:
3235: stcpy (piv, argstck[arg]);
3236: stcnv_m2c (piv);
3237:
3238: obj_get_attribute (piv, "CLASS", a);
3239: stcnv_c2m (a);
3240:
3241: goto nxt_operator;
3242: }
3243:
3244: case INSTANCEOF:
3245: {
3246: char io_inst[255];
3247: char io_cls[255];
3248: short io_res;
3249:
3250: if (f != 2) {
3251: merr_raise (FUNARG);
3252: return;
3253: }
3254:
3255: stcpy (io_inst, argstck[arg]);
3256: stcpy (io_cls, argstck[arg + 1]);
3257:
3258: stcnv_m2c (io_inst);
3259: stcnv_m2c (io_cls);
3260:
3261: io_res = obj_instance_of (io_inst, io_cls);
3262:
3263: intstr (a, (int) io_res);
3264:
3265: goto nxt_operator;
3266: }
3267: case 'r': /* $RANDOM */
3268:
3269: if (f != 1) {
3270: merr_raise (FUNARG);
3271: return;
3272: }
3273:
3274: {
3275: long ilong;
3276:
3277: nrandom = (ran_a * nrandom + ran_b) % ran_c;
3278:
3279: if ((i = intexpr (a)) < 1) {
3280: merr_raise (ARGER);
3281: return;
3282: }
3283:
3284: ilong = (nrandom * i) / ran_c;
3285:
3286: if (ilong < 0) ilong += i;
3287:
3288: lintstr (a, ilong);
3289:
3290: }
3291:
3292: goto nxt_operator;
3293:
3294:
3295: /* $VIEW */
3296: case 'v':
3297:
3298: view_fun (f, a);
3299:
3300: if (merr () > 0) return;
3301:
3302: goto nxt_operator;
3303:
3304:
3305: /* $ZBOOLEAN */
3306: case 'B':
3307:
3308: if (f != 3) {
3309: merr_raise (FUNARG);
3310: return;
3311: }
3312:
3313: i = 0;
3314: ch = intexpr (argstck[arg + 2]) % 16;
3315: b = argstck[arg + 1];
3316:
3317: if (*b == EOL) {
3318: *b = 0;
3319: b[1] = 0;
3320: }
3321:
3322: f = 0;
3323:
3324: switch (ch) {
3325:
3326:
3327: /* 1: A AND B */
3328: case 1:
3329:
3330: while (a[i] != EOL) {
3331:
3332: a[i] &= b[f];
3333: i++;
3334:
3335: if (b[++f] == EOL) f = 0;
3336:
3337: }
3338:
3339: break;
3340:
3341:
3342: /* 7: A OR B */
3343: case 7:
3344:
3345: while (a[i] != EOL) {
3346:
3347: a[i] |= b[f];
3348: i++;
3349:
3350: if (b[++f] == EOL) f = 0;
3351:
3352: }
3353:
3354: break;
3355:
3356:
3357: /* 6: A XOR B */
3358: case 6:
3359:
3360: while (a[i] != EOL) {
3361:
3362: a[i] = (a[i] ^ b[f]) & (eightbit ? 0377 : 0177);
3363: i++;
3364:
3365: if (b[++f] == EOL) f = 0;
3366:
3367: }
3368:
3369: break;
3370:
3371:
3372: /* 14: A NAND B */
3373: case 14:
3374:
3375: while (a[i] != EOL) {
3376:
3377: a[i] = ~(a[i] & b[f]) & (eightbit ? 0377 : 0177);
3378: i++;
3379:
3380: if (b[++f] == EOL) f = 0;
3381:
3382: }
3383:
3384: break;
3385:
3386:
3387: /* 8: A NOR B */
3388: case 8:
3389:
3390: while (a[i] != EOL) {
3391:
3392: a[i] = ~(a[i] | b[f]) & (eightbit ? 0377 : 0177);
3393: i++;
3394:
3395: if (b[++f] == EOL) f = 0;
3396:
3397: }
3398:
3399: break;
3400:
3401:
3402: /* 9: A EQUALS B */
3403: case 9:
3404:
3405: while (a[i] != EOL) {
3406:
3407: a[i] = ~(a[i] ^ b[f]) & (eightbit ? 0377 : 0177);
3408: i++;
3409:
3410: if (b[++f] == EOL) f = 0;
3411:
3412: }
3413:
3414: break;
3415:
3416:
3417: /* 2: A AND NOT B */
3418: case 2:
3419:
3420: while (a[i] != EOL) {
3421:
3422: a[i] &= ~b[f];
3423: i++;
3424:
3425: if (b[++f] == EOL) f = 0;
3426:
3427: }
3428:
3429: break;
3430:
3431:
3432: /* 11: A OR NOT B */
3433: case 11:
3434:
3435: while (a[i] != EOL) {
3436:
3437: a[i] = (a[i] | ~b[f]) & (eightbit ? 0377 : 0177);
3438: i++;
3439:
3440: if (b[++f] == EOL) f = 0;
3441:
3442: }
3443:
3444: break;
3445:
3446:
3447: /* 13: NOT A OR B */
3448: case 13:
3449:
3450: while (a[i] != EOL) {
3451:
3452: a[i] = (~a[i] | b[f]) & (eightbit ? 0377 : 0177);
3453: i++;
3454:
3455: if (b[++f] == EOL) f = 0;
3456:
3457: }
3458:
3459: break;
3460:
3461:
3462: /* 4: NOT A AND B */
3463: case 4:
3464:
3465: while (a[i] != EOL) {
3466:
3467: a[i] = ~a[i] & b[f];
3468: i++;
3469:
3470: if (b[++f] == EOL) f = 0;
3471:
3472: }
3473:
3474: break;
3475:
3476:
3477: /* 5: B */
3478: case 5:
3479:
3480: while (a[i] != EOL) {
3481:
3482: a[i++] = b[f];
3483:
3484: if (b[++f] == EOL) f = 0;
3485:
3486: }
3487:
3488: break;
3489:
3490:
3491: /* 10: NOT B */
3492: case 10:
3493:
3494: while (a[i] != EOL) {
3495:
3496: a[i++] = ~b[f] & 0177;
3497:
3498: if (b[++f] == EOL) f = 0;
3499:
3500: }
3501:
3502: break;
3503:
3504:
3505: /* 12: NOT A */
3506: case 12:
3507:
3508: while (a[i] != EOL) {
3509:
3510: a[i] = ~a[i] & 0177;
3511: i++;
3512:
3513: if (b[++f] == EOL) f = 0;
3514:
3515: }
3516:
3517: break;
3518:
3519:
3520: /* 0: always FALSE */
3521: case 0:
3522:
3523: while (a[i] != EOL)
3524: a[i++] = 0;
3525: break;
3526:
3527:
3528: /* 15: always TRUE */
3529: case 15:
3530:
3531: ch = (char) 0177;
3532: while (a[i] != EOL)
3533: a[i++] = ch;
3534: /* 3: A */
3535:
3536: }
3537:
3538: goto nxt_operator;
3539:
3540:
3541: /* ZCRC "cyclic redundancy check" check sums */
3542: case ZCRC:
3543:
3544: if (f == 1) {
3545: f = 0; /* missing 2nd arg defaults to "0" */
3546: }
3547: else {
3548:
3549: if (f != 2) {
3550: merr_raise (FUNARG);
3551: return;
3552: }
3553:
3554: if ((f = intexpr (argstck[arg + 1])) != 0 && f != 1) {
3555: merr_raise (ARGER);
3556: return;
3557: }
3558:
3559: }
3560:
3561: i = 0;
3562:
3563: if (f == 0) { /* XORing */
3564:
3565: f = 0;
3566:
3567: while (a[i] != EOL) f ^= a[i++];
3568:
3569: f = f & 0377;
3570:
3571: }
3572: else { /* ASCII sum */
3573:
3574: f = 0;
3575:
3576: while (a[i] != EOL) f += a[i++];
3577:
3578: }
3579:
3580: intstr (a, f);
3581:
3582: goto nxt_operator;
3583:
3584:
3585: /* $ZFUNCTIONKEY */
3586: case 'F':
3587:
3588: if (f != 1) {
3589: merr_raise (FUNARG);
3590: return;
3591: }
3592:
3593: if ((i = intexpr (a)) < 1 || i > 44) {
3594: merr_raise (FUNARG);
3595: return;
3596: }
3597:
3598: stcpy (a, zfunkey[i - 1]);
3599:
3600: goto nxt_operator;
3601:
3602:
3603: case 'P': /* $ZPIECE */
3604:
3605: /* Similar to $PIECE */
3606: /* The difference is, that stuff within quotes is not */
3607: /* counted as delimiter. nor is stuff within brackets */
3608:
3609: {
3610: short l, l1, m, n;
3611: short quo = 0; /* quotes */
3612: short bra = 0; /* brackets */
3613: char ch0;
3614:
3615: b = argstck[arg + 1];
3616: l1 = b - a - 1; /* length of 1st argument */
3617:
3618: switch (f) {
3619:
3620:
3621: case 2:
3622:
3623: f = 1;
3624: l = 1;
3625:
3626: break;
3627:
3628:
3629: case 3:
3630:
3631: if ((f = intexpr (argstck[arg + 2])) <= 0) {
3632: a[0] = EOL;
3633: goto nxt_operator;
3634: }
3635:
3636: if (merr () == MXNUM) {
3637: if (f >= 0) f = 256;
3638: merr_raise (OK);
3639: }
3640:
3641: l = f;
3642: break;
3643:
3644:
3645: case 4:
3646:
3647: l = intexpr (argstck[arg + 3]);
3648:
3649: if (merr () == MXNUM) {
3650:
3651: if (l >= 0) l = 256;
3652:
3653: merr_raise (OK);
3654:
3655: }
3656:
3657: if ((f = intexpr (argstck[arg + 2])) <= 0) f = 1;
3658:
3659: if (merr () == MXNUM) {
3660:
3661: if (f >= 0) f = 256;
3662:
3663: merr_raise (OK);
3664:
3665: }
3666:
3667: if (f > l) {
3668: a[0] = EOL;
3669: goto nxt_operator;
3670: }
3671:
3672: break;
3673:
3674:
3675: default:
3676:
3677: merr_raise (FUNARG);
3678: return;
3679:
3680: }
3681:
3682: i = 0;
3683: m = 0;
3684: ch = 0;
3685:
3686: while (b[ch] != EOL) ch++; /* $l of 2nd arg */
3687:
3688: if (ch == 1) {
3689:
3690: ch = b[0];
3691: j = 1;
3692:
3693: if (f > 1) {
3694:
3695: while (i < l1) { /* scan 1st string ... */
3696:
3697: ch0 = a[i++];
3698:
3699: if (ch != '"') {
3700:
3701: if (ch0 == '"') {
3702: toggle (quo);
3703: continue;
3704: }
3705:
3706: if (quo) continue;
3707:
3708: }
3709:
3710: if (ch0 == '(') bra++;
3711: if (ch0 == ')') bra--;
3712:
3713: if (ch0 != ch) continue;
3714: if (bra > 1) continue;
3715: if ((ch0 != '(') && bra) continue;
3716:
3717: if (++j == f) {
3718: m = i;
3719: goto zp10;
3720: }
3721:
3722: }
3723:
3724: /* if(j<f) */
3725: a[0] = EOL;
3726:
3727: goto nxt_operator;
3728:
3729: }
3730:
3731: zp10:
3732:
3733: for (; i < l1; i++) {
3734:
3735: ch0 = a[i];
3736:
3737: if (ch != '"') {
3738:
3739: if (ch0 == '"') {
3740: toggle (quo);
3741: continue;
3742: }
3743:
3744: if (quo) continue;
3745:
3746: }
3747:
3748: if (ch0 == '(') bra++;
3749: if (ch0 == ')') bra--;
3750: if (ch0 != ch) continue;
3751: if (bra > 1) continue;
3752: if ((ch0 != '(') && bra) continue;
3753:
3754: if (j == l) {
3755: a[i] = EOL;
3756: break;
3757: }
3758:
3759: j++;
3760:
3761: }
3762:
3763: if (m > 0) stcpy (a, &a[m]);
3764:
3765: goto nxt_operator;
3766:
3767: }
3768:
3769: if (ch == 0) {
3770: a[0] = EOL;
3771: goto nxt_operator;
3772: } /* 2nd arg is empty */
3773:
3774: /* else (ch>1) $Length of Delimiter>1 */
3775: n = 1;
3776:
3777: if (f > 1) {
3778:
3779: while (i < l1) { /* scan 1st string ... */
3780:
3781: j = 0;
3782:
3783: if ((ch0 = a[i]) == '"') {
3784: toggle (quo);
3785: i++;
3786:
3787: continue;
3788: }
3789:
3790: if (quo) {
3791: i++;
3792: continue;
3793: }
3794:
3795: if (ch0 == '(') {
3796: bra++;
3797: i++;
3798:
3799: continue;
3800: }
3801:
3802: if (ch0 == ')') {
3803: bra--;
3804: i++;
3805:
3806: continue;
3807: }
3808:
3809: if (bra) {
3810: i++;
3811: continue;
3812: }
3813:
3814: zp20:
3815: if (a[i + j] != b[j]) {
3816: i++;
3817: continue;
3818: } /* ... for occurence of 2nd */
3819:
3820: if (++j < ch) goto zp20;
3821:
3822: i += ch; /* skip delimiter */
3823:
3824: if (++n == f) {
3825: m = i;
3826: goto zp30;
3827: }
3828: }
3829:
3830: /* if(n<f) */ a[0] = EOL;
3831:
3832: goto nxt_operator;
3833: }
3834:
3835: zp30:
3836:
3837: while (i < l1) {
3838:
3839: j = 0;
3840:
3841: if ((ch0 = a[i]) == '"') {
3842: toggle (quo);
3843: i++;
3844:
3845: continue;
3846: }
3847:
3848: if (quo) {
3849: i++;
3850: continue;
3851: }
3852:
3853: if (ch0 == '(') {
3854: bra++;
3855: i++;
3856:
3857: continue;
3858: }
3859:
3860: if (ch0 == ')') {
3861: bra--;
3862: i++;
3863:
3864: continue;
3865: }
3866:
3867: if (bra) {
3868: i++;
3869: continue;
3870: }
3871:
3872: zp40:
3873: if (a[i + j] != b[j]) {
3874: i++;
3875: continue;
3876: }
3877:
3878: if (++j < ch) goto zp40;
3879:
3880: if (n == l) {
3881: a[i] = EOL;
3882: break;
3883: } /* last $zpiece: done! */
3884:
3885: i += ch;
3886: n++;
3887:
3888: }
3889:
3890: if (m > 0) stcpy (a, &a[m]);
3891:
3892: goto nxt_operator;
3893:
3894: }
3895:
3896: case 'L': /* $ZLENGTH */
3897:
3898: /* Similar to $LENGTH with two arguments */
3899: /* The difference is, that stuff within quotes is not */
3900: /* counted as delimiter. nor is stuff within brackets */
3901:
3902: if (f != 2) {
3903: merr_raise (FUNARG);
3904: return;
3905: }
3906:
3907: i = 0;
3908: j = 0;
3909:
3910: b = argstck[arg + 1];
3911:
3912: if ((f = stlen (b))) {
3913: int quo,
3914: bra,
3915: ch0;
3916:
3917: quo = 0;
3918: bra = 0;
3919:
3920: if (f == 1) { /* length of delimiter =1 char */
3921:
3922: ch = b[0];
3923: j = 0;
3924:
3925: for (;;) {
3926:
3927: ch0 = a[i++];
3928:
3929: if (ch0 == EOL) break;
3930:
3931: if (ch != '"') {
3932:
3933: if (ch0 == '"') {
3934: toggle (quo);
3935: continue;
3936: }
3937:
3938: if (quo) continue;
3939:
3940: }
3941:
3942: if (ch0 == '(') bra++;
3943: if (ch0 == ')') bra--;
3944: if (ch0 != ch) continue;
3945: if (bra > 1) continue;
3946: if ((ch0 != '(') && bra) continue;
3947:
3948: j++;
3949: }
3950:
3951:
3952: j++;
3953:
3954: }
3955: else {
3956:
3957: int n;
3958:
3959: j = 1;
3960:
3961: for (;;) {
3962:
3963: n = 0;
3964:
3965: if ((ch0 = a[i]) == '"') {
3966: toggle (quo);
3967: i++;
3968:
3969: continue;
3970: }
3971:
3972: if (ch0 == EOL) break;
3973:
3974: if (quo) {
3975: i++;
3976: continue;
3977: }
3978:
3979: if (ch0 == '(') {
3980: bra++;
3981: i++;
3982:
3983: continue;
3984: }
3985:
3986: if (ch0 == ')') {
3987: bra--;
3988: i++;
3989:
3990: continue;
3991: }
3992:
3993: if (bra) {
3994: i++;
3995: continue;
3996: }
3997:
3998: zl10:
3999:
4000: if (a[i + n] != b[n]) {
4001: i++;
4002: continue;
4003: }
4004:
4005: if (++n < f) goto zl10;
4006:
4007: i += f; /* skip delimiter */
4008: j++;
4009:
4010: }
4011: }
4012: }
4013:
4014: intstr (a, j);
4015: goto nxt_operator;
4016:
4017: case ZLSD: /* $ZLSD levenshtein function */
4018:
4019: if (f != 2) {
4020: merr_raise (FUNARG);
4021: return;
4022: }
4023:
4024: f = levenshtein (a, argstck[arg + 1]);
4025: intstr (a, f);
4026:
4027: goto nxt_operator;
4028:
4029:
4030: /* $ZKEY */
4031: /* transform a string to be used as a key in an array so */
4032: /* the result string will collate in the desired way */
4033: /* according to the production rule specified by VIEW 93 */
4034: case 'K':
4035:
4036: if (f == 2) {
4037: zkey (a, intexpr (argstck[arg + 1]));
4038: }
4039: else if (f == 1) {
4040: zkey (a, v93);
4041: }
4042: else {
4043: merr_raise (FUNARG);
4044: }
4045:
4046: if (merr () > OK) return;
4047:
4048: goto nxt_operator;
4049:
4050:
4051: /* $ZREPLACE */
4052: /* Replace in first argument non overlapping occurences */
4053: /* of the second argument by the third argument. */
4054: /* if the third argument is missing, assume it to be empty */
4055: case 'R':
4056:
4057: if (f == 3) {
4058: zreplace (a, argstck[arg + 1], argstck[arg + 2]);
4059: }
4060: else if (f == 2) {
4061: zreplace (a, argstck[arg + 1], "\201");
4062: }
4063: else {
4064: merr_raise (FUNARG);
4065: }
4066:
4067: if (merr () > OK) return;
4068:
4069: goto nxt_operator;
4070:
4071:
4072: /* $ZSYNTAX */
4073:
4074: case 'S':
4075:
4076: if (f != 1) {
4077: merr_raise (FUNARG);
4078: return;
4079: }
4080:
4081: zsyntax (a);
4082:
4083: if (merr () > OK) return;
4084:
4085: goto nxt_operator;
4086:
4087:
4088: /* $ZTIME()/$ZDATE() */
4089: case 'T':
4090: case 'D':
4091:
4092: {
4093: time_t unix_epoch;
4094: char *horo_time = a;
4095: char fmt_string[120];
4096: struct tm *zdate_time;
4097:
4098: if (f > 2) {
4099: merr_raise (FUNARG);
4100: return;
4101: }
4102:
4103: if (!is_horolog (horo_time)) {
4104: merr_raise (ZINVHORO);
4105: return;
4106: }
4107:
4108: if (f == 2) {
4109: stcpy (fmt_string, argstck[arg + 1]);
4110: }
4111: else if (f == 1) {
4112: char zdf_key[50];
4113:
4114: switch (i) {
4115:
4116: case 'D':
4117: sprintf (zdf_key, "^$JOB\202%d\202ZDATE_FORMAT\201", pid);
4118: break;
4119:
4120: case 'T':
4121: sprintf (zdf_key, "^$JOB\202%d\202ZTIME_FORMAT\201", pid);
4122: break;
4123:
4124: }
4125:
4126: ssvn (get_sym, zdf_key, fmt_string);
4127: }
4128:
4129: stcnv_m2c (fmt_string);
4130:
4131: unix_epoch = horolog_to_unix (horo_time);
4132: zdate_time = localtime (&unix_epoch);
4133:
4134: strftime (a, 255, fmt_string, zdate_time);
4135:
4136: stcnv_c2m (a);
4137:
4138: goto nxt_operator;
4139: }
4140:
4141:
4142: /* $ZHOROLOG() */
4143: /* convert string date to $H format */
4144: case 'H':
4145: {
4146: char *time_str = a;
4147: char *fmt_string = argstck[arg + 1];
4148: struct tm zhoro_tm;
4149: unsigned long ilong;
4150: unsigned long ilong1;
4151:
4152: if (f != 2) {
4153: merr_raise (FUNARG);
4154: return;
4155: }
4156:
4157: strptime (time_str, fmt_string, &zhoro_tm);
4158:
4159: ilong1 = mktime (&zhoro_tm) + tzoffset;
4160: ilong = ilong1 / 86400;
4161:
4162: lintstr (a, ilong + 47117);
4163: i = stlen (a);
4164:
4165: a[i++] = ',';
4166: ilong = ilong1 - (ilong * 86400) + 43200;
4167:
4168: lintstr (&a[i], ilong);
4169:
4170: goto nxt_operator;
4171:
4172: }
4173:
4174:
4175: case GETX: /* dummy function for implicit $GET */
4176:
4177: /* un-stack $ZREFERENCE and $ZLOCAL */
4178: stcpy (zref, refsav[--refsx]);
4179: stcpy (zloc, refsav[refsx] + 256);
4180:
4181: free (refsav[refsx]);
4182:
4183:
4184: case GET: /* dummy function for $GET with two args */
4185:
4186: goto nxt_operator;
4187:
4188:
4189: case 'E': /* ZEDIT */
4190:
4191: if (f > 4) {
4192: merr_raise (FUNARG);
4193: return;
4194: }
4195:
4196: {
4197:
4198: int k, l, rev, esc;
4199:
4200: if (f == 1) {
4201: rev = TRUE;
4202: goto reverse;
4203: }
4204:
4205: j = (f == 4 ? intexpr (argstck[arg + 3]) : 1); /* type of action */
4206:
4207: if ((rev = j < 0)) j = (-j);
4208: if ((esc = j / 10) == 1 || esc == 2) j = j % 10;
4209:
4210: if (j < 1 || j > 3) {
4211: merr_raise (ARGER);
4212: return;
4213: }
4214:
4215: f = (f >= 3 ? intexpr (argstck[arg + 2]) : 0); /* target length */
4216:
4217: if (f > 255) merr_raise (ARGER);
4218:
4219: if (merr () > OK) return;
4220:
4221: if (esc == 1) { /* remove ESC-Sequences */
4222:
4223: stcpy (tmp, a);
4224:
4225: i = 0;
4226: k = 0;
4227: l = 1;
4228: esc = 0;
4229:
4230: while ((a[k] = tmp[i++]) != EOL) {
4231:
4232: if (l) {
4233: if (a[k] != ESC) {
4234: k++;
4235: continue;
4236: }
4237:
4238: if ((a[k] = tmp[i++]) != '[') continue;
4239:
4240: l = 0;
4241:
4242: continue;
4243: }
4244:
4245: if (a[k] >= '@') l = 1;
4246:
4247: }
4248:
4249: }
4250:
4251: /* anything to be done ??? */
4252: if (argstck[arg + 1][0] == EOL) goto reverse;
4253:
4254: stcpy (tmp, argstck[arg + 1]);
4255:
4256: if (j != 1) { /* remove leading characters */
4257:
4258: i = 0;
4259: k = 0;
4260:
4261: while (a[i] != EOL) {
4262:
4263: if (a[i] == tmp[k]) {
4264: i++;
4265: k = 0;
4266:
4267: continue;
4268: }
4269:
4270: if (tmp[k++] == EOL) break;
4271:
4272: }
4273:
4274: if (i) stcpy (a, &a[i]);
4275:
4276: }
4277:
4278: if (j != 3) { /* remove trailing characters */
4279:
4280: i = stlen (a) - 1;
4281: k = 0;
4282:
4283: while (i >= 0) {
4284:
4285: if (a[i] == tmp[k]) {
4286: i--;
4287: k = 0;
4288:
4289: continue;
4290: }
4291:
4292: if (tmp[k++] == EOL) break;
4293:
4294: }
4295:
4296: a[i + 1] = EOL;
4297:
4298: }
4299:
4300: i = stlen (a);
4301:
4302: if ((f -= i) > 0) { /* characters to append */
4303:
4304: if (esc == 2) { /* ignore ESC-Sequences */
4305:
4306: k = 0;
4307: l = 1;
4308:
4309: while (a[k] != EOL) {
4310:
4311: if (l) {
4312:
4313: if (a[k++] == ESC) {
4314:
4315: f += 2;
4316:
4317: if (a[k++] == '[') l = 0;
4318:
4319: }
4320: }
4321: else {
4322:
4323: f++;
4324:
4325: if (a[k++] >= '@') l = 1;
4326:
4327: }
4328:
4329: }
4330:
4331: }
4332:
4333: k = 0;
4334:
4335: if (j == 1) {
4336: k = f;
4337: f = 0;
4338: }
4339:
4340: if (j == 2) {
4341: k = f - f / 2;
4342: f -= k;
4343: }
4344:
4345: l = stlen (tmp);
4346:
4347: if (k) { /* append on right side */
4348:
4349: a[k += i] = EOL;
4350: j = l;
4351:
4352: while (--k >= i) {
4353:
4354: a[k] = tmp[--j];
4355:
4356: if (j <= 0) j = l;
4357:
4358: }
4359:
4360: }
4361:
4362: if (f) { /* append on left side */
4363:
4364: i = 0;
4365:
4366: while (l < f) tmp[l++] = tmp[i++];
4367:
4368: stcpy (&tmp[l], a);
4369: stcpy (a, tmp);
4370:
4371: }
4372:
4373: }
4374:
4375: reverse:
4376:
4377: if (rev) {
4378:
4379: i = stlen (a) - 1;
4380: j = 0;
4381: f = i / 2;
4382:
4383: while (j <= f) {
4384: k = a[j];
4385: a[j++] = a[i];
4386: a[i--] = k;
4387: }
4388:
4389: }
4390:
4391: }
4392:
4393: goto nxt_operator;
4394:
4395: default:
4396: merr_raise (ILLFUN);
4397: return;
4398:
4399:
4400: }
4401:
4402: /* end of function evaluation section */
4403:
4404: nxt_operator:
4405:
4406: if (spx > 0 && (f = op_stck[spx]) != ARRAY && f != '(') {
4407: goto nxt_expr;
4408: }
4409: /* push answer */
4410:
4411: op_stck[++spx] = OPERAND;
4412: codptr++;
4413:
4414: goto nextchr;
4415:
4416:
4417: case '$': /* scan function name convert upper to lower */
4418:
4419: if (op_stck[spx] == OPERAND) goto m_operator;
4420: if ((f = *++codptr) >= 'A' && f <= 'Z') f += 32;
4421:
4422: if (f == 'z' && standard) {
4423: merr_raise (NOSTAND);
4424: return;
4425: }
4426:
4427: if (f == '$' || f == '%') { /* extrinsic function/extrinsic variable */
4428:
4429: zexflag = FALSE;
4430:
4431: extra_fun:
4432:
4433:
4434: {
4435: short savmcmnd, savsetp; /* stuff to be saved */
4436: char savarnam[256];
4437: char *savdofr;
4438: long savlen;
4439: short savtest;
4440: short savop;
4441: char *savargs = NULL;
4442: int savarg;
4443: char *savastck;
4444: char *savpart;
4445: char *b;
4446: char *namold;
4447: long rouoldc;
4448: char label[255],
4449: routine[255];
4450: short errex; /* FLAG: error exit */
4451: short libcall;
4452: libcall = FALSE;
4453:
4454: for (i = 0; i < 255; i++) {
4455: routine[i] = '\201';
4456: }
4457:
4458: if (f == '%') libcall = TRUE;
4459:
4460: savmcmnd = mcmnd;
4461: savsetp = setpiece;
4462: savop = setop;
4463: savtest = test;
4464: stcpy (savarnam, varnam);
4465: savdofr = dofram0;
4466: errex = FALSE;
4467:
4468: if ((argstck[++arg] = a) >= s) {
4469:
4470: char *bak;
4471: bak = partition;
4472:
4473: if (getpmore () == 0) {
4474: merr_raise (STKOV);
4475: return;
4476: }
4477:
4478: a = a - bak + partition;
4479: b = b - bak + partition;
4480:
4481: }
4482:
4483: savlen = a - argptr;
4484: savpart = partition;
4485:
4486: if (spx > 0) {
4487:
4488: if ((savargs = calloc ((unsigned) (savlen + 256L), 1)) == NULL) {
4489: merr_raise (STKOV);
4490: return;
4491: } /* could not allocate stuff... */
4492:
4493: stcpy0 (savargs, argptr, savlen + 256L);
4494: argptr = partition;
4495:
4496: }
4497:
4498: savarg = arg;
4499:
4500: if ((savastck = calloc ((unsigned) (arg + 1), sizeof (char *))) == NULL) {
4501: merr_raise (STKOV);
4502: return;
4503: } /* could not allocate stuff... */
4504:
4505: stcpy0 (savastck, (char *) argstck, (long) ((arg + 1) * sizeof (char *)));
4506:
4507: b = label; /* parse label */
4508:
4509: if ((ch = *++codptr) == '%') {
4510: *b++ = ch;
4511: codptr++;
4512: }
4513:
4514: while (((ch = *codptr) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9')) {
4515: *b++ = ch;
4516: codptr++;
4517: }
4518:
4519: *b = EOL;
4520: b = routine;
4521:
4522:
4523: if (obj_field) {
4524: strcpy (b, &(object_class[1]));
4525: stcnv_c2m (b);
4526: b += strlen (object_class) - 1;
4527: *++b = EOL;
4528: }
4529:
4530:
4531:
4532: if (ch == '^') { /* parse routine name */
4533:
4534:
4535:
4536: if (((ch = *++codptr) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '%') {
4537: *b++ = ch;
4538: }
4539:
4540: while (((ch = *++codptr) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9')) {
4541: *b++ = ch;
4542: }
4543:
4544: if (libcall) {
4545: char newnam[255];
4546:
4547: for (i = 0; i < stlen (routine); i++) {
4548: routine[i] = tolower (routine[i]);
4549: }
4550:
4551: newnam[0] = '%';
4552: newnam[1] = 'u';
4553: newnam[2] = 'l';
4554: newnam[3] = '\201';
4555:
4556: stcat (newnam, routine);
4557:
4558: routine[0] = EOL;
4559: stcpy (routine, newnam);
4560:
4561: b = b + 3;
4562: }
4563:
4564:
4565: if (routine[0] == EOL) {
4566: merr_raise (ILLFUN);
4567: errex = TRUE;
4568:
4569: goto errexfun;
4570: }
4571:
4572: }
4573:
4574:
4575:
4576: {
4577: char nrou[255];
4578: char ntag[255];
4579: char nbuf[255];
4580:
4581: stcpy (nrou, routine);
4582: stcpy (ntag, label);
4583:
4584: stcnv_m2c (nrou);
4585: stcnv_m2c (ntag);
4586:
4587:
4588: if (rtn_resolve (nrou, ntag, nbuf) != NULL) {
4589: strcpy (routine, nbuf);
4590: stcnv_c2m (routine);
4591: }
4592: else {
4593: merr_raise (LBLUNDEF);
4594: return;
4595: }
4596: }
4597:
4598:
4599: *b = EOL;
4600:
4601: /* something must be specified */
4602: if (label[0] == EOL && routine[0] == EOL) {
4603: merr_raise (ILLFUN);
4604: errex = TRUE;
4605:
4606: goto errexfun;
4607: }
4608:
4609:
4610: if (obj_field) {
1.13 snw 4611: char t_objf[STRLEN];
1.1 snw 4612:
1.13 snw 4613: snprintf (t_objf, STRLEN - 1, "%s\201", object_instance);
1.1 snw 4614:
4615: dofram0 = dofrmptr;
4616: *dofrmptr++ = DELIM;
4617: dofrmptr += stcpy (dofrmptr, t_objf) + 1;
4618: }
4619:
4620:
4621: if (*codptr == '(' && *(codptr + 1) != ')') {
4622:
4623:
4624: if (!obj_field) dofram0 = dofrmptr;
4625: obj_field = FALSE;
4626:
4627:
1.12 snw 4628: /* dofram0 = dofrmptr; */
1.1 snw 4629:
4630: i = 0;
4631: codptr++;
4632:
4633: for (;;) {
4634:
4635: setpiece = TRUE; /* to avoid error on closing bracket */
4636:
4637: if (*codptr == '.' && (*(codptr + 1) < '0' || *(codptr + 1) > '9')) {
4638:
4639: codptr++;
4640:
4641: expr (NAME);
4642: codptr++;
4643: *dofrmptr++ = DELIM; /* to indicate call by name */
4644: dofrmptr += stcpy (dofrmptr, varnam) + 1;
4645:
4646: }
4647: else {
4648: expr (STRING);
4649: dofrmptr += stcpy (dofrmptr, argptr) + 1;
4650: }
4651:
4652: setpiece = FALSE;
4653: i++;
4654:
4655: if (merr () > OK) {
4656: dofrmptr = dofram0;
4657: errex = TRUE;
4658:
4659: goto errexfun;
4660: }
4661:
4662: ch = *codptr++;
4663:
4664: if (ch == ',') continue;
4665:
4666: if (ch != ')') {
4667: merr_raise (COMMAER);
4668: dofrmptr = dofram0;
4669: errex = TRUE;
4670:
4671: goto errexfun;
4672: }
4673:
4674: ch = *codptr;
4675:
4676: break;
4677:
4678: }
4679:
4680: }
4681: else {
4682:
4683:
4684: if (!obj_field) {
4685: dofram0 = 0;
4686: }
4687:
4688: obj_field = FALSE;
4689:
1.12 snw 4690: /* dofram0 = 0; */
1.1 snw 4691: if (*codptr == '(') codptr += 2;
4692:
4693: }
4694:
4695: rouoldc = roucur - rouptr;
4696: namold = 0;
4697:
4698: if (routine[0] != EOL) { /* load routine */
4699:
4700: dosave[0] = EOL;
4701: loadsw = TRUE;
4702:
4703: while ((*(namptr++)) != EOL);
4704:
4705: namold = namptr;
4706:
4707: stcpy (namptr, rou_name);
4708: zload (routine);
4709:
4710: if (merr () > OK) {
4711: errex = TRUE;
4712: goto errexfun;
4713: }
4714:
4715: }
4716:
4717: {
4718:
4719: char *reg, *reg1;
4720:
4721: reg1 = rouptr;
4722: reg = reg1;
4723:
4724: if (label[0] != EOL) {
4725:
4726: while (reg < rouend) {
4727:
4728: reg++;
4729: j = 0;
4730:
4731: while (*reg == label[j]) {
4732: reg++;
4733: j++;
4734: }
4735:
4736: if (label[j] == EOL) {
4737:
4738: if (*reg == ':') {
4739: char return_type[255];
4740: short ret_type;
4741: register int typei;
4742:
4743: /* we got a return type. parse it. */
4744: reg++; /* skip over the colon */
4745:
4746: typei = 0;
4747:
4748: while (isalpha ((ch = *reg++))) {
4749: return_type[typei++] = toupper (ch);
4750: }
4751:
4752: reg--; /* back up to the previous char so that parsing of the entry point can resume later */
4753: return_type[typei] = '\0';
4754:
4755: ret_type = dt_get_type (return_type);
4756: if (ret_type == DT_INVALID) {
4757: merr_raise (INVTYPE);
4758: errex = TRUE;
4759:
4760: goto errexfun;
4761: }
4762:
4763: /* save off the return type to be checked by QUIT code */
4764: extr_types[nstx + 1] = ret_type;
4765:
1.12 snw 4766: /* printf ("return_type = '%s' *reg = '%c'\r\n", return_type, *reg); */
1.1 snw 4767: }
4768:
4769: if (*reg == TAB || *reg == SP) goto off;
4770: /* call of procedure without specifying a parameter list */
4771:
4772: if (*reg == '(') {
4773:
4774: if (dofram0 == 0) dofram0 = dofrmptr;
4775:
4776: goto off;
4777:
4778: }
4779:
4780: }
4781:
4782: reg = (reg1 = reg1 + UNSIGN (*reg1) + 2);
4783:
4784: }
4785:
4786: {
4787:
4788: merr_raise (LBLUNDEF);
4789: stcpy (varerr, label); /* to be included in error message */
4790:
4791: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
4792:
4793: zload (rou_name);
4794:
4795: errex = TRUE;
4796:
4797: goto errexfun;
4798:
4799: }
4800: }
4801:
4802: off:
4803:
4804: roucu0 = reg1;
4805:
4806: }
4807:
4808: if (roucu0 >= rouend) {
4809:
4810: merr_raise (LBLUNDEF);
4811: stcpy (varerr, label); /* to be included in error message */
4812:
4813: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
4814:
4815: zload (rou_name);
4816: errex = TRUE;
4817:
4818: goto errexfun;
4819:
4820: }
4821:
4822: if (routine[0] != EOL) stcpy (rou_name, routine);
4823:
4824: roucu0++;
4825: forsw = FALSE;
4826:
4827: #ifdef DEBUG_NEWSTACK
4828: printf("Stack PUSH in expr.c!\r\n");
4829: #endif
4830:
4831: if (++nstx > NESTLEVLS) {
4832: nstx--;
4833: merr_raise (STKOV);
4834: errex = TRUE;
4835:
4836: goto errexfun;
4837: }
4838: else {
4839: estack++;
4840: }
4841:
4842: nestc[nstx] = '$';
4843:
4844: #ifdef DEBUG_NEWSTACK
4845: if(!cmdptr) printf("CMDPTR is ZERO!\r\n");
4846: #endif
4847:
4848: nestp[nstx] = cmdptr;
4849: nestn[nstx] = namold;
4850: nestr[nstx] = rouoldc;
4851: nestnew[nstx] = 0;
4852: nestlt[nstx] = level;
4853: level = 0; /* push level ; clr level */
4854: ztrap[nstx][0] = EOL;
4855:
4856: cmdptr += stcpy (cmdptr, codptr - 1) + 1;
4857: roucur = roucu0;
4858:
4859: if (dofram0) {
4860:
4861: char *reg, *reg1;
4862:
4863: reg = roucu0;
4864: reg1 = dofram0;
4865:
4866: while ((ch = (*reg++)) != '(') {
4867:
4868: if (ch == SP || ch == TAB || ch == EOL) {
4869: break;
4870: }
4871:
4872: }
4873:
4874: if (ch != '(') {
4875:
4876: merr_raise (TOOPARA);
4877: dofrmptr = dofram0;
4878: errex = TRUE;
4879:
4880: #ifdef DEBUG_NEWSTACK
4881: printf("Cheesy Stack POP in expr.c\r\n");
4882: #endif
4883:
4884:
4885:
4886: nstx--;
4887: estack--;
4888:
4889: goto errexfun;
4890:
4891: }
4892:
4893: j = 0;
4894:
4895: if (*reg == ')') {
4896: reg++;
4897: }
4898: else {
4899: /* PARSE FORMALLIST */
4900: short fl_type;
1.12 snw 4901: /* re-enable following 3 later */
4902: /*short fl_mandatory;*/
4903: /*short fl_byref;*/
4904: /*short lastparm;*/
1.1 snw 4905: char fl_typestr[255];
4906: char fl_mand;
4907: short dtcheck_result;
4908: register short typei;
4909: short gotparm;
4910: int paramct;
4911:
4912: fl_type = DT_AUTO;
1.12 snw 4913: /* re-enable following 3 later */
4914: /*fl_mandatory = TRUE;*/
4915: /*fl_byref = FALSE;*/
4916: /*lastparm = FALSE;*/
1.1 snw 4917: dtcheck_result = FALSE;
4918: gotparm = FALSE;
4919: paramct = 0;
4920:
4921: while ((ch = (*reg++)) != EOL) {
4922:
4923: gotparm = FALSE;
4924:
4925: if ((ch == ':') && j) {
4926:
4927: /* we have a type specification */
4928: typei = 0;
4929:
4930: while ((ch = (*reg++)) != EOL) {
4931: /* parse it */
4932: if (isalpha (ch)) {
4933: fl_typestr[typei++] = ch;
4934: }
4935: else if (ch == ':') {
4936: /* we have an "optional" part */
4937: fl_typestr[typei] = '\0';
4938: fl_mand = *(reg + 1);
4939:
1.12 snw 4940: /*
1.1 snw 4941: if ((fl_mand == 'o') || (fl_mand == 'O')) {
4942: fl_mandatory = FALSE;
4943: }
4944: else {
4945: merr_raise (INVLIBOPT);
4946: dofrmptr = dofram0;
4947:
4948: errex = TRUE;
4949:
4950: nstx--;
4951: estack--;
4952:
4953: goto errexfun;
4954: }
1.12 snw 4955: */
4956:
4957: if ((fl_mand != 'o') && (fl_mand != 'O')) {
4958: merr_raise (INVLIBOPT);
4959: dofrmptr = dofram0;
4960:
4961: errex = TRUE;
4962:
4963: nstx--;
4964: estack--;
4965:
4966: goto errexfun;
4967: }
4968:
4969:
1.1 snw 4970: }
4971: else if ((ch == ',') || (ch == ')')) {
4972:
1.12 snw 4973: /* re-enable later
1.1 snw 4974: if (ch == ')') {
4975: lastparm = TRUE;
4976: }
1.12 snw 4977: */
1.1 snw 4978:
4979: gotparm = TRUE;
4980: paramct++;
4981:
4982: fl_typestr[typei] = '\0';
4983: fl_type = dt_get_type (fl_typestr);
4984:
4985: if (fl_type == DT_INVALID) {
4986:
4987: merr_raise (INVTYPE);
4988: dofrmptr = dofram0; /* reset frame pointer */
4989: errex = TRUE;
4990:
4991: nstx--;
4992: estack--;
4993:
4994: goto errexfun;
4995:
4996: }
4997:
4998: break;
4999: }
5000: }
5001: }
5002:
5003: if (gotparm == TRUE) {
5004:
5005: if (reg1[0] == DELIM) {
5006: dtcheck_result = dt_check (fl_type, reg1 + 1, paramct);
5007: }
5008: else {
5009: dtcheck_result = dt_check (fl_type, reg1, paramct);
5010: }
5011:
5012: if (dtcheck_result == FALSE) {
5013: merr_raise (TYPMISMATCH);
1.12 snw 5014: dofrmptr = dofram0; /* reset frame pointer */
1.1 snw 5015:
5016: errex = TRUE;
5017:
5018: nstx--;
5019: estack--;
5020:
5021: goto errexfun;
5022: }
5023: }
5024:
5025: if ((ch == ',' || ch == ')') && j) {
5026:
5027: varnam[j] = EOL;
5028:
5029: #if 0
5030: printf("01 [nstx] nstx is (%d) in expr.c\r\n",nstx);
5031: printf("[nestnew[nstx]] is (%d) in expr.c\r\n",nestnew[nstx]);
5032: printf("[newptr] newptr is [");
5033: for(loop=0; loop<50; loop++)
5034: printf("%c", (newptr[loop] == EOL) ? '!' : newptr[loop]);
5035: printf("] in expr.c\r\n");
5036: #endif
5037:
5038: if (nestnew[nstx] == 0) nestnew[nstx] = newptr;
5039:
5040: if (reg1 < dofrmptr) {
5041:
5042: if (*reg1 == DELIM) { /* call by reference */
5043:
5044: if (stcmp (reg1 + 1, varnam)) { /* are they different?? */
5045: symtab (new_sym, varnam, "");
5046: symtab (m_alias, varnam, reg1 + 1);
5047: }
5048:
5049: }
5050: else {
5051: symtab (new_sym, varnam, ""); /* call by value */
5052: symtab (set_sym, varnam, reg1);
5053: }
5054:
5055: reg1 += stlen (reg1) + 1;
5056:
5057: }
5058: else {
5059: symtab (new_sym, varnam, "");
5060: }
5061:
5062: if (ch == ')') break;
5063:
5064: j = 0;
5065: continue;
5066: }
5067:
5068: if ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9' && j) || (ch == '%' && j == 0)) {
5069: varnam[j++] = ch;
5070: continue;
5071: }
5072:
5073: merr_raise (ARGLIST);
5074: dofrmptr = dofram0; /* reset frame pointer */
5075: errex = TRUE;
5076:
5077: nstx--;
5078: estack--;
5079:
5080: goto errexfun;
5081:
5082: }
5083:
5084: }
5085:
5086: if (reg1 < dofrmptr) {
5087: merr_raise (TOOPARA);
5088: dofrmptr = dofram0; /* reset frame pointer */
5089: errex = TRUE;
5090: nstx--;
5091: estack--;
5092:
5093: goto errexfun;
5094: }
5095:
5096: dofrmptr = dofram0;
5097:
5098: }
5099:
5100: xecline (0);
5101:
5102: if (repQUIT) { /* repeat QUIT */
5103:
5104: stcpy (code, " V 26:\201");
5105:
5106: #ifdef DEBUG_NEWSTACK
5107: printf("Trying to get at nstx in expr.c (2)\r\n");
5108: #endif
5109:
5110: intstr (&code[6], nstx - repQUIT);
5111: repQUIT = 0;
5112: codptr = code;
5113:
5114: return;
5115:
5116: }
5117:
5118: stcpy (tmp, argptr);
5119:
5120: errexfun:
5121:
5122: mcmnd = savmcmnd;
5123: setpiece = savsetp;
5124: setop = savop;
5125: test = savtest;
5126:
5127: stcpy (varnam, savarnam);
5128:
5129: dofram0 = savdofr;
5130: argptr = partition;
5131: a = argptr;
5132:
5133: if (spx > 0) {
5134: stcpy0 (argptr, savargs, savlen + 256L);
5135: free (savargs);
5136: }
5137:
5138: arg = savarg;
5139: stcpy0 ((char *) argstck, savastck, (long) ((arg + 1) * sizeof (char *)));
5140:
5141: free (savastck);
5142: a = savlen + argptr;
5143:
5144: if (savpart != partition) { /* autoadjust may have changed that */
5145:
5146: f = 0;
5147:
5148: while (f <= arg) {
5149:
5150: if (argstck[f]) argstck[f] = argstck[f] - savpart + partition;
5151:
5152: f++;
5153:
5154: }
5155:
5156: }
5157:
5158: if (errex) {
5159:
5160: if (zexflag && (merr () == NOPGM || merr () == LBLUNDEF)) merr_raise (ILLFUN);
5161: return;
5162:
5163: }
5164:
5165: if (merr () != OK) return;
5166: /* if (ierr != OK && ierr != (OK - CTRLB)) return;*/
5167:
5168: stcpy (a, tmp);
5169:
5170: goto exec;
5171:
5172: } /* end of extrinsic function/variable section */
5173:
5174: }
5175: else if (((ch = *++codptr) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z')) {
5176:
5177: if (ch < 'a') ch += 32;
5178:
5179: tmp[0] = SP;
5180: tmp[1] = f;
5181: tmp[2] = ch;
5182: b = &tmp[3];
5183:
5184: while (((ch = *++codptr) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z')) *b++ = ch | 0140;
5185:
5186: *b++ = SP;
5187: *b = EOL;
5188:
5189: if (ch == '(') { /* function */
5190:
5191: if (f != 'z') { /* standard instrinsic functions */
5192:
5193: if (find (" ascii char data extract find fn fnumber get increment ins instanceof justify length na name next order piece \
5194: query qlength ql qsubscript qs random re reverse select st stack text tr translate ty type view ", tmp) == FALSE) {
5195: merr_raise (ILLFUN);
5196: return;
5197: }
5198:
5199: if (f == 'f' && tmp[2] == 'n') f = FNUMBER;
5200: else if (f == 'q' && tmp[2] == 'l') f = QLENGTH;
5201: else if (f == 'q' && tmp[2] == 's') f = QSUBSCRIPT;
5202: else if (f == 'r' && tmp[2] == 'e') f = REVERSE;
5203: else if (f == 's' && tmp[2] == 't') f = SVNstack;
5204: else if (f == 't' && tmp[2] == 'r') f = TRANSLATE;
5205: else if (f == 'n' && tmp[2] == 'a') f = 'N';
5206: else if (f == 't' && tmp[2] == 'y') f = TYPE;
5207: else if (f == 'i' && tmp[3] == 's') f = INSTANCEOF;
5208:
5209: }
5210: else {
5211:
5212: /* userdefined intrinsic: process as extrinsic */
5213: if ((find (zfunctions, tmp) == FALSE) && (tmp[2] != 'f' || tmp[3] != SP)) {
5214:
5215: f = stlen (tmp) - 1;
5216: stcpy (&tmp[f], codptr);
5217:
5218: code[0] = '$';
5219: code[1] = '^';
5220: code[2] = '%';
5221: code[3] = 'Z';
5222:
5223: stcpy (&code[4], &tmp[2]);
5224:
5225: codptr = code;
5226: f = '$';
5227: zexflag = TRUE;
5228:
5229: goto extra_fun;
5230:
5231: }
5232:
5233: f = tmp[2] - 32;
5234:
5235: if (tmp[3] == SP) {
5236:
5237: if (f == 'S' && s_fun_flag == FALSE) f = 'o'; /* ZSORT(=$ORDER) instead of ZSYNTAX */
5238: if (f == 'P' && p_fun_flag == FALSE) f = ZPREVIOUS; /* ZPREVIOUS instead of ZPIECE */
5239: if (f == 'D' && d_fun_flag == FALSE) f = ZDATA; /* ZDATA instead of ZDATE */
5240: if (f == 'N' && n_fun_flag == FALSE) f = ZNEXT; /* ZNEXT instead of ZNAME */
5241:
5242: }
5243: else {
5244:
5245: switch (f) {
5246:
5247:
5248: case 'C':
5249: if ((stcmp (" zcrc \201", tmp) == 0) ||
5250: (stcmp (" zcr \201", tmp) == 0))
5251: f = ZCRC;
5252: break;
5253:
5254:
5255: case 'D':
5256: if (stcmp (" zdata \201", tmp) == 0)
5257: f = ZDATA;
5258: break;
5259:
5260:
5261: case 'L':
5262: if (stcmp (" zlsd \201", tmp) == 0)
5263: f = ZLSD;
5264: break;
5265:
5266:
5267: case 'N':
5268: if (stcmp (" znext \201", tmp) == 0)
5269: f = ZNEXT;
5270: break;
5271:
5272:
5273: case 'P':
5274: if (stcmp (" zprevious \201", tmp) == 0)
5275: f = ZPREVIOUS;
5276: break;
5277:
5278: case 'S':
5279: if (stcmp (" zsort \201", tmp) == 0)
5280: f = 'o'; /* process $ZSORT as $ORDER */
5281: break;
5282:
5283:
5284: }
5285:
5286: }
5287: }
5288: }
5289: else { /* special variable */
5290:
5291: if (f != 'z') {
5292:
5293: if (find (" di dialect ec ecode es estack et etrap device horolog io job key pd pdisplay principal quit reference st stack storage sy system test ti timezone tl tlevel tr trollback wi with ", tmp) == FALSE) {
5294: merr_raise (ILLFUN);
5295: return;
5296: }
5297:
5298: if (f == 's') {
5299:
5300: if (tmp[2] == 'y') f = SVNsystem;
5301: if (tmp[2] == 't') f = SVNstack;
5302:
5303: }
5304:
5305: if (f == 'd') {
5306: f = SVNdialect;
5307: }
5308:
5309: if (f == 'e') {
5310:
5311: if (tmp[2] == 'c') f = SVNecode;
5312: if (tmp[2] == 's') f = SVNestack;
5313: if (tmp[2] == 't') f = SVNetrap;
5314:
5315: }
5316:
5317: if (f == 'p' && tmp[2] == 'd') f = SVNpdisplay;
5318:
5319: if (f == 't') {
5320:
5321: if (tmp[2] == 'i') f = SVNtimezone;
5322: if (tmp[2] == 'l') f = SVNtlevel;
5323: if (tmp[2] == 'r') f = SVNtrollback;
5324:
5325: }
5326:
5327: }
5328: else {
5329:
5330: if (find (zsvn, tmp) == FALSE) {
5331: *(--b) = EOL; /* there's a SPace we don't need */
5332: f = ' '; /* user defined svn */
5333: }
5334: else {
5335:
5336: f = tmp[2] - 32;
5337:
5338: if (f == 'T' && tmp[3] == 'r' && (tmp[4] == SP || (stcmp (" ztrap \201", tmp) == 0))) f = ZTRAP;
5339:
5340: if (f == 'M') { /* loadable match */
5341:
5342: if ((f = tmp[3]) >= 'a' && f <= 'z') f -= 32;
5343:
5344: f -= 64;
5345:
5346: }
5347:
5348: if (f == 'U' && tmp[3] == 't') f = SVNzut;
5349:
5350: }
5351: }
5352: }
5353: }
5354:
5355: if (ch != '(') { /* 'special variable' */
5356:
5357: codptr--;
5358:
5359: if (extyp != STRING && extyp != ARGIND && spx == 0) {
5360: return;
5361: }
5362:
5363: if ((argstck[++arg] = a) >= s) {
5364:
5365: char *bak;
5366: bak = partition;
5367:
5368: if (getpmore () == 0) {
5369: merr_raise (STKOV);
5370: return;
5371: }
5372:
5373: a = a - bak + partition;
5374: b = b - bak + partition;
5375:
5376: }
5377:
5378: /************* special variable evaluation ************************************/
5379: switch (f) {
5380:
5381:
5382: /* $ZUUID */
5383: case 'U':
5384:
5385: uuid_v4 (a);
5386: stcnv_c2m (a);
5387:
5388: goto exec;
5389:
5390: #if !defined(__osf__)
5391: case SVNzut:
5392: {
5393: unsigned long long res;
5394:
5395: struct timeval tv;
5396: gettimeofday(&tv, NULL);
5397:
5398: res = tv.tv_sec * 1000000 + tv.tv_usec;
5399:
5400: sprintf (a, "%llu\201", res);
5401:
5402: goto exec;
5403: }
5404: #endif
5405:
5406: /* $JOB */
5407: case 'j':
5408:
5409: lintstr (a, pid);
5410:
5411: goto exec;
5412:
5413:
5414: /* $IO */
5415: case 'i':
5416:
5417: intstr (a, io);
5418: i = stlen (a);
5419: a[i++] = ':';
5420: a[i++] = '"';
5421: i += stcpy (&a[i], dev[io]);
5422: a[i++] = '"';
5423: a[i] = EOL;
5424:
5425: goto exec;
5426:
5427: case SVNdialect:
5428: {
5429: short rb_slot;
5430: rb_slot = rbuf_slot_from_name (rou_name);
5431:
5432: switch (rbuf_flags[rb_slot].dialect) {
5433:
5434: case D_FREEM:
5435: sprintf (a, "FREEM\201");
5436: break;
5437:
5438: case D_MDS:
5439: sprintf (a, "MDS\201");
5440: break;
5441:
5442: case D_M77:
5443: sprintf (a, "M77\201");
5444: break;
5445:
5446: case D_M84:
5447: sprintf (a, "M84\201");
5448: break;
5449:
5450: case D_M90:
5451: sprintf (a, "M90\201");
5452: break;
5453:
5454: case D_M95:
5455: sprintf (a, "M95\201");
5456: break;
5457:
5458: case D_M5:
5459: sprintf (a, "M5\201");
5460: break;
5461: }
5462:
5463: goto exec;
5464:
5465: }
5466:
5467: /* $PDISPLAY */
5468: case SVNpdisplay:
5469:
5470: if (getenv ("DISPLAY") != NULL) {
5471: char *mwapi_display;
5472: char disp_temp[255];
5473:
5474: mwapi_display = getenv ("DISPLAY");
5475: strncpy (disp_temp, mwapi_display, 255);
5476: stcnv_c2m (disp_temp);
5477: stcpy (a, disp_temp);
5478: }
5479: else {
5480: intstr (a, 0);
5481: }
5482: goto exec;
5483:
5484: /* $PRINCIPAL */
5485: case 'p':
5486:
5487: a[0] = '0';
5488: a[1] = ':';
5489: a[2] = '"';
5490: i = 3 + stcpy (&a[3], dev[HOME]);
5491: a[i++] = '"';
5492: a[i] = EOL;
5493:
5494: goto exec;
5495:
5496:
5497: /* $QUIT */
5498: case 'q':
5499:
5500: a[0] = '0' | (nestc[nstx] == '$');
5501:
5502:
5503:
5504: a[1] = EOL;
5505:
5506: goto exec;
5507:
5508:
5509: /* $TEST */
5510: case 't':
5511:
5512: a[0] = '0' | test;
5513: a[1] = EOL;
5514:
5515: goto exec;
5516:
5517:
5518: /* $HOROLOG */
5519: case 'h':
5520:
5521: {
5522:
5523: unsigned long ilong, ilong1;
5524:
5525: ilong1 = time (0L) + tzoffset; /* make $H local time */
5526: ilong = ilong1 / 86400;
5527:
5528: lintstr (a, ilong + 47117);
5529: i = stlen (a);
5530:
5531: a[i++] = ',';
5532: ilong = ilong1 - (ilong * 86400);
5533:
5534: lintstr (&a[i], ilong);
5535:
5536: goto exec;
5537:
5538: }
5539:
5540:
5541: /* $ZHOROLOG() */
5542: case 'H':
5543: {
5544:
5545: unsigned long ilong, ilong1;
5546:
5547: #if defined(USE_GETTIMEOFDAY) && !defined(__osf__)
5548:
5549: struct timeval timebuffer;
5550: gettimeofday (&timebuffer, NULL);
5551:
5552: ilong1 = timebuffer.tv_sec + tzoffset; /* make $ZH local time */
5553:
5554: #else
5555:
5556: struct timeb timebuffer;
5557: ftime (&timebuffer);
5558: ilong1 = timebuffer.time + tzoffset; /* make $ZH local time */
5559:
5560: #endif
5561:
5562: ilong = ilong1 / 86400;
5563: lintstr (a, ilong + 47117);
5564: i = stlen (a);
5565: a[i++] = ',';
5566: ilong = ilong1 - (ilong * 86400);
5567: lintstr (&a[i], ilong);
5568:
5569: #if defined(USE_GETTIMEOFDAY) && !defined(__osf__)
5570: if ((ilong = timebuffer.tv_usec))
5571: #else
5572: if ((ilong = timebuffer.millitm))
5573: #endif
5574: {
5575: char doggie_bag[50];
5576:
1.13 snw 5577: snprintf (doggie_bag, sizeof (doggie_bag) - 1, ".%ld\201", ilong);
1.1 snw 5578: stcat (a, doggie_bag);
5579: }
5580: }
5581: goto exec;
5582:
5583:
5584: case SVNsystem:
5585:
1.13 snw 5586: sprintf (a, "%d,\"%s\"\201", MDC_VENDOR_ID, jour_hostid);
1.1 snw 5587: goto exec;
5588:
5589:
5590: case SVNtimezone:
5591:
5592: lintstr (a, tzoffset);
5593: goto exec;
5594:
5595:
5596: case SVNtlevel:
5597:
1.13 snw 5598: sprintf (a, "%d\201", tp_level);
1.1 snw 5599: goto exec;
5600:
5601:
5602: case SVNtrollback:
5603:
5604: a[0] = '0';
5605: a[1] = EOL;
5606: goto exec;
5607:
5608:
5609: case SVNecode:
5610:
1.12 snw 5611: /* write_m ("in SVNecode\r\n\201"); */
1.1 snw 5612:
5613: if (stlen (user_ecode)) {
5614: stcpy (a, user_ecode);
5615: }
5616: else {
5617: stcpy (a, ecode);
5618: }
5619:
5620: goto exec;
5621:
5622:
5623: case SVNestack:
5624: {
5625: char esbuf[256];
1.13 snw 5626: sprintf (esbuf, "%d\201", estack);
1.1 snw 5627:
5628: stcpy (a, esbuf);
5629: goto exec;
5630:
5631: }
5632:
5633:
5634: case SVNetrap:
1.12 snw 5635: /* write_m ("in SVNetrap\r\n\201"); */
1.1 snw 5636: stcpy (a, etrap);
5637: goto exec;
5638:
5639:
5640: case SVNstack:
5641:
5642: intstr (a, nstx);
5643:
5644: goto exec;
5645:
5646:
5647: /* $KEY */
5648: case 'k':
5649:
5650: stcpy (a, zb);
5651: if (*a >= SP && *a < DEL) *a = EOL;
5652:
5653: goto exec;
5654:
5655:
5656: /* $DEVICE */
5657: case 'd':
5658: if (devstat[io].mdc_err == 0) {
1.13 snw 5659: sprintf (a, "0\201\0");
1.1 snw 5660: }
5661: else {
1.13 snw 5662: sprintf (a, "%d,%d,%s\201\0", devstat[io].mdc_err, devstat[io].frm_err, devstat[io].err_txt);
1.1 snw 5663: }
5664:
5665: goto exec;
5666:
5667: /* $STORAGE */
5668: case 's':
1.13 snw 5669: sprintf (a, "%ld\201", DEFPSIZE);
1.1 snw 5670: goto exec;
5671:
5672: /* $WITH */
5673: case 'w':
5674: stcpy (a, i_with);
5675: goto exec;
5676:
5677: /* $X */
5678: case 'x':
5679:
5680: intstr (a, xpos[io]);
5681: goto exec;
5682:
5683:
5684: /* $Y */
5685: case 'y':
5686:
5687: intstr (a, ypos[io]);
5688: goto exec;
5689:
5690:
5691: /* non-standard special variables */
5692:
5693: /* $ZA - on HOME device dummy, else byte offset to begin of file */
5694: case 'A':
5695: if (io == HOME) {
5696: a[0] = '0';
5697: a[1] = EOL;
5698: }
5699: else {
5700: lintstr (a, ftell (opnfile[io]));
5701: }
5702: goto exec;
5703:
5704:
5705: /* $ZB - last keystroke */
5706: case 'B':
5707: stcpy (a, zb);
5708: goto exec;
5709:
5710:
5711: /* $ZCONTROLC flag */
5712: case 'C':
5713: a[0] = '0' | zcc;
5714: zcc = FALSE;
5715: a[1] = EOL;
5716: goto exec;
5717:
5718:
1.12 snw 5719: /* $ZX (number of columns) */
5720: case 'X':
5721: intstr (a, n_columns);
5722: goto exec;
5723:
5724: /* $ZY (number of rows) */
5725: case 'Y':
5726: intstr (a, n_lines);
5727: goto exec;
1.1 snw 5728:
5729: /* $ZERROR */
5730: case 'E':
5731: stcpy (a, zerror);
5732: goto exec;
5733:
5734:
5735: /* $ZTRAP */
5736: case ZTRAP:
5737:
5738: stcpy (a, ztrap[nstx]);
5739:
5740: goto exec;
5741:
5742:
5743: /* $ZPRECISION */
5744: case 'P':
5745: intstr (a, zprecise);
5746: goto exec;
5747:
5748:
5749: /* $ZSYSTEM */
5750: case 'S':
5751: intstr (a, zsystem);
5752: goto exec;
5753:
5754:
5755: /* $ZVERSION */
5756: case 'V':
5757: stcpy (&a[stcpy (a, "FreeM \201")], FREEM_VERSION_STR);
5758: goto exec;
5759:
5760:
5761: /* $ZNAME */
5762: case 'N':
5763: /*
5764: i = 0;
5765: while ((a[i] = rou_name[i]) != EOL) {
5766: if (rou_name[i] == '.') break;
5767: i++;
5768: }
5769: a[i] = EOL;
5770: */
5771: stcpy (a, rou_name);
5772: goto exec;
5773:
5774:
5775: /* $ZI, INTERRUPT ENABLE/DISABLE */
5776: case 'I':
5777: a[0] = '0' | breakon;
5778: a[1] = EOL;
5779: goto exec;
5780:
5781:
5782: /* $ZDATE */
5783: case 'D':
5784: {
5785: time_t ilong;
5786: struct tm *zdate_time;
5787: char zdf_key[50];
5788: char fmt_string[128];
5789:
1.13 snw 5790: snprintf (zdf_key, sizeof (zdf_key) - 1, "^$JOB\202%d\202ZDATE_FORMAT\201", pid);
1.1 snw 5791: ssvn (get_sym, zdf_key, fmt_string);
5792: stcnv_c2m (fmt_string);
5793:
5794: ilong = time (0L);
5795:
5796: zdate_time = localtime (&ilong);
5797:
5798: strftime (a, 255, fmt_string, zdate_time);
5799: stcnv_c2m (a);
5800: }
5801:
5802: goto exec;
5803:
5804:
5805: /* $ZTIME */
5806: case 'T':
5807: {
5808: time_t ilong;
5809: struct tm *zdate_time;
5810:
5811: ilong = time (0L);
5812:
5813: zdate_time = localtime (&ilong);
5814:
5815: strftime (a, 255, "%X", zdate_time);
5816: stcnv_c2m (a);
5817: }
5818:
5819: goto exec;
5820:
5821:
5822: /* $ZJOB - value of JOB number (of father process) */
5823: case 'J':
5824: if (father) {
5825: lintstr (a, father);
5826: }
5827: else {
5828: stcpy (a, "\201");
5829: }
5830:
5831: goto exec;
5832:
5833:
5834: /* $ZORDER - value of physically next global reference @$ZO(@$ZR) */
5835: case 'O':
5836: global (getnext, tmp, a);
5837:
5838: if (merr () > 0) return;
5839:
5840: goto exec;
5841:
5842:
5843: /* $ZLOCAL - last local reference */
5844: case 'L':
5845: zname (a, zloc);
5846: if (merr () > OK) return;
5847:
5848: goto exec;
5849:
5850:
5851: /* $(Z)REFERENCE - last global reference */
5852: case 'r':
5853: case 'R':
5854: zname (a, zref);
5855: if (merr () > OK) return;
5856:
5857: goto exec;
5858:
5859:
5860: case 'C' - 64:
5861: stcpy (a, zmc);
5862: goto exec; /* loadable match 'controls' */
5863:
5864:
5865: case 'N' - 64:
5866: stcpy (a, zmn);
5867: goto exec; /* loadable match 'numerics' */
5868:
5869:
5870: case 'P' - 64:
5871: stcpy (a, zmp);
5872: goto exec; /* loadable match 'punctuation' */
5873:
5874:
5875: case 'A' - 64:
5876: stcpy (a, zmu);
5877: stcat (a, zml);
5878: goto exec; /* loadable match 'alphabetic' */
5879:
5880:
5881: case 'L' - 64:
5882: stcpy (a, zml);
5883: goto exec; /* loadable match 'lowercase' */
5884:
5885:
5886: case 'U' - 64:
5887: stcpy (a, zmu);
5888: goto exec; /* loadable match 'uppercase' */
5889:
5890:
5891: case 'E' - 64:
5892: for (i = NUL; i <= DEL; i++) a[i] = i;
5893: a[i] = EOL;
5894: goto exec; /* 'loadable' match 'everything' */
5895:
5896:
5897: case ' ': /* user defined special variable */
5898:
5899: udfsvn (get_sym, &tmp[2], a);
5900:
5901: if (ierr <= OK) goto exec;
5902:
5903: merr_raise (OK);
5904:
5905: /* if not found in special variable table, process as extrinsic svn */
5906: /* $$^%Z... all uppercase */
5907:
5908: f = 2;
5909:
5910: while ((ch = tmp[f]) != EOL) {
5911:
5912: if (ch >= 'a' && ch <= 'z') ch -= 32;
5913:
5914: tmp[f++] = ch;
5915:
5916: }
5917:
5918: stcat (tmp, ++codptr);
5919:
5920: code[0] = '$';
5921: code[1] = '^';
5922: code[2] = '%';
5923: code[3] = 'Z';
5924:
5925: stcpy (&code[4], &tmp[2]);
5926:
5927: codptr = code;
5928: f = '$';
5929: zexflag = TRUE;
5930: arg--;
5931:
5932: goto extra_fun;
5933:
5934: default:
5935: merr_raise (ILLFUN);
5936: return;
5937: }
5938: /* end of specialvariable evaluation */
5939: /******************************************************************************/
5940: }
5941: if (++spx >= PARDEPTH) {
5942: merr_raise (STKOV);
5943: return;
5944: }
5945: op_stck[spx] = f;
5946: op_stck[++spx] = '$';
5947:
5948:
5949: text:
5950: if (*(codptr + 1) != '@') {
5951: f = op_stck[spx - 1];
5952: /* f= (spx>0 ? op_stck[spx-1] : 0);
5953: * if (f) */
5954:
5955: switch (f) {
5956: case 't': /* $TEXT is special */
5957:
5958: if ((argstck[++arg] = a) >= s) {
5959: char *bak;
5960:
5961: bak = partition;
5962: if (getpmore () == 0) {
5963: merr_raise (STKOV);
5964: return;
5965: }
5966:
5967: a = a - bak + partition;
5968: b = b - bak + partition;
5969:
5970: }
5971:
5972: i = 0;
5973:
5974: while ((ch = *++codptr) != EOL) {
5975:
5976: if (ch == ')') break;
5977:
5978: if (ch == '+') {
5979:
5980: a[i] = EOL;
5981:
5982: if (++spx > PARDEPTH) {
5983: merr_raise (STKOV);
5984: return;
5985: }
5986:
5987: op_stck[spx] = OPERAND;
5988: goto comma;
5989:
5990: }
5991:
5992: if (ch == '^') {
5993:
5994: a[i] = EOL;
5995:
5996: if (++spx > PARDEPTH) {
5997: merr_raise (STKOV);
5998: return;
5999: }
6000:
6001: op_stck[spx] = OPERAND;
6002: a += i + 1;
6003:
6004: if (i == 0) {
6005: a[0] = '1';
6006: a[1] = EOL;
6007: }
6008: else {
6009: /* just routine name: */
6010: /* return first line */
6011:
6012: a[0] = EOL;
6013:
6014: }
6015:
6016: if ((argstck[++arg] = a) >= s) {
6017: char *bak;
6018:
6019: bak = partition;
6020:
6021: if (getpmore () == 0) {
6022: merr_raise (STKOV);
6023: return;
6024: }
6025:
6026: a = a - bak + partition;
6027: b = b - bak + partition;
6028:
6029: }
6030:
6031: if ((spx + 2) > PARDEPTH) {
6032: merr_raise (STKOV);
6033: return;
6034: }
6035:
6036: op_stck[++spx] = '$';
6037: op_stck[++spx] = OPERAND;
6038:
6039: goto uparrow;
6040: }
6041:
6042: if ((ch < '0' && ch != '%') /* illegal character in $TEXT */
6043: ||ch > 'z' ||
6044: (ch < 'A' && ch > '9') ||
6045: (ch < 'a' && ch > 'Z')) {
6046:
6047: merr_raise (INVREF);
6048: return;
6049:
6050: }
6051:
6052: a[i++] = ch;
6053:
6054: }
6055:
6056: a[i] = EOL;
6057: codptr--;
6058:
6059: goto exec;
6060:
6061: case 'd': /* $data() */
6062: case 'o': /* $order() */
6063: case 'g': /* $get() */
6064: case 'n': /* $next() */
6065: case 'q': /* $query() */
6066: case 'O': /* $zorder() */
6067: case 'N': /* $zname() */
6068: case ZNEXT: /* $znext() */
6069: case ZPREVIOUS: /* $zprevious() */
6070: {
6071:
6072: if ((ch = *++codptr) >= 'A' && ch <= 'Z')
6073: goto scan_name;
6074:
6075: if (ch >= 'a' && ch <= 'z')
6076: goto scan_name;
6077:
6078: if (ch == '%' || ch == '^')
6079: goto scan_name;
6080:
6081: merr_raise (INVEXPR);
6082:
6083: return;
6084: }
6085: }
6086: }
6087:
6088: codptr++;
6089: goto nextchr;
6090:
6091:
6092: case ':':
6093: /* colon: $select or delimiter */
6094: if (spx < 2 || op_stck[spx - 2] != 's') {
6095:
6096: if (op_stck[1] == OPERAND && spx == 1)
6097: return;
6098:
6099: merr_raise (INVEXPR);
6100:
6101: return;
6102:
6103: }
6104:
6105: arg--;
6106: spx--;
6107:
6108: if (tvexpr (a) == FALSE) { /* skip next expr */
6109:
6110: i = 0; /* quote */
6111: j = 0; /* bracket */
6112:
6113: for (;;) {
6114:
6115: ch = *++codptr;
6116:
6117: if (ch == '"') {
6118: toggle (i);
6119: continue;
6120: }
6121:
6122: if (i) {
6123:
6124: if (ch != EOL)
6125: continue;
6126:
6127: merr_raise (QUOTER);
6128: return;
6129:
6130: }
6131:
6132: if (ch == ',' && !j) {
6133: codptr++;
6134: goto nextchr;
6135: }
6136:
6137: if (ch == '(') {
6138: j++;
6139: continue;
6140: }
6141:
6142: if (ch == ')') {
6143:
6144: if (j--)
6145: continue;
6146:
6147: merr_raise (SELER);
6148: return;
6149:
6150: }
6151:
6152: if (ch == EOL) {
6153: merr_raise (SELER);
6154: return;
6155: }
6156:
6157: }
6158: }
6159:
6160: codptr++;
6161: goto nextchr;
6162:
6163: }
6164:
6165: m_operator:
6166:
6167: if (extyp == ARGIND && spx == 1 /* && op_stck[2]!='(' */ )
6168: return;
6169:
6170: f = op_stck[spx];
6171:
6172: if (++spx > PARDEPTH) {
6173: merr_raise (STKOV);
6174: return;
6175: }
6176:
6177:
6178: op10: /* entry for shortcut if first operator */
6179:
6180: /* check for NOT_OPERATOR */
6181: if (ch == NOT) {
6182: if (((ch = *++codptr) == '=' || ch == '<' || ch == '>' || ch == '?' || ch == '&' || ch == '!' || ch == '[' || ch == ']')) {
6183: if (ch == ']' && *(codptr + 1) == ch) {
6184: codptr++;
6185: ch = SORTSAFTER;
6186: if (*(codptr+1)=='=') {
6187: codptr++;
6188: ch=EQSORTS;
6189: }
6190: }
6191: if (ch == ']' && *(codptr + 1) == '=') {
6192: codptr++;
6193: ch = EQFOLLOWS;
6194: }
6195: if (ch == '!' && *(codptr + 1) == ch) {
6196: codptr++;
6197: ch = XOR;
6198: }
6199:
6200: op_stck[spx] = SETBIT (ch);
6201: if (ch == '?')
6202: goto scan_pattern;
6203: /* a+=stlen(a)+1; */
6204: /* djw: does the while loop do the same as the commented out line above? */
6205: /* we should decide yes or no and get rid of the other code... */
6206:
6207: while (*a++ != EOL);
6208:
6209: codptr++;
6210: goto nextchr;
6211:
6212: }
6213: else {
6214: op_stck[spx] = NOT;
6215: goto nextchr;
6216: }
6217: }
6218:
6219: if (ch == '*' && *(codptr + 1) == ch) {
6220: codptr++;
6221: ch = POWER;
6222: }
6223:
6224: if (ch == ']' && *(codptr + 1) == ch) {
6225: codptr++;
6226: ch = SORTSAFTER;
6227: }
6228:
6229: if (ch == '<' && *(codptr + 1) == '=') {
6230: codptr++;
6231: ch = SETBIT ('>');
6232: }
6233:
6234: if (ch == '>' && *(codptr + 1) == '=') {
6235: codptr++;
6236: ch = SETBIT ('<');
6237: }
6238:
6239: if (ch == ']' && *(codptr + 1) == '=') {
6240: codptr++;
6241: ch = EQFOLLOWS;
6242: }
6243:
6244: if (ch == SORTSAFTER && *(codptr + 1) == '=') {
6245: codptr++;
6246: ch = EQSORTS;
6247: }
6248:
6249: if (ch == '$')
6250: ch = MAXOP;
6251:
6252: if (ch == '^') {
6253: codptr--;
6254: return;
6255: }
6256:
6257: if ((op_stck[spx] = ch) != PATTERN) {
6258:
6259: if (f == OPERAND) while (*a++ != EOL); /* binary operator */
6260:
6261: codptr++;
6262: goto nextchr;
6263: }
6264:
6265: scan_pattern:
6266: if ((ch = *++codptr) == INDIRECT) { /* a+=stlen(a)+1; */
6267: while (*a++ != EOL) ;
6268: goto m_operator;
6269: }
6270:
6271: if ((ch > '9' || ch < '0') && (ch != '.')) {
6272: merr_raise (INVEXPR);
6273: return;
6274: }
6275:
6276: tmp[0] = ch;
6277: i = 1;
6278: f = '1'; /* 'previous' character */
6279: j = 0; /* point flag */
6280: group = 0; /* grouped pattern match */
6281:
6282: while ((ch = *++codptr) != EOL) {
6283:
6284: if ((ch >= '0') && (ch <= '9')) {
6285:
6286: tmp[i++] = ch;
6287: f = '1';
6288:
6289: continue;
6290:
6291: }
6292:
6293: if (ch == '.') {
6294:
6295: if (j) {
6296: merr_raise (INVEXPR);
6297: return;
6298: }
6299:
6300: j++;
6301: tmp[i++] = ch;
6302: f = '1';
6303:
6304: continue;
6305: }
6306:
6307: j = 0;
6308: if (ch == NOT) { /* negation of pattern class ? */
6309:
6310: ch = *(codptr + 1);
6311:
6312: if ((ch == '"') || (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z')) {
6313: tmp[i++] = NOT;
6314: }
6315: else {
6316: ch = NOT;
6317: }
6318:
6319: }
6320:
6321: if (ch == '"') {
6322:
6323: if (f != '1' && f != 'A') {
6324: merr_raise (INVEXPR);
6325: return;
6326: }
6327:
6328: for (;;) {
6329:
6330: tmp[i++] = ch;
6331:
6332: if ((ch = *++codptr) == EOL) {
6333: merr_raise (QUOTER);
6334: return;
6335: }
6336:
6337: if (ch == '"') {
6338:
6339: if ((f = *(codptr + 1)) != '"') {
6340: ch = DELIM;
6341: break;
6342: }
6343:
6344: codptr++;
6345: }
6346: }
6347:
6348: tmp[i++] = ch;
6349: f = '"';
6350:
6351: continue;
6352:
6353: }
6354:
6355: if (ch == '(') {
6356:
6357: if (f != '1') {
6358: merr_raise (INVEXPR);
6359: return;
6360: }
6361:
6362: group++;
6363: f = '(';
6364: tmp[i++] = ch;
6365:
6366: continue;
6367:
6368: }
6369:
6370: if (group && (ch == ',' || ch == ')')) {
6371:
6372: if ((f == '1') || (f == '(')) {
6373: merr_raise (INVEXPR);
6374: return;
6375: }
6376:
6377: if (ch == ',') {
6378:
6379: f = '(';
6380: tmp[i++] = ch;
6381:
6382: continue;
6383:
6384: }
6385:
6386: if (ch == ')') {
6387: group--;
6388: tmp[i++] = ch;
6389:
6390: continue;
6391: }
6392:
6393: } /* ??? formatting ??? */
6394:
6395: if (ch >= 'A' && ch <= 'Z') ch += 32; /* lower case conversion */
6396:
6397: if (ch == 'z') { /* loadable match, store as uppercase chars */
6398:
6399: if (standard) {
6400: merr_raise (NOSTAND);
6401: return;
6402: }
6403:
6404: ch = *++codptr;
6405:
6406: if (ch == '"') {
6407:
6408: if (f != '1') {
6409: merr_raise (INVEXPR);
6410: return;
6411: }
6412:
6413: codptr--;
6414: tmp[i++] = 'z';
6415:
6416: continue;
6417:
6418: }
6419:
6420: if (ch == '(') {
6421:
6422: if (f != '1') {
6423: merr_raise (INVEXPR);
6424: return;
6425: }
6426:
6427: codptr--;
6428: continue;
6429: }
6430:
6431: if (ch >= 'A' && ch <= 'Z') ch += 32; /* lower case conversion */
6432:
6433: if (ch != 'e')
6434: j = 1; /* process 'ze' as 'e' */
6435: }
6436:
6437: if (ch != 'c' && ch != 'n' && ch != 'p' && ch != 'a' && ch != 'l' && ch != 'u' && ch != 'e') break;
6438:
6439: if ((f != '1') && (f != 'A')) {
6440: merr_raise (INVEXPR);
6441: return;
6442: }
6443:
6444: if (j) {
6445: ch -= 32;
6446: j = 0;
6447: }
6448:
6449: tmp[i++] = ch;
6450: f = 'A';
6451:
6452: }
6453:
6454: if ((f == '1') || group) {
6455: merr_raise (INVEXPR);
6456: return;
6457: }
6458:
6459: tmp[i] = EOL;
6460:
6461: if ((*a = pattern (a, tmp)) > '1') {
6462: merr_raise (INVEXPR);
6463: return;
6464: }
6465:
6466: if (UNSIGN (op_stck[spx--]) & 0200) toggle (*a);
6467:
6468: *(a + 1) = EOL;
6469:
6470: goto next10;
6471:
6472: /* process values on stack */
6473:
6474:
6475: exec:
6476:
6477: if (spx == 0) {
6478:
6479: if ((ch = *++codptr) == EOL || ch == SP || ch == ',' || ch == ':' || (ch == '^' && (extyp == LABEL || extyp == OFFSET))) return;
6480:
6481: op_stck[++spx] = OPERAND;
6482:
6483: goto next10;
6484:
6485: }
6486:
6487: f = op_stck[spx];
6488:
6489: if (f == ARRAY || f == '(') {
6490:
6491: if (++spx > PARDEPTH) {
6492: merr_raise (STKOV);
6493: return;
6494: }
6495:
6496: op_stck[spx] = OPERAND;
6497: codptr++;
6498:
6499: goto nextchr;
6500:
6501: }
6502:
6503: /* process operators */
6504:
6505: nxt_expr:
6506:
6507: if (f == '$') { /* push 'OPERAND' on stack */
6508:
6509: op_stck[++spx] = OPERAND;
6510: codptr++;
6511:
6512: goto nextchr;
6513:
6514: }
6515:
6516: if (f == OPERAND) {
6517: merr_raise (MISSOP);
6518: return;
6519: }
6520:
6521: if (op_stck[--spx] == OPERAND) { /* binary operators */
6522:
6523: b = a;
6524: a = argstck[--arg];
6525:
6526: switch (f & 0177) { /* binary operators, NOT OMITTED */
6527:
6528: case PLUS:
6529:
6530: stcpy (tmp, b);
6531:
6532: plus01:
6533:
6534: atyp = numlit (a);
6535: btyp = numlit (tmp);
6536:
6537: #ifdef EUR2DEM
6538:
6539: if (atyp != btyp) {
6540:
6541: char tmp2[256];
6542:
6543: if ((atyp == 0) && (a[0] == '0')) atyp = btyp; /* zero is any currency */
6544: if ((btyp == 0) && (tmp[0] == '0')) btyp = atyp; /* zero is any currency */
6545:
6546: if (atyp && btyp) {
6547:
6548: if (atyp > 1) {
6549: stcpy (tmp2, EUR2WHR[atyp]);
6550: mul (tmp, tmp2);
6551: }
6552:
6553: if (btyp > 1) {
6554: zprecise += 4;
6555: stcpy (tmp2, EUR2WHR[btyp]);
6556: mdiv (tmp, tmp2, '/');
6557: zprecise -= 4;
6558: }
6559:
6560: }
6561: else if (atyp != btyp && typemmflag) {
6562: merr_raise (TYPEMISMATCH);
6563: return;
6564: }
6565:
6566: }
6567:
6568: #endif /* EUR2DEM */
6569:
6570: add (a, tmp);
6571: plus02:
6572:
6573: #ifdef EUR2DEM
6574:
6575: if (atyp == 0) goto next05;
6576: if (atyp != btyp) cond_round (a, zprecise + 2);
6577:
6578: stcat (a, WHR[atyp]);
6579:
6580: #endif /* EUR2EUR */
6581:
6582: goto next05;
6583:
6584:
6585: case MINUS:
6586:
6587: tmp[0] = '-';
6588: stcpy (&tmp[1], b);
6589: goto plus01;
6590:
6591:
6592: case MULTIPLY:
6593:
6594: stcpy (tmp, b);
6595: atyp = numlit (a);
6596: btyp = numlit (tmp);
6597: #ifdef EUR2DEM
6598: if (btyp && (atyp == 0)) {
6599: atyp = btyp;
6600: btyp = 0;
6601: }
6602:
6603: if (atyp && btyp) {
6604:
6605: if (typemmflag) {
6606: merr_raise (TYPEMISMATCH);
6607: return;
6608: }
6609:
6610: atyp = btyp = 0;
6611:
6612: }
6613:
6614: #endif /* EUR2DEM */
6615:
6616: mul (a, tmp);
6617:
6618: #ifdef EUR2DEM
6619:
6620: if (atyp == 0) goto next05;
6621:
6622: cond_round (a, zprecise + 2);
6623: stcat (a, WHR[atyp]);
6624:
6625: #endif /* EUR2DEM */
6626:
6627: goto next05;
6628:
6629:
6630: case DIVIDE:
6631: case INTDIVIDE:
6632: case MODULO:
6633:
6634: stcpy (tmp, b);
6635: atyp = numlit (a);
6636: btyp = numlit (tmp);
6637:
6638: #ifdef EUR2DEM
6639: if (atyp != btyp) {
6640: char tmp2[256];
6641:
6642: if (atyp && btyp) {
6643:
6644: if (f == MODULO) {
6645:
6646: if (atyp > 1) {
6647: stcpy (tmp2, EUR2WHR[atyp]);
6648: mul (tmp, tmp2);
6649: }
6650:
6651: if (btyp > 1) {
6652: stcpy (tmp2, EUR2WHR[btyp]);
6653: mdiv (tmp, tmp2, '/');
6654: }
6655:
6656: }
6657: else {
6658:
6659: if (atyp > 1) {
6660: stcpy (tmp2, EUR2WHR[atyp]);
6661: mul (tmp, tmp2);
6662: }
6663:
6664: if (btyp > 1) {
6665: stcpy (tmp2, EUR2WHR[btyp]);
6666: mul (a, tmp2);
6667: }
6668:
6669: atyp = btyp = 0;
6670:
6671: }
6672:
6673: } else if (btyp && typemmflag && (*a != '0' || f == MODULO)) {
6674: merr_raise (TYPEMISMATCH);
6675: return;
6676: }
6677: }
6678: else if (f != MODULO) {
6679: atyp = 0;
6680: }
6681:
6682: #endif /* EUR2DEM */
6683:
6684: if (tmp[0] == '0') {
6685: merr_raise (M9);
6686: return;
6687: }
6688:
6689: if (atyp != btyp) zprecise += 4;
6690:
6691: mdiv (a, tmp, f);
6692:
6693: if (atyp != btyp) zprecise -= 4;
6694:
6695: goto plus02;
6696:
6697:
6698: case CONCATENATE:
6699:
6700: if (stcat (a, b)) goto next05;
6701:
6702: merr_raise (M75);
6703: return;
6704:
6705:
6706: case EQUAL:
6707:
6708: if (stcmp (a, b)) {
6709: *a = '0';
6710: }
6711: else {
6712: *a = '1';
6713: }
6714:
6715: /* common entry point to reverse the logical value */
6716: /* of current expression */
6717:
6718:
6719: notop:
6720: if (f & 0200) toggle (*a); /* NOT_OPERAND */
6721:
6722: a[1] = EOL;
6723:
6724: goto next05;
6725:
6726:
6727: case GREATER:
6728:
6729: stcpy (tmp, b);
6730: atyp = numlit (a);
6731: btyp = numlit (tmp);
6732:
6733: #ifdef EUR2DEM
6734: if (atyp != btyp) {
6735: char tmp2[256];
6736:
6737: if ((atyp == 0) && (a[0] == '0')) atyp = btyp; /* zero is any currency */
6738: if ((btyp == 0) && (tmp[0] == '0')) btyp = atyp; /* zero is any currency */
6739:
6740: if (atyp && btyp) {
6741:
6742: if (atyp > 1) {
6743: stcpy (tmp2, EUR2WHR[atyp]);
6744: mul (tmp, tmp2);
6745: }
6746:
6747: if (btyp > 1) {
6748: stcpy (tmp2, EUR2WHR[btyp]);
6749: mul (a, tmp2);
6750: }
6751:
6752: cond_round (a, zprecise + 2);
6753: cond_round (tmp, zprecise + 2);
6754:
6755: }
6756: else if (atyp != btyp && typemmflag) {
6757: merr_raise (TYPEMISMATCH);
6758: return;
6759: }
6760: }
6761: #endif /* EUR2DEM */
6762:
6763: if (comp (tmp, a)) {
6764: *a = '1';
6765: }
6766: else {
6767: *a = '0';
6768: }
6769:
6770: goto notop;
6771:
6772:
6773: case LESS:
6774:
6775: stcpy (tmp, b);
6776: atyp = numlit (a);
6777: btyp = numlit (tmp);
6778:
6779: #ifdef EUR2DEM
6780: if (atyp != btyp) {
6781: char tmp2[256];
6782:
6783: if ((atyp == 0) && (a[0] == '0')) atyp = btyp; /* zero is any currency */
6784: if ((btyp == 0) && (tmp[0] == '0')) btyp = atyp; /* zero is any currency */
6785:
6786: if (atyp && btyp) {
6787:
6788: if (atyp > 1) {
6789: stcpy (tmp2, EUR2WHR[atyp]);
6790: mul (tmp, tmp2);
6791: }
6792:
6793: if (btyp > 1) {
6794: stcpy (tmp2, EUR2WHR[btyp]);
6795: mul (a, tmp2);
6796: }
6797:
6798: cond_round (a, zprecise + 2);
6799: cond_round (tmp, zprecise + 2);
6800:
6801: }
6802: else if (atyp != btyp && typemmflag) {
6803: merr_raise (TYPEMISMATCH);
6804: return;
6805: }
6806:
6807: }
6808:
6809: #endif /* EUR2DEM */
6810: if (comp (a, tmp)) {
6811: *a = '1';
6812: }
6813: else {
6814: *a = '0';
6815: }
6816:
6817: goto notop;
6818:
6819:
6820: case AND:
6821:
6822: if (tvexpr (a)) {
6823: tvexpr (b);
6824: *a = *b;
6825: }
6826:
6827: goto notop;
6828:
6829:
6830: case OR:
6831:
6832: ch = tvexpr (b); /* beware case of a="" */
6833:
6834: if (tvexpr (a) == FALSE && ch) *a = '1';
6835:
6836: goto notop;
6837:
6838:
6839: case XOR:
6840:
6841: ch = tvexpr (b); /* beware case of a="" */
6842: *a = (tvexpr(a) == ch) ? '0' : '1';
6843:
6844: goto notop;
6845:
6846:
6847: case CONTAINS:
6848:
6849: if (*b == EOL || find (a, b)) {
6850: *a = '1';
6851: }
6852: else {
6853: *a = '0';
6854: }
6855:
6856: goto notop;
6857:
6858:
6859: case EQFOLLOWS:
6860:
6861: if (stcmp (a, b) == 0) {
6862: a[0] = '1';
6863: goto notop;
6864: }
6865:
6866:
6867: case FOLLOWS:
6868:
6869: if (*b == EOL) {
6870:
6871: if (*a == EOL) {
6872: *a = '0';
6873: }
6874: else {
6875: *a = '1';
6876: }
6877:
6878: }
6879: else if (stcmp (a, b) <= 0) { /* frequent special case */
6880: *a = '0';
6881: }
6882: else {
6883: *a = '1';
6884: }
6885:
6886: goto notop;
6887:
6888:
6889: case POWER:
6890:
6891: stcpy (tmp, b);
6892: numlit (a);
6893: numlit (tmp);
6894: power (a, tmp);
6895: goto next05;
6896:
6897:
6898: case EQSORTS:
6899:
6900: if (stcmp (a, b) == 0) {
6901: a[0] = '1';
6902: goto notop;
6903: }
6904:
6905:
6906: case SORTSAFTER:
6907:
6908: if (collate (b, a)) {
6909: *a = '1';
6910: }
6911: else {
6912: *a = '0';
6913: }
6914:
6915: goto notop;
6916:
6917:
6918: case MAXOP:
6919:
6920: #ifdef NOSCRAMBL
6921: if (standard) {
6922: merr_raise (NOSTAND);
6923: return;
6924: }
6925: #endif /* NOSCRAMBL */
6926:
6927: stcpy (tmp, b);
6928: numlit (tmp);
6929: numlit (a);
6930:
6931: if (comp (a, tmp)) stcpy (a, tmp);
6932:
6933: goto next05;
6934:
6935:
6936: case MINOP:
6937:
6938: #ifdef NOSCRAMBL
6939: if (standard) {
6940: merr_raise (NOSTAND);
6941: return;
6942: }
6943: #endif /* NOSCRAMBL */
6944:
6945: stcpy (tmp, b);
6946: numlit (tmp);
6947: numlit (a);
6948:
6949: if (comp (a, tmp) == 0) stcpy (a, tmp);
6950:
6951: goto next05;
6952:
6953:
6954: default:
6955: merr_raise (ILLOP);
6956: return;
6957:
6958: }
6959: } /* end binary operators */
6960:
6961: switch (f) {
6962:
6963: case INDIRECT:
6964:
6965:
6966: indirect:
6967:
6968: if (*++codptr == '@' && *(codptr + 1) == '(') {
6969:
6970: if (a[stlen (a) - 1] == ')') {
6971: codptr += 2;
6972: a[stlen (a) - 1] = ',';
6973: }
6974: else {
6975: codptr++;
6976: }
6977:
6978: }
6979:
6980: stcpy (a + stlen (a), codptr);
6981: stcpy (&code[1], a);
6982: codptr = code;
6983: *codptr = SP;
6984: arg--;
6985:
6986: if (spx <= 0) {
6987: op_stck[0] = 0;
6988: codptr++;
6989:
6990: goto nextchr;
6991: }
6992:
6993: if ((op_stck[spx] & 0177) != PATTERN) goto text;
6994:
6995: a = argstck[arg];
6996: goto scan_pattern;
6997:
6998:
6999: case MINUS: /* unary minus */
7000:
7001: b = a + stlen (a) + 1;
7002:
7003: while (b > a) {
7004: *b = *(b - 1);
7005: b--;
7006: }
7007:
7008: *a = '-';
7009:
7010:
7011: case PLUS: /* unary plus */
7012:
7013: atyp = numlit (a);
7014:
7015: #ifdef EUR2DEM
7016: if (atyp) {
7017: stcat (a, WHR[atyp]);
7018: }
7019: #endif /* EUR2DEM */
7020: goto nxt_operator;
7021:
7022:
7023: case NOT: /* unary not */
7024:
7025: tvexpr (a);
7026: toggle (*a);
7027:
7028: goto nxt_operator;
7029:
7030:
7031: default:
7032: merr_raise (MISSOPD);
7033: return;
7034:
7035: } /* end unary operators */
7036:
7037:
7038: } /* end expr() */
7039:
7040:
7041: /******************************************************************************/
7042: /* $ZSYNTAX */
7043: /* a simple syntax check. */
7044: /* $ZSYNTAX expects one argument. If it finds no fault, it */
7045: /* returns an empty string. Otherwise it returns a pair of */
7046: /* integers separated by a comma. The first number indicates */
7047: /* the position where the error has been found. The second */
7048: /* number returns an error code (same meaning as in $ZE) */
7049: /* only the most frequent errors are searched for: */
7050: /* - illegal commands */
7051: /* - not matching brackets */
7052: /* - not matching quotes */
7053: /* - missing or surplus arguments */
7054: /* - surplus commata */
7055:
7056: void zsyntax(char *a)
7057: {
7058: register int i;
7059: register int j;
7060: register int f;
7061: register int ch;
7062:
7063: char tmp[256];
7064: char *b;
7065: short cmnd;
7066: short forline; /* flag: FOR encountered */
7067:
7068: b = a;
7069: forline = FALSE;
7070: while ((ch = *b) == '.' || ch == SP)
7071: b++; /* level points for blockstr. */
7072: while ((ch = *b++) != EOL) { /* scan command */
7073: if (ch == ';' || ch == '!')
7074: break; /* comment or unix_call */
7075: if (ch >= 'A' && ch <= 'Z')
7076: ch += 32; /* uppercase to lowercase */
7077: f = ch;
7078: cmnd = f;
7079: if (ch < 'b' || ch > 'z' || /* illegal char in cmmd position */
7080: ch == 'm' || ch == 't' || ch == 'y') {
7081: j = CMMND;
7082:
7083:
7084: zserr:
7085:
7086: intstr (a, b - a);
7087: a[i = stlen (a)] = ',';
7088:
7089: merr_num_to_code (j, &a[++i]);
7090: stcnv_c2m (a);
7091:
7092: return;
7093: }
7094: i = 1;
7095: while (((tmp[++i] = ch = *b++) != EOL) && /* check full command name */
7096: ((ch >= 'A' && ch <= 'Z') ||
7097: (ch >= 'a' && ch <= 'z')))
7098: if (ch < 'a')
7099: tmp[i] = ch + 32;
7100: if (f != 'z') {
7101: if (i > 2) {
7102: tmp[0] = SP;
7103: tmp[1] = f;
7104: tmp[i] = SP;
7105: tmp[++i] = EOL;
7106: if (find (
7107: " break close do else for goto hang halt if job kill lock new open quit read set use view write xecute "
7108: ,tmp) == FALSE) {
7109: j = CMMND;
7110: goto zserr;
7111: }
7112: }
7113: }
7114: i = 0; /* quote */
7115: j = 0; /* bracket */
7116: if (ch == ':') { /* scan postcond */
7117: while ((ch = *b++) != EOL) {
7118: if (ch == '*' && *b == ch)
7119: b++; /* exponentiation */
7120: if (ch == '!' && *b == ch)
7121: b++; /* XOR */
7122: if (ch == ']') {
7123: if (*b == ch)
7124: b++; /* SORTSAFTER */
7125: if (*b == '=')
7126: b++; /* EQFOLLOWS or EQSORTS */
7127: }
7128: if (ch == '"') {
7129: toggle (i);
7130: continue;
7131: }
7132: if (i)
7133: continue;
7134: if (ch == SP)
7135: break;
7136: if (ch == '$') {
7137: ch = *b++;
7138: if (ch >= 'A' && ch <= 'Z')
7139: ch += 32;
7140: if ((ch < 'a' || ch > 'z' || ch == 'b' ||
7141: ch == 'm' || ch == 'u' || ch == 'w') && ch != '$') {
7142: j = ILLFUN;
7143: goto zserr;
7144: }
7145: if (ch == 's') { /* $SELECT */
7146: int xch,
7147: xi,
7148: xj;
7149: char *xb;
7150: int sfl;
7151:
7152: xi = 0; /* quotes */
7153: xj = 0; /* brackets */
7154: xb = b; /* do not change old 'b' pointer */
7155: sfl = TRUE; /* first ':' expected */
7156: for (;;)
7157: {
7158: if ((xch = *xb++) == EOL ||
7159: ((xch == SP || xch == ',') && xj == 0)) {
7160: if (xj == 0)
7161: break; /* $STORAGE */
7162: j = SELER;
7163: b = xb;
7164: goto zserr;
7165: }
7166: if (xch == '"') {
7167: toggle (xi);
7168: continue;
7169: }
7170: if (xi)
7171: continue;
7172: if (xch == ':') {
7173: if (xj > 1)
7174: continue;
7175: if (sfl) {
7176: sfl = FALSE;
7177: continue;
7178: }
7179: j = SELER;
7180: b = xb;
7181: goto zserr;
7182: }
7183: if (xch == ',') {
7184: if (xj > 1)
7185: continue;
7186: if (!sfl) {
7187: sfl = TRUE;
7188: continue;
7189: }
7190: j = SELER;
7191: b = xb;
7192: goto zserr;
7193: }
7194: if (xch == '(') {
7195: xj++;
7196: continue;
7197: }
7198: if (xch == ')') {
7199: if ((xj--) > 1)
7200: continue;
7201: if (sfl) {
7202: j = SELER;
7203: b = xb;
7204: goto zserr;
7205: }
7206: break;
7207: }
7208: }
7209: }
7210: /* end select check */
7211: else if (ch == 'd' || /* $DATA */
7212: ch == 'g' || /* $GET */
7213: ch == 'o' || /* $ORDER */
7214: ch == 'n' || /* $NEXT */
7215: ch == 'q' || /* $QUERY */
7216: ch == 'i') { /* $INCREMENT */
7217: int xch,
7218: xi,
7219: xj;
7220: char *xb;
7221:
7222: xb = b; /* do not change old 'b' pointer */
7223: /* skip name */
7224: while (((xch = (*xb)) >= 'A' && xch <= 'Z') ||
7225: (xch >= 'a' && xch <= 'z'))
7226: xb++;
7227: if (xch == '(') {
7228: if ((xch = (*++xb)) == '^' || xch == '%' ||
7229: (xch >= 'A' && xch <= 'Z') ||
7230: (xch >= 'a' && xch <= 'z')) {
7231: xi = xch;
7232: if (xch == '^' && *(xb + 1) == '%')
7233: xb++;
7234: while
7235: (((xch = (*++xb)) >= 'A' && xch <= 'Z') ||
7236: (xch >= 'a' && xch <= 'z') ||
7237: (xch >= '0' && xch <= '9') ||
7238: (xch == '.') ||
7239: (xch == '/' && xi <= '^') ||
7240: (xch == '%' && *(xb - 1) == '/')) ;
7241: } else {
7242: if (xch == '@')
7243: continue;
7244: j = INVEXPR;
7245: b = xb;
7246: goto zserr;
7247: }
7248: xi = 0; /* quotes */
7249: xj = 0; /* brackets */
7250: for (;;)
7251: {
7252: xch = *xb++;
7253: if (xch == '"' && xj) {
7254: toggle (xi);
7255: continue;
7256: }
7257: if (xi && (xch != EOL))
7258: continue;
7259: if (xch == '(') {
7260: xj++;
7261: continue;
7262: }
7263: if (xch == ')') {
7264: if (xj-- > 0)
7265: continue;
7266: break;
7267: }
7268: if (xj && xch != EOL)
7269: continue;
7270: if (xch == ',' &&
7271: (ch == 'g' || ch == 'q' || ch == 'o'))
7272: break;
7273: j = INVEXPR;
7274: b = xb;
7275: goto zserr;
7276: }
7277: }
7278: } /* end data/order/query check */
7279: if (ch == 'e' || /* $EXTRACT */
7280: ch == 'p' || /* $PIECE */
7281: ch == 'a' || /* $ASCII */
7282: ch == 'g' || /* $GET */
7283: ch == 'j' || /* $JUSTIFY */
7284: ch == 'l' || /* $LENGTH */
7285: ch == 'r' || /* $RANDOM/REVERSE */
7286: ch == 't' || /* $TEXT/TRANSLATE */
7287: ch == 'f') { /* $FIND/FNUMBER */
7288: int xch,
7289: xi,
7290: xj,
7291: xa;
7292: char *xb;
7293:
7294: xb = b; /* do not change old 'b' pointer */
7295: /* skip name */
7296: while (((xch = (*xb)) >= 'A' && xch <= 'Z') ||
7297: (xch >= 'a' && xch <= 'z'))
7298: xb++;
7299: if (xch == '(') {
7300: xi = 0; /* quotes */
7301: xj = 0; /* brackets */
7302: xa = 1;
7303: for (;;)
7304: {
7305: xch = (*++xb);
7306: if (xch == EOL)
7307: break;
7308: if (xch == '"') {
7309: toggle (xi);
7310: continue;
7311: }
7312: if (xi)
7313: continue;
7314: if (xch == '(') {
7315: xj++;
7316: continue;
7317: }
7318: if (xch == ')') {
7319: if (xj-- > 0)
7320: continue;
7321: break;
7322: }
7323: if (xj == 0 && xch == ',') {
7324: xa++;
7325: continue;
7326: }
7327: }
7328: if ((ch == 'e' && (xa > 3)) || /* $EXTRACT */
7329: (ch == 'p' && (xa < 2 || xa > 4)) || /* $PIECE */
7330: (ch == 'a' && (xa > 2)) || /* $ASCII */
7331: (ch == 'g' && (xa > 2)) || /* $GET */
7332: (ch == 'j' && (xa < 2 || xa > 3)) || /* $JUSTIFY */
7333: (ch == 'l' && (xa > 2)) || /* $LENGTH */
7334: (ch == 'r' && (xa > 1)) || /* $RANDON/$REVERSE */
7335: (ch == 't' && (xa > 3)) || /* $TEXT/TRANSLATE */
7336: (ch == 'f' && (xa < 2 || xa > 3))) { /* $FIND/FNUMBER */
7337: j = FUNARG;
7338: b = xb;
7339: goto zserr;
7340: }
7341: }
7342: } /* end number of args check */
7343: continue;
7344: }
7345: if (ch == '(') {
7346: j++;
7347: continue;
7348: }
7349: if (ch == ')') {
7350: if (j--)
7351: continue;
7352: break;
7353: }
7354: if (ch == ',') {
7355: if ((ch = *b) == SP || ch == EOL || ch == ',') {
7356: j = ARGLIST;
7357: goto zserr;
7358: }
7359: }
7360: }
7361: if (i)
7362: j = QUOTER;
7363: else if (j)
7364: j = j < 0 ? INVEXPR : BRAER;
7365: if (j == OK && ch != EOL && ch != SP)
7366: j = SPACER;
7367: if (j)
7368: goto zserr;
7369: } /* end postcond */
7370: if (ch == SP)
7371: ch = *b;
7372: else if (ch != EOL) {
7373: j = SPACER;
7374: goto zserr;
7375: }
7376: if ((ch == SP || ch == EOL) && /* never argumentless */
7377: (f == 'j' || f == 'o' || f == 'r' ||
7378: f == 's' || f == 'u' || f == 'x' ||
7379: f == 'g')) {
7380: j = ARGLIST;
7381: goto zserr;
7382: }
7383: /* or.. always argumentless */
7384: if ((ch != SP && ch != EOL) && (f == 'e' || (f == 'q' && forline))) {
7385: j = SPACER;
7386: goto zserr;
7387: }
7388: if (f == 'f')
7389: forline = TRUE;
7390: if (ch == EOL)
7391: break;
7392: /* scan argument */
7393: i = 0; /* quotes */
7394: j = 0; /* brackets */
7395: ch = SP; /* init: previous character */
7396: for (;;) /* scan argument */
7397: {
7398: f = ch; /* f=previous character */
7399: if ((ch = *b++) == EOL)
7400: break;
7401: if (ch == '*' && *b == ch)
7402: b++; /* exponentiation */
7403: if (ch == '!' && *b == ch)
7404: b++; /* XOR */
7405: if (ch == ']') {
7406: if (*b == ch)
7407: b++; /* SORTSAFTER */
7408: if (*b == '=')
7409: b++; /* EQFOLLOWS or EQSORTS */
7410: }
7411: if (ch == '"') {
7412: toggle (i);
7413: continue;
7414: }
7415: if (i)
7416: continue;
7417: if (ch == '$') {
7418: ch = *b++;
7419: if (ch >= 'A' && ch <= 'Z')
7420: ch += 32;
7421: if ((ch < 'a' || ch > 'z' || ch == 'b' ||
7422: ch == 'm' || ch == 'u' || ch == 'w') && ch != '$') {
7423: j = ILLFUN;
7424: goto zserr;
7425: }
7426: if (ch == 's') { /* $SELECT */
7427: int xch,
7428: xi,
7429: xj;
7430: char *xb;
7431: int sfl;
7432:
7433: xi = 0; /* quotes */
7434: xj = 0; /* brackets */
7435: xb = b; /* do not change old 'b' pointer */
7436: sfl = TRUE; /* first ':' expected */
7437: for (;;)
7438: {
7439: if ((xch = *xb++) == EOL ||
7440: ((xch == SP || xch == ',') && xj == 0)) {
7441: if (xj == 0)
7442: break; /* $STORAGE */
7443: j = SELER;
7444: b = xb;
7445: goto zserr;
7446: }
7447: if (xch == '"') {
7448: toggle (xi);
7449: continue;
7450: }
7451: if (xi)
7452: continue;
7453: if (xch == ':') {
7454: if (xj > 1)
7455: continue;
7456: if (sfl) {
7457: sfl = FALSE;
7458: continue;
7459: }
7460: j = SELER;
7461: b = xb;
7462: goto zserr;
7463: }
7464: if (xch == ',') {
7465: if (xj > 1)
7466: continue;
7467: if (!sfl) {
7468: sfl = TRUE;
7469: continue;
7470: }
7471: j = SELER;
7472: b = xb;
7473: goto zserr;
7474: }
7475: if (xch == '(') {
7476: xj++;
7477: continue;
7478: }
7479: if (xch == ')') {
7480: if ((xj--) > 1)
7481: continue;
7482: if (sfl) {
7483: j = SELER;
7484: b = xb;
7485: goto zserr;
7486: }
7487: break;
7488: }
7489: }
7490: }
7491: /* end select check */
7492: else if (ch == 'd' || /* $DATA */
7493: ch == 'g' || /* $GET */
7494: ch == 'o' || /* $ORDER */
7495: ch == 'n' || /* $NEXT */
7496: ch == 'q') { /* $QUERY */
7497: int xch,
7498: xi,
7499: xj;
7500: char *xb;
7501:
7502: xb = b; /* do not change old 'b' pointer */
7503: /* skip name */
7504: while (((xch = (*xb)) >= 'A' && xch <= 'Z') ||
7505: (xch >= 'a' && xch <= 'z'))
7506: xb++;
7507: if (xch == '(') {
7508: if ((xch = (*++xb)) == '^' || xch == '%' ||
7509: (xch >= 'A' && xch <= 'Z') ||
7510: (xch >= 'a' && xch <= 'z')) {
7511: xi = xch;
7512: if (xch == '^' && *(xb + 1) == '%')
7513: xb++;
7514: while
7515: (((xch = (*++xb)) >= 'A' && xch <= 'Z') ||
7516: (xch >= 'a' && xch <= 'z') ||
7517: (xch >= '0' && xch <= '9') ||
7518: (xch == '.') ||
7519: (xch == '/' && xi <= '^') ||
7520: (xch == '%' && *(xb - 1) == '/')) ;
7521:
7522: } else {
7523: if (xch == '@')
7524: continue;
7525: j = INVEXPR;
7526: b = xb;
7527: goto zserr;
7528: }
7529: xi = 0; /* quotes */
7530: xj = 0; /* brackets */
7531: for (;;)
7532: {
7533: xch = *xb++;
7534: if (xch == '"' && xj) {
7535: toggle (xi);
7536: continue;
7537: }
7538: if (xi && (xch != EOL))
7539: continue;
7540: if (xch == '(') {
7541: xj++;
7542: continue;
7543: }
7544: if (xch == ')') {
7545: if (xj-- > 0)
7546: continue;
7547: break;
7548: }
7549: if (xj && xch != EOL)
7550: continue;
7551: if (xch == ',' &&
7552: (ch == 'g' || ch == 'q' || ch == 'o'))
7553: break;
7554: j = INVEXPR;
7555: b = xb;
7556: goto zserr;
7557: }
7558: }
7559: } /* end data/order/query check */
7560: if (ch == 'e' || /* $EXTRACT */
7561: ch == 'p' || /* $PIECE */
7562: ch == 'a' || /* $ASCII */
7563: ch == 'g' || /* $GET */
7564: ch == 'j' || /* $JUSTIFY */
7565: ch == 'l' || /* $LENGTH */
7566: ch == 'r' || /* $RANDON/$REVERSE */
7567: ch == 't' || /* $TEXT/TRANSLATE */
7568: ch == 'f') { /* $FIND/FNUMBER */
7569: int xch,
7570: xi,
7571: xj,
7572: xa;
7573: char *xb;
7574:
7575: xb = b; /* do not change old 'b' pointer */
7576: /* skip name */
7577: while (((xch = (*xb)) >= 'A' && xch <= 'Z') ||
7578: (xch >= 'a' && xch <= 'z'))
7579: xb++;
7580: if (xch == '(') {
7581: xi = 0; /* quotes */
7582: xj = 0; /* brackets */
7583: xa = 1;
7584: for (;;)
7585: {
7586: xch = (*++xb);
7587: if (xch == EOL)
7588: break;
7589: if (xch == '"') {
7590: toggle (xi);
7591: continue;
7592: }
7593: if (xi)
7594: continue;
7595: if (xch == '(') {
7596: xj++;
7597: continue;
7598: }
7599: if (xch == ')') {
7600: if (xj-- > 0)
7601: continue;
7602: break;
7603: }
7604: if (xj == 0 && xch == ',') {
7605: xa++;
7606: continue;
7607: }
7608: }
7609: if ((ch == 'e' && (xa > 3)) || /* $EXTRACT */
7610: (ch == 'p' && (xa < 2 || xa > 4)) || /* $PIECE */
7611: (ch == 'a' && (xa > 2)) || /* $ASCII */
7612: (ch == 'o' && (xa > 2)) || /* $ORDER */
7613: (ch == 'q' && (xa > 2)) || /* $QUERY */
7614: (ch == 'g' && (xa > 2)) || /* $GET */
7615: (ch == 'j' && (xa < 2 || xa > 3)) || /* $JUSTIFY */
7616: (ch == 'l' && (xa > 2)) || /* $LENGTH */
7617: (ch == 't' && (xa > 3)) || /* $TEXT/TRANSLATE */
7618: (ch == 'f' && (xa < 2 || xa > 3))) { /* $FIND/FNUMBER */
7619: j = FUNARG;
7620: b = xb;
7621: goto zserr;
7622: }
7623: }
7624: } /* end number of args check */
7625: continue;
7626: }
7627: if (ch == '(') {
7628: if (f == ')' || f == '"') {
7629: j = ARGLIST;
7630: goto zserr;
7631: }
7632: j++;
7633: continue;
7634: }
7635: if (ch == ')') {
7636: tmp[0] = f;
7637: tmp[1] = EOL;
7638: if (find (" !#&'(*+,-/:<=>?@[\\]_\201", tmp)) {
7639: j = MISSOPD;
7640: goto zserr;
7641: }
7642: if (j--)
7643: continue;
7644: break;
7645: }
7646: if (ch == SP)
7647: break;
7648: tmp[0] = ch;
7649: tmp[1] = EOL;
7650: if (ch == '/' && (cmnd == 'r' || cmnd == 'w') && (f == SP || f == ',')) {
7651: int xch,
7652: xi,
7653: xj;
7654: char *xb;
7655:
7656: xi = 0; /* quotes */
7657: xj = 0; /* brackets */
7658: xb = b; /* do not change old 'b' pointer */
7659: while ((xch = *xb++) != EOL) {
7660: if (xch == '"') {
7661: toggle (xi);
7662: continue;
7663: }
7664: if (xi)
7665: continue;
7666: if (xch == '(') {
7667: xj++;
7668: continue;
7669: }
7670: if (xch == ')') {
7671: if ((xj--) > 1)
7672: continue;
7673: xch = *xb++;
7674: break;
7675: }
7676: if (xj)
7677: continue;
7678: if ((xch < 'A' || xch > 'Z') &&
7679: (xch < '1' || xch > '3'))
7680: break;
7681: }
7682: if (xch != ',' && xch != SP && xch != EOL) {
7683: b = xb;
7684: j = SPACER;
7685: goto zserr;
7686: }
7687: if (--xb == b) {
7688: j = ARGLIST;
7689: goto zserr;
7690: }
7691: }
7692: if (f == '?' && cmnd != 'r' && cmnd != 'w' &&
7693: find ("@1234567890.\201", tmp) == 0) { /* pattern match */
7694: j = MISSOPD;
7695: goto zserr;
7696: }
7697: /* note: write/read may have !?*#/ not as binary op */
7698: if (find ("&<=>[\\]_\201", tmp) || /* binary operator */
7699: (find ("!?*#/\201", tmp) && cmnd != 'r' && cmnd != 'w'))
7700: /* some may be negated */
7701: {
7702: if (find ("#*/\\_\201", tmp) || f != NOT) {
7703: tmp[0] = f;
7704: if (find (" &'(+-<=>[\\]_\201", tmp) ||
7705: (find ("!?*#/\201", tmp) && cmnd != 'r' && cmnd != 'w')) {
7706: j = MISSOPD;
7707: goto zserr;
7708: }
7709: }
7710: continue;
7711: }
7712: if (ch == '+' || ch == '-') {
7713: if (f == NOT) {
7714: j = MISSOPD;
7715: goto zserr;
7716: }
7717: continue;
7718: }
7719: if (ch == ':') {
7720: if (f == ',') {
7721: j = MISSOPD;
7722: goto zserr;
7723: }
7724: continue;
7725: }
7726: if (ch == '`' || ch == ';' || ch == '{' || ch == '|' ||
7727: ch == '}' || ch == '~') { /* illegal characters */
7728: j = ILLOP;
7729: goto zserr;
7730: }
7731: if (ch == '$') { /* check function */
7732: if (((f = *b | 0140) < 'a' || f > 'z') && f != '$') {
7733: j = ILLFUN;
7734: goto zserr;
7735: }
7736: continue;
7737: }
7738: if (ch == ',') { /* comma is a delimiter! */
7739: if (*(b - 2) == SP || (f = *b) == SP || f == EOL || f == ',') {
7740: j = ARGLIST;
7741: goto zserr;
7742: }
7743: }
7744: }
7745: if (i)
7746: j = QUOTER;
7747: else if (j)
7748: j = j > 0 ? INVEXPR : BRAER;
7749: if (j)
7750: goto zserr;
7751: if (ch == EOL)
7752: break;
7753: /* skip spaces before next command */
7754: while (ch == SP || ch == TAB)
7755: ch = *b++;
7756: b--;
7757: }
7758: *a = EOL; /* no error found */
7759: return;
7760: } /* end zsyntax() */
7761:
7762: time_t horolog_to_unix (char *horo)
7763: {
7764:
7765: char *ptr = horo;
7766: register char ch;
7767: register short i;
7768:
7769: char horo_days[10];
7770: char horo_seconds[10];
7771:
7772: time_t seconds;
7773:
7774: i = 0;
7775:
7776: while ((ch = *(ptr++)) != ',') {
7777: horo_days[i++] = ch;
7778: }
7779: horo_days[i] = '\0';
7780:
7781: i = 0;
7782: while ((ch = *(ptr++)) != EOL) {
7783: horo_seconds[i++] = ch;
7784: }
7785: horo_seconds[i] = '\0';
7786:
7787: seconds = (((atol (horo_days) - 47117L) * 86400L) + 43200 + atol (horo_seconds) + tzoffset);
7788:
7789: return (time_t) seconds;
7790:
7791: }
7792:
7793:
7794: /* a = result string
7795: * type = type of transform
7796: */
7797: void zkey (char *a, long type)
7798: {
7799:
7800: char del0;
7801: char del1;
7802: char del2;
7803: char del3;
7804: char del4;
7805:
7806: int f;
7807: char prod_rule[256];
7808: int i;
7809: int ncs; /* flag: non_collating_substring */
7810:
7811: if (type == 0) type = (-v93); /* zero is reverse of default type */
7812: if ((f = (type < 0))) type = (-type);
7813:
7814: if (type-- > NO_V93) {
7815: merr_raise (ARGER);
7816: return;
7817: }
7818:
7819: del2 = v93a[type][0]; /* delimiter between primary/seconary key */
7820: del0 = v93a[type][1]; /* delimiter between 'from' and 'to' substring */
7821: del3 = '('; /* introducer for 'non-collating' substrings */
7822: del4 = ')'; /* terminator for 'non-collating' substring */
7823: ncs = FALSE; /* non_collating_substring flag */
7824:
7825: if (del0 == EOL) return; /* no rule under of this type */
7826:
7827: del1 = v93a[type][2]; /* delimiter between different from/to pairs */
7828: /* production rule, stripped from delimiter declaration */
7829: /* with an added separator character at both ends */
7830:
7831: i = stcpy (prod_rule, &v93a[type][2]);
7832: prod_rule[i] = del1;
7833: prod_rule[++i] = EOL;
7834:
7835: if (f) goto backw; /* negative is backward transform */
7836:
7837: /* forward transform */
7838: i = stlen (a);
7839:
7840: if (i == 0) return; /* string empty - nothing to do */
7841:
7842: {
7843: char ct0[256];
7844: char ct1[256];
7845: int ch = 0;
7846: int d = 0;
7847: int i1 = 0;
7848: int j = 0;
7849: int n0 = 0;
7850: int n1 = 0;
7851: int pos = 0;
7852: char c;
7853:
7854: i = 0;
7855: n0 = 0;
7856: n1 = 0;
7857:
7858: while ((c = a[i]) != EOL) { /* non-collating substring? */
7859:
7860: if (c == del3) { /* introducer valid only with matching terminator! */
7861:
7862: j = i;
7863:
7864: while ((ch = a[++j]) != EOL) {
7865: if (ch == del4) break;
7866: }
7867:
7868: if (ch == del4) {
7869:
7870: while (i <= j) ct1[n1++] = a[i++];
7871: continue;
7872:
7873: }
7874:
7875: }
7876:
7877: j = 0;
7878: d = 0;
7879:
7880: /* search for longest matching string */
7881: while ((ch = prod_rule[j++]) != EOL) {
7882:
7883: if (ch == del1) {
7884:
7885: if (prod_rule[j] != c) continue;
7886:
7887: i1 = i;
7888:
7889: while ((ch = prod_rule[j++]) != del0 && ch == a[i1++]) ;
7890:
7891: if (ch != del0) continue;
7892:
7893: if ((ch = i1 - i) > d) {
7894: d = ch;
7895: pos = j;
7896: }
7897:
7898: }
7899:
7900: }
7901:
7902: if (n0 > STRLEN) {
7903: merr_raise (M75);
7904: return;
7905: } /* string too long */
7906:
7907: if (d == 0) {
7908:
7909: ct0[n0++] = c;
7910: ct1[n1++] = '0';
7911: i++;
7912:
7913: continue;
7914:
7915: }
7916:
7917: j = 0;
7918: c = prod_rule[pos];
7919: ch = '0';
7920:
7921: if (c == del1) {
7922:
7923: ct1[n1++] = ' ';
7924:
7925: while (j <= pos) {
7926:
7927: if (prod_rule[j] == del0) ch++;
7928:
7929: j++;
7930:
7931: }
7932:
7933: }
7934: else {
7935:
7936: while (j <= pos) {
7937:
7938: if (prod_rule[j] == del0 && prod_rule[j + 1] == c) ch++;
7939:
7940: j++;
7941:
7942: }
7943:
7944: }
7945:
7946: j = 0;
7947: i += d;
7948: ct1[n1++] = ch;
7949:
7950: while ((ct0[n0++] = prod_rule[pos++]) != del1) {
7951:
7952: if (n1 > STRLEN) {
7953: merr_raise (M75);
7954: return;
7955: } /* string too long */
7956:
7957: }
7958:
7959: n0--;
7960:
7961: }
7962:
7963: ct0[n0++] = del2;
7964: ct0[n0] = EOL;
7965: ct1[n1] = EOL;
7966:
7967: /* purge trailing zeroes */
7968: while (ct1[--n1] == '0') {
7969:
7970: ct1[n1] = EOL;
7971:
7972: if (n1 == 0) {
7973: n0--;
7974: break;
7975: }
7976:
7977: }
7978:
7979: if (n0 + n1 > STRLEN) {
7980: merr_raise (M75);
7981: return;
7982: } /* string too long */
7983:
7984: stcpy (a, ct0);
7985: stcpy (&a[n0], ct1);
7986:
7987: }
7988:
7989: return;
7990:
7991:
7992: /* backward transform */
7993: backw:
7994:
7995: i = stlen (a);
7996:
7997: if (i == 0) return; /* string empty */
7998:
7999: {
8000: int c;
8001: int ch;
8002: int d;
8003: int n0;
8004: int n1;
8005: int n2;
8006: int j;
8007: char z[256];
8008:
8009: stcpy (z, a);
8010: n0 = 0;
8011: n1 = 0;
8012: n2 = 0;
8013:
8014: while ((d = z[n1++]) != EOL && (d != del2)) ;
8015:
8016: if (d == EOL) return; /* nothing to change */
8017:
8018: for (;;) {
8019:
8020: c = z[n0];
8021: d = z[n1];
8022:
8023: if (c == del2 && d == EOL) break;
8024:
8025: if (d == EOL) {
8026: d = '0';
8027: }
8028: else {
8029: n1++;
8030: }
8031:
8032:
8033: if (d == del3) {
8034:
8035: a[n2++] = d;
8036: ncs = TRUE;
8037:
8038: continue;
8039:
8040: }
8041:
8042: if (ncs) {
8043:
8044: a[n2++] = d;
8045:
8046: if (d == del4) ncs = FALSE;
8047:
8048: continue;
8049:
8050: }
8051:
8052: if (d == ' ') { /* replacement with no chars */
8053:
8054: d = z[n1++] - '0';
8055: j = 1;
8056:
8057: while ((ch = prod_rule[j++]) != EOL) {
8058: if (ch == del0 && (--d) == 0) break;
8059: }
8060:
8061: }
8062: else {
8063:
8064: if ((d -= '0') == 0) {
8065:
8066: a[n2++] = c;
8067: n0++;
8068:
8069: continue;
8070:
8071: }
8072:
8073: j = 1;
8074:
8075: while ((ch = prod_rule[j++]) != EOL) {
8076: if (ch == del0 && prod_rule[j] == c && (--d) == 0) break;
8077: }
8078:
8079: }
8080:
8081: d = j;
8082:
8083: while ((ch = prod_rule[j++]) != EOL) {
8084:
8085: if (ch == del1) break;
8086:
8087: n0++;
8088:
8089: }
8090:
8091: d--;
8092:
8093: while (prod_rule[d--] != del1) ;
8094:
8095: if (prod_rule[d + 2] == EOL) {
8096: merr_raise (ARGER);
8097: return;
8098: } /* string is not of proper format */
8099:
8100: d++;
8101:
8102: while ((ch = prod_rule[++d]) != del0) a[n2++] = ch;
8103:
8104: }
8105:
8106: a[n2] = EOL;
8107:
8108: }
8109:
8110: return;
8111: } /* end zkey() */
8112:
8113: int levenshtein (char *word1, char *word2)
8114: {
8115: int l1 = 0;
8116: int l2 = 0;
8117: int i = 0;
8118: int j = 0;
8119: int m = 0;
8120: int t = 0;
8121: int x = 0;
8122: char d[2][256];
8123:
8124: l1 = stlen (word1);
8125: word1--;
8126:
8127: l2 = stlen (word2);
8128: word2--;
8129:
8130: if (l1 == 0) return (l2);
8131: if (l2 == 0) return (l1);
8132:
8133: t = 0;
8134:
8135: for (i = 0; i <= l1; i++) d[0][i] = i;
8136:
8137: for (j = 1; j <= l2; j++) {
8138:
8139: t ^= 1;
8140: d[t][0] = j;
8141:
8142: for (i = 1; i <= l1; i++) {
8143:
8144: m = d[t ^ 1][i - 1];
8145: if (word1[i] != word2[j]) m++;
8146:
8147: x = d[t ^ 1][i];
8148: if (++x < m) m = x;
8149:
8150: x = d[t][i - 1];
8151: if (++x < m) m = x;
8152:
8153: d[t][i] = m;
8154:
8155: }
8156:
8157: }
8158:
8159: return (m);
8160: }
8161:
8162: /* conditional rounding */
8163: /* 'a' is assumed to be a 'canonic' numeric string */
8164: /* it is rounded to 'digits' fractional digits provided that */
8165: /* the canonic result has at most (digits-2) frac.digits */
8166: void cond_round (char *a, int digits)
8167: {
8168: int ch;
8169: int i;
8170: int point;
8171: int lena;
8172:
8173: point = -1;
8174:
8175: i = 0;
8176: i = 0;
8177:
8178: while (a[i] != EOL) {
8179:
8180: if (a[i] == '.') point = i;
8181: i++;
8182:
8183: }
8184:
8185: lena = i;
8186:
8187: if (point < 0) point = i;
8188: if ((point + digits + 1) >= i) return; /* nothing to round */
8189:
8190: i = point + digits + 1;
8191:
8192: if (a[i] < '5') {
8193:
8194: if ((a[i - 1] != '0') || (a[i - 2] != '0')) return; /* condition! */
8195:
8196: a[i] = EOL;
8197:
8198: while (a[--i] == '0') a[i] = EOL;
8199:
8200: if (a[i] == '.') {
8201:
8202: a[i] = EOL;
8203:
8204: if (i == 0 || (i == 1 && a[0] == '-')) a[0] = '0';
8205:
8206: }
8207:
8208: return;
8209:
8210: }
8211:
8212: if (a[i - 1] != '9' || a[i - 2] != '9') return; /* condition */
8213:
8214: for (;;) {
8215:
8216: if (i >= point) {
8217: a[i] = EOL;
8218: }
8219: else {
8220: a[i] = '0';
8221: }
8222:
8223: if (--i < (a[0] == '-')) {
8224:
8225: for (i = lena; i >= 0; i--) a[i + 1] = a[i];
8226:
8227: a[a[0] == '-'] = '1';
8228:
8229: break;
8230:
8231: }
8232:
8233: if ((ch = a[i]) == '.') continue;
8234:
8235: if (a[i] < '9' && ch >= '0') {
8236: a[i] = ++ch;
8237: break;
8238: }
8239:
8240: }
8241:
8242: return;
8243:
8244: } /* end cond_round */
8245:
8246: short is_horolog(char *s)
8247: {
8248:
8249: register int i;
8250: char ch;
8251: int commata = 0;
8252: int digits = 0;
8253:
8254: if (!isdigit (s[0])) return FALSE;
8255:
8256: for (i = 0; i < stlen (s); i++) {
8257:
8258: ch = s[i];
8259:
8260: if (isdigit (ch)) {
8261: digits++;
8262: }
8263: else if (ch == ',' && commata == 0) {
8264: commata++;
8265: }
8266: else if (ch == ',' && commata > 0) {
8267: return FALSE;
8268: }
8269: else {
8270: return FALSE;
8271: }
8272:
8273: }
8274:
8275: if (commata != 1) {
8276: return FALSE;
8277: }
8278: else {
8279: return TRUE;
8280: }
8281:
8282: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to expr.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / src