1: /*
2: * $Id: routine.c,v 1.11 2025/05/06 15:18:55 snw Exp $
3: * Routine buffer management
4: *
5: *
6: * Author: Serena Willis <snw@coherent-logic.com>
7: * Copyright (C) 1998 MUG Deutschland
8: * Copyright (C) 2023, 2025 Coherent Logic Development LLC
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: *
26: * $Log: routine.c,v $
27: * Revision 1.11 2025/05/06 15:18:55 snw
28: * Remove isblank call from routine.c to fix broken Solaris 8 build
29: *
30: * Revision 1.10 2025/05/01 03:56:29 snw
31: * -m
32: *
33: * Revision 1.9 2025/04/30 20:03:09 snw
34: * Work on entryref parser
35: *
36: * Revision 1.8 2025/04/30 17:19:16 snw
37: * Improve backtraces in debugger
38: *
39: * Revision 1.7 2025/04/30 14:41:03 snw
40: * Further debugger work
41: *
42: * Revision 1.6 2025/04/13 04:22:43 snw
43: * Fix snprintf calls
44: *
45: * Revision 1.5 2025/04/09 19:52:02 snw
46: * Eliminate as many warnings as possible while building with -Wall
47: *
48: * Revision 1.4 2025/03/27 03:27:35 snw
49: * Install init scripts to share/freem/examples/init and fix regression in method dispatch
50: *
51: * Revision 1.3 2025/03/09 19:50:47 snw
52: * Second phase of REUSE compliance and header reformat
53: *
54: *
55: * SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
56: * SPDX-License-Identifier: AGPL-3.0-or-later
57: **/
58:
59: #include <string.h>
60: #include <errno.h>
61: #include <sys/types.h>
62:
63: #if !defined(__OpenBSD__) && !defined(__FreeBSD__)
64: # include <sys/timeb.h>
65: #endif
66:
67: #include <sys/ioctl.h>
68: #include <unistd.h>
69: #include <stdlib.h>
70: #include <ctype.h>
71:
72: #ifdef AMIGA68K
73: #include <sys/fcntl.h>
74: #endif
75:
76: #include "mpsdef.h"
77:
78: #include <time.h>
79:
80: #ifdef USE_SYS_TIME_H
81: #include <sys/time.h>
82: #endif
83:
84: #include "events.h"
85:
86: short rtn_get_offset(char *buf)
87: {
88: char *rp;
89: char *rc;
90: char *p;
91: char otag[256];
92: char ortn[256];
93: char oline[256];
94:
95: register int i = 0;
96: register int j = 0;
97: register int k = 0;
98:
99: int os = 0;
100:
101: stcpy (ortn, rou_name);
102:
103: rp = rouptr;
104: rc = roucur;
105:
106: stcnv_m2c (ortn);
107:
108: while (rp < rc) {
109:
110: i = 0;
111: for (p = rp + 1; p < rc && *p != EOL && *p != '\0'; p++) {
112: if (i < 256) {
113: oline[i++] = *p;
114: }
115: }
116: oline[i] = '\0';
117:
118: if (isalpha (oline[0]) || oline[0] == '%') {
119:
120: os = 0;
121: k = 0;
122:
123: for (j = 0; j < strlen (oline); j++) {
124:
125: switch (oline[j]) {
126:
127: case ' ':
128: case '(':
129: case ';':
130: case EOL:
131: otag[k] = '\0';
132:
133: break;
134:
135: default:
136: otag[k++] = oline[j];
137: }
138:
139: if (oline[j] == ' ' || oline[j] == '(' || oline[j] == ';' || oline[j] == EOL) break;
140: }
141: }
142: else {
143: os++;
144: }
145:
146: rp = p + 1;
147: }
148:
149: if (os) {
150: sprintf (buf, "%s+%d^%s\201", otag, os, ortn);
151: }
152: else {
153: sprintf (buf, "%s^%s\201", otag, ortn);
154: }
155:
156:
157: return TRUE;
158: }
159:
160: char *rtn_resolve(char *rou, char *tag, char *buf)
161: {
162: char superclass[255];
163:
164: if (rtn_has_tag (rou, tag)) {
165: strcpy (buf, rou);
166: return buf;
167: }
168: else {
169: if (rtn_get_superclass (rou, superclass)) {
170: return rtn_resolve (superclass, tag, buf);
171: }
172: else {
173: buf = NULL;
174: return NULL;
175: }
176: }
177:
178: }
179:
180: short rtn_get_superclass(char *rou, char *buf)
181: {
182: FILE *fp;
183: char pth[PATHLEN];
184: char line[255];
185: char *s;
186: short rtn_exists;
187: short after_parens;
188: short found_super;
189: char *p;
190: register char ch;
191:
192: if (strcmp (rou, "%OBJECT") == 0) {
193: buf = NULL;
194: return FALSE;
195: }
196:
197: rtn_exists = rtn_get_path (rou, pth);
198:
199: if (rtn_exists == FALSE) {
200: buf = NULL;
201: return FALSE;
202: }
203:
204: fp = fopen (pth, "r");
205: if (fp == NULL) {
206: buf = NULL;
207: return FALSE;
208: }
209:
210: s = fgets (line, 255, fp);
211:
212: fclose (fp);
213:
214: if (s == NULL) {
215: buf = NULL;
216: return FALSE;
217: }
218:
219: if ((!isalpha (line[0])) && (line[0] != '%')) {
220: buf = NULL;
221: return FALSE;
222: }
223:
224: p = line;
225: after_parens = FALSE;
226: found_super = FALSE;
227:
228: while ((ch = *p++) != '\0') {
229:
230: if (ch == ')') after_parens = TRUE;
231:
232: /* ignore comments in search for superclass */
233: if (ch == ';' && after_parens == TRUE) {
234: found_super = FALSE;
235: break;
236: }
237:
238: if (ch == ':' && after_parens == TRUE) {
239: strcpy (buf, p);
240: found_super = TRUE;
241: break;
242: }
243:
244: }
245:
246: if (!found_super) {
247: sprintf (buf, "%%OBJECT");
248: return TRUE;
249: }
250:
251: p = buf;
252: for (;;) {
253: ch = *p;
254:
255: if (ch == SP || ch == TAB || ch == ';' || ch == '\0' || ch == '\r' || ch == '\n') {
256: *p = '\0';
257: break;
258: }
259:
260: p++;
261: }
262:
263: return TRUE;
264: }
265:
266: short rtn_get_path(char *rou, char *buf)
267: {
268: FILE *fp;
269: char pth[PATHLEN];
270:
271: if (rou[0] == '%') {
272: stcpy (pth, rou0plib);
273: stcnv_m2c (pth);
274: }
275: else {
276: stcpy (pth, rou0path);
277: stcnv_m2c (pth);
278: }
279:
280: snprintf (buf, PATHLEN - 1, "%s/%s.m", pth, rou);
281:
282: if ((fp = fopen (buf, "r")) != NULL) {
283: (void) fclose (fp);
284:
285: return TRUE;
286: }
287: else {
288: return FALSE;
289: }
290:
291: }
292:
293: short rtn_has_tag(char *rou, char *tag)
294: {
295: m_entry *entries;
296: m_entry *e;
297:
298: entries = rtn_get_entries (rou);
299:
300: for (e = entries; e != NULL; e = e->next) {
301: if (strcmp (tag, e->tag) == 0) {
302: rtn_free_entries (entries);
303: return TRUE;
304: }
305: }
306:
307: rtn_free_entries (entries);
308: return FALSE;
309: }
310:
311: void rtn_free_entries(m_entry *head)
312: {
313: m_entry *tmp;
314:
315: while (head != NULL) {
316: tmp = head;
317: head = head->next;
318: free (tmp);
319: }
320:
321: head = NULL;
322: }
323:
324: m_entry *rtn_get_entries(char *rou)
325: {
326: FILE *fp;
327: char rou_path[PATHLEN];
328: m_entry *head = NULL;
329: m_entry *t;
330: register char ch;
331: register int i = 0;
332: register int j = 0;
333: char cur_line[255];
334: char cur_label[255];
335: int has_args = 0;
336: char *paren_pos;
337:
338: if (rtn_get_path (rou, rou_path) == FALSE) {
339: return (m_entry *) NULL;
340: }
341:
342: fp = fopen (rou_path, "r");
343:
344: while (fgets (cur_line, 255, fp) != NULL) {
345:
346: if (isalpha (cur_line[0]) || cur_line[0] == '%') {
347: has_args = 0;
348: j = 0;
349:
350: for (i = 0; i < strlen (cur_line); i++) {
351: ch = cur_line[i];
352:
353: switch (ch) {
354:
355: case ')':
356: cur_label[j++] = ')';
357:
358: case SP:
359: case TAB:
360: case EOL:
361: cur_label[j] = '\0';
362: j = 0;
363: if (strlen (cur_label)) {
364: t = (m_entry *) malloc (sizeof (m_entry));
365: NULLPTRCHK(t,"rtn_get_entries");
366:
367: paren_pos = strchr (cur_label, '(');
368: if (paren_pos == NULL) {
369: /* not a formallist */
370: t->tag = (char *) malloc (sizeof (char) * (strlen (cur_label) + 1));
371: NULLPTRCHK(t->tag,"rtn_get_entries");
372:
373: strcpy (t->tag, cur_label);
374: }
375: else {
376: /* a formallist */
377: char *toktmp;
378:
379: toktmp = strdup (cur_label);
380: NULLPTRCHK(toktmp,"rtn_get_entries");
381:
382: (void) strtok (toktmp, "(");
383:
384: t->tag = malloc (sizeof (char) * (strlen (toktmp) + 1));
385: NULLPTRCHK(t->tag,"rtn_get_entries");
386:
387: strcpy (t->tag, toktmp);
388:
389: free (toktmp);
390: }
391:
392: t->next = head;
393: head = t;
394: }
395: break;
396:
397: case '(':
398: has_args++;
399: default:
400: cur_label[j++] = ch;
401: }
402:
403: if (ch == SP || ch == TAB || ch == EOL) break;
404: }
405: }
406: }
407:
408: fclose (fp);
409: return head;
410:
411: }
412:
413: void zload (char *rou) /* load routine in buffer */
414: {
415: FILE *infile;
416: short linelen;
417: char pgm[256];
418: char tmp1[256];
419:
420: register long int i;
421: register long int j;
422: register long int ch;
423:
424: char *savptr; /* save routine pointer */
425: long timex;
426: short altern = 0;
427:
428: /* Routines are stored in routine buffers. If a routine is called
429: * we first look whether it's already loaded. If not, we look for
430: * the least recently used buffer and load it there. Besides
431: * dramatically improved performance there is little effect on
432: * the user. Sometimes you see an effect: if the program is changed
433: * by some other user or by yourself using the 'ced' editor you
434: * may get the old version for some time with DO, GOTO or ZLOAD.
435: * A ZREMOVE makes sure the routine is loaded from disk.
436: */
437: if (*rou == EOL || *rou == 0) { /* routine name empty */
438:
439: pgms[0][0] = EOL;
440: rouend = rouins = rouptr = buff;
441: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
442:
443: *rouptr = EOL;
444: *(rouptr + 1) = EOL;
445: *(rouptr + 2) = EOL;
446:
447: dosave[0] = 0;
448:
449: return;
450:
451: }
452:
453: savptr = rouptr;
454:
455: /* what time is it ? */
456: timex = time (0L);
457:
458: /* FreeM: it takes a lickin' and keeps on tickin' */
459:
460: /* let's have a look whether we already have the stuff */
461: for (i = 0; i < NO_OF_RBUF; i++) {
462:
463: if (pgms[i][0] == 0) {
464: altern = i;
465: break;
466: } /* buffer empty */
467:
468: j = 0;
469:
470: while (rou[j] == pgms[i][j]) {
471:
472: if (rou[j++] == EOL) {
473:
474: rouptr = buff + (i * PSIZE0);
475: ages[i] = time (0L);
476: rouend = ends[i];
477: rouins = rouend - 1;
478:
479: return;
480:
481: }
482:
483: }
484:
485: if (ages[i] <= timex) timex = ages[altern = i];
486:
487: }
488:
489: /* clear DO-label stored under FOR */
490: dosave[0] = 0;
491: j = 0;
492: ch = EOL; /* init for multiple path search */
493: tmp1[0] = EOL;
494:
495:
496: nextpath: /* entry point for retry */
497:
498: i = 0;
499:
500: if (rou[0] == '%') { /* %_routines are in special directory */
501:
502: if (mcmnd >= 'a') { /* DO GOTO JOB */
503:
504: if (rou0plib[j] != EOL) {
505: while ((ch = pgm[i++] = rou0plib[j++]) != ':' && ch != EOL);
506: }
507:
508: }
509: else if (rou1plib[j] != EOL) {
510: while ((ch = pgm[i++] = rou1plib[j++]) != ':' && ch != EOL);
511: }
512:
513: }
514: else {
515:
516: if (mcmnd >= 'a') { /* DO GOTO JOB */
517:
518: if (rou0path[j] != EOL) {
519: while ((ch = pgm[i++] = rou0path[j++]) != ':' && ch != EOL);
520: }
521:
522: }
523: else if (rou1path[j] != EOL) {
524: while ((ch = pgm[i++] = rou1path[j++]) != ':' && ch != EOL);
525: }
526:
527: }
528:
529: if (i > 0) {
530:
531: if (i == 1 || (i == 2 && pgm[0] == '.')) {
532: i = 0;
533: }
534: else {
535: pgm[i - 1] = '/';
536: }
537:
538: }
539:
540: pgm[i] = EOL;
541:
542: stcpy (tmp1, pgm); /* directory where we search for the routine */
543: stcpy (&pgm[i], rou);
544:
545: rouptr = buff + (altern * PSIZE0);
546:
547: stcat (pgm, rou_ext);
548:
549: pgm[stlen (pgm)] = NUL; /* append routine extension */
550:
551: if ((infile = fopen (pgm, "r")) == NULL) {
552:
553: rouptr = savptr;
554:
555: if (ch != EOL) goto nextpath; /* try next access path */
556:
557: stcpy (varerr, rou);
558:
559: merr_raise (NOPGM);
560:
561: return;
562:
563: }
564:
565: again:
566:
567: linelen = 0;
568: savptr = rouend = rouptr;
569:
570: for (i = 1; i < (PSIZE0 - 1); i++) {
571:
572: *++rouend = ch = getc (infile);
573:
574: if (ch == LF || ch == EOF) {
575:
576: *rouend++ = EOL;
577: i++;
578: *savptr = i - linelen - 2;
579:
580: savptr = rouend;
581: linelen = i;
582:
583: if (ch == EOF) {
584:
585: fclose (infile);
586:
587: *rouend-- = EOL;
588: rouins = rouend - 1;
589: ends[altern] = rouend;
590: ages[altern] = time (0L);
591:
592: stcpy (pgms[altern], rou);
593: stcpy (path[altern], tmp1);
594:
595: rbuf_flags[altern].dialect = standard;
596: if (standard == D_FREEM) {
597: rbuf_flags[altern].standard = FALSE;
598: }
599: else {
600: rbuf_flags[altern].standard = TRUE;
601: }
602:
603: return;
604: }
605: }
606: }
607:
608: rouptr = savptr;
609:
610: if (autorsize) {
611:
612: while ((ch = getc (infile)) != EOF) {
613:
614: i++;
615:
616: if (ch == LF) i++;
617:
618: } /* how big? */
619:
620: i = ((i + 3) & ~01777) + 02000; /* round for full kB; */
621:
622: if (newrsize (i, NO_OF_RBUF) == 0) { /* try to get more routine space. */
623:
624: altern = 0;
625: ch = EOL;
626:
627: fseek (infile, 0L, 0);
628:
629: goto again;
630:
631: }
632:
633: }
634:
635: fclose (infile);
636:
637: goto pgmov;
638:
639: pgmov:
640:
641: /* program overflow error */
642: rouptr = rouins = rouend = savptr;
643: (*savptr++) = EOL;
644: *savptr = EOL;
645:
646: for (i = 0; i < NO_OF_RBUF; i++) {
647: ages[i] = 0;
648: pgms[i][0] = 0;
649: }
650:
651: pgms[i][0] = EOL;
652: rou_name[0] = EOL;
653: merr_raise (PGMOV);
654:
655: return;
656:
657: } /* end of zload() */
658:
659: void zsave (char *rou) /* save routine on disk */
660: {
661: register int i;
662: register int j;
663: register int ch;
664: char tmp[256];
665:
666: stcpy (tmp, rou); /* save name without path */
667:
668: /* look whether we know where the routine came from */
669:
670: if (zsavestrategy) { /* VIEW 133: remember ZLOAD directory on ZSAVE */
671:
672: for (i = 0; i < NO_OF_RBUF; i++) {
673:
674: if (pgms[i][0] == 0) break; /* buffer empty */
675:
676: j = 0;
677:
678: while (rou[j] == pgms[i][j]) {
679:
680: if (rou[j++] == EOL) {
681:
682: stcpy (rou, path[i]);
683: stcat (rou, tmp);
684:
685: j = 0;
686: ch = 1; /* init for multiple path search */
687:
688: goto try;
689:
690: }
691:
692: }
693:
694: }
695:
696: }
697:
698: /* not found */
699: j = 0;
700: ch = EOL; /* init for multiple path search */
701:
702:
703: nextpath: /* entry point for retry */
704:
705: if (tmp[0] == '%') {
706:
707: if (rou1plib[0] != EOL) {
708:
709: i = 0;
710:
711: while ((ch = rou[i++] = rou1plib[j++]) != ':' && ch != EOL);
712:
713: if (i == 1 || (i == 2 && rou[0] == '.')) {
714: i = 0;
715: }
716: else {
717: rou[i - 1] = '/';
718: }
719:
720: stcpy (&rou[i], tmp);
721:
722: }
723:
724: }
725: else {
726:
727: if (rou1path[0] != EOL) {
728:
729: i = 0;
730:
731: while ((ch = rou[i++] = rou1path[j++]) != ':' && ch != EOL);
732:
733: if (i == 1 || (i == 2 && rou[0] == '.')) {
734: i = 0;
735: }
736: else {
737: rou[i - 1] = '/';
738: }
739:
740: stcpy (&rou[i], tmp);
741:
742: }
743:
744: }
745:
746:
747: try:
748:
749: stcat (rou, rou_ext);
750: rou[stlen (rou)] = NUL; /* append routine extention */
751:
752: if (rouend <= rouptr) {
753: unlink (rou);
754: rou_name[0] = EOL;
755: }
756: else {
757: FILE *outfile;
758: char *i0;
759:
760: for (;;) {
761:
762: errno = 0;
763:
764: if ((outfile = fopen (rou, "w")) != NULL) break;
765:
766: if (errno == EINTR) continue; /* interrupt */
767:
768: if (errno == EMFILE || errno == ENFILE) {
769: close_all_globals ();
770: continue;
771: } /* free file_des */
772:
773: if (ch != EOL) goto nextpath; /* try next access path */
774:
775: merr_raise (PROTECT);
776: return;
777:
778: }
779:
780: i0 = rouptr;
781:
782: while (++i0 < (rouend - 1)) {
783:
784: if ((ch = (*(i0))) == EOL) {
785: ch = LF;
786: i0++;
787: }
788:
789: putc (ch, outfile);
790:
791: }
792:
793: if (ch != LF) putc (LF, outfile);
794:
795: fclose (outfile);
796:
797: }
798:
799: return;
800:
801: } /* end of zsave() */
802:
803: /* insert 'line' in routine at 'position' */
804: void zi (char *line, char *position)
805: {
806: short offset;
807: short label;
808: short i;
809: short i0;
810: short ch;
811: char *reg;
812: char *end;
813: char line0[256];
814:
815: if (rouend - rouptr + stlen (line) + 1 > PSIZE0) { /* sufficient space ??? */
816:
817: reg = buff;
818:
819: if (getrmore () == 0L) return; /* PGMOV */
820:
821: position += buff - reg;
822:
823: }
824:
825: label = TRUE;
826: i = 0;
827: i0 = 0;
828:
829: while ((ch = line[i]) != EOL) {
830:
831: if (label) {
832:
833: if (ch == SP) ch = TAB;
834:
835: if (ch == TAB) {
836: label = FALSE;
837: }
838: else if (ch == '(') {
839:
840: line0[i0++] = ch;
841: i++;
842:
843: while (((ch = line[i]) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '%' || ch == ',') {
844: line0[i0++] = ch;
845: i++;
846: }
847:
848: if (ch != ')') {
849: merr_raise (ISYNTX);
850: return;
851: }
852:
853: line0[i0++] = ch;
854: i++;
855:
856: if ((ch = line[i]) != SP && ch != TAB) {
857: merr_raise (ISYNTX);
858: return;
859: }
860:
861: continue;
862:
863: }
864: else if ((ch < 'a' || ch > 'z') && (ch < 'A' || ch > 'Z') && (ch < '0' || ch > '9') && (ch != '%' || i)) {
865: merr_raise (ISYNTX);
866: return;
867: }
868:
869: line0[i0++] = ch;
870: i++;
871:
872: continue;
873:
874: }
875:
876: if (ch < SP || (ch >= DEL && (eightbit == FALSE))) {
877: merr_raise (ISYNTX);
878: return;
879: }
880:
881: line0[i0++] = ch;
882: i++;
883:
884: }
885:
886: if (label) {
887: merr_raise (ISYNTX);
888: return;
889: }
890:
891: line0[i0] = EOL;
892: offset = i0;
893:
894: if (offset > 0) {
895:
896: offset += 2;
897: end = rouend;
898: rouend += offset;
899:
900: if (roucur > position || roucur > end) roucur += offset;
901:
902: reg = rouend;
903:
904: while (position <= end) {
905: (*reg--) = (*end--);
906: }
907:
908: (*(position++)) = (UNSIGN (offset) - 2);
909:
910: reg = line0;
911:
912: while (((*(position++)) = (*(reg++))) != EOL);
913:
914: *(rouend + 1) = EOL;
915: *(rouend + 2) = EOL;
916:
917: for (i = 0; i < NO_OF_RBUF; i++) {
918:
919: if (rouptr == (buff + (i * PSIZE0))) {
920: ends[i] = rouend;
921: break;
922: }
923:
924: }
925:
926: }
927:
928: rouins = position;
929:
930: return;
931: } /* end of zi() */
932:
933: /*
934: * getraddress(char *a, short lvl):
935: *
936: * returns the 'canonical' address of the line at the specified DO/FOR/XEC level
937: *
938: * char *a (out param): pointer to the address of the line
939: * short lvl: process this level
940: *
941: */
942: void getraddress (char *a, short lvl)
943: {
944:
945: char *rcur; /* cursor into routine */
946: short f;
947: char tmp3[256];
948: char *j0;
949: char *j1;
950: short rlvl; /* lower level, where to find routine name */
951: register int i;
952: register int j;
953:
954: f = mcmnd;
955: mcmnd = 'd'; /* make load use standard-path */
956: rlvl = lvl;
957:
958: if (nestn[rlvl] == 0 && rlvl < nstx) rlvl++;
959:
960: if (nestn[rlvl]) zload (nestn[rlvl]);
961:
962: mcmnd = f;
963:
964: /* command on stack: 2 == DO_BLOCK; other: make uppercase */
965: i = nestc[lvl];
966:
967: if (i != '$') i = ((i == 2) ? 'd' : i - 32);
968:
969: a[0] = '(';
970: a[1] = i;
971: a[2] = ')';
972: a[3] = EOL; /* command */
973:
974: rcur = nestr[lvl] + rouptr; /* restore rcur */
975: j0 = (rouptr - 1);
976: j = 0;
977: tmp3[0] = EOL;
978:
979: j0++;
980:
981: if (rcur < rouend) {
982:
983: while (j0 < (rcur - 1)) {
984:
985: j1 = j0++;
986: j++;
987:
988: if ((*j0 != TAB) && (*j0 != SP)) {
989:
990: j = 0;
991:
992: while ((tmp3[j] = (*(j0++))) > SP) {
993:
994: if (tmp3[j] == '(') tmp3[j] = EOL;
995:
996: j++;
997:
998: }
999:
1000: tmp3[j] = EOL;
1001: j = 0;
1002:
1003: }
1004:
1005: j0 = j1;
1006: j0 += (UNSIGN (*j1)) + 2;
1007:
1008: }
1009:
1010: }
1011:
1012: stcat (a, tmp3);
1013:
1014: if (j > 0) {
1015:
1016: i = stlen (a);
1017: a[i++] = '+';
1018:
1019: intstr (&a[i], j);
1020:
1021: }
1022:
1023: if (nestn[rlvl]) {
1024:
1025: stcat (a, "^\201");
1026: stcat (a, nestn[rlvl]);
1027:
1028: }
1029: else if (rou_name[0] != EOL) {
1030:
1031: stcat (a, "^\201");
1032: stcat (a, rou_name);
1033:
1034: }
1035:
1036: f = mcmnd;
1037: mcmnd = 'd'; /* make load use standard-path */
1038:
1039: zload (rou_name);
1040:
1041: mcmnd = f;
1042:
1043: return;
1044:
1045: } /* end getraddress() */
1046:
1047: /* parse lineref and return pos.in routine */
1048: /* result: [pointer to] pointer to line */
1049: void lineref (char **adrr)
1050: {
1051: long offset;
1052: long j;
1053: char *reg;
1054: char *beg;
1055:
1056: while (*codptr == '@') { /* handle indirection */
1057:
1058: codptr++;
1059:
1060: expr (ARGIND);
1061:
1062: if (merr () > 0) return;
1063:
1064: stcat (argptr, codptr);
1065: stcpy (code, argptr);
1066:
1067: codptr = code;
1068:
1069: }
1070:
1071: offset = 0;
1072: beg = rouptr;
1073:
1074: if (*codptr == '+') {
1075:
1076: codptr++;
1077:
1078: expr (STRING);
1079:
1080: if (merr () > 0) return;
1081:
1082: if ((offset = intexpr (argptr)) <= 0) {
1083: *adrr = 0;
1084: return;
1085: }
1086:
1087: offset--;
1088:
1089: }
1090: else {
1091:
1092: expr (LABEL);
1093:
1094: if (merr () > 0) return;
1095:
1096: reg = beg;
1097:
1098: while (beg < rouend) {
1099:
1100: reg++;
1101:
1102: if ((*reg) != TAB && (*reg) != SP) {
1103:
1104: j = 0;
1105:
1106: while ((*reg) == varnam[j]) {
1107: reg++;
1108: j++;
1109: }
1110:
1111: if (((*reg) == TAB || (*reg) == SP || (*reg) == '(') && varnam[j] == EOL) break;
1112:
1113: }
1114:
1115: reg = (beg = beg + UNSIGN (*beg) + 2);
1116:
1117: }
1118:
1119: stcpy (varerr, varnam);
1120:
1121: varnam[0] = EOL;
1122: codptr++;
1123:
1124: if (*codptr == '+') {
1125:
1126: codptr++;
1127:
1128: expr (STRING);
1129:
1130: if (merr () > 0) return;
1131:
1132: offset = intexpr (argptr);
1133:
1134: }
1135:
1136: }
1137:
1138: if (offset < 0) {
1139:
1140: reg = rouptr;
1141:
1142: while (reg < beg) {
1143: reg += UNSIGN (*reg) + 2;
1144: offset++;
1145: }
1146:
1147: if (offset < 0) {
1148: *adrr = 0;
1149: return;
1150: }
1151:
1152: beg = rouptr;
1153:
1154: }
1155:
1156: while (offset-- > 0 && beg <= rouend) beg += UNSIGN (*beg) + 2;
1157:
1158: *adrr = beg;
1159:
1160: return;
1161: } /* end of lineref() */
1162:
1163: char *m_text(char *lref, char *buf)
1164: {
1165: char *old_codptr;
1166: char old_code[STRLEN];
1167:
1168: old_codptr = codptr;
1169: stcpy (old_code, code);
1170:
1171: sprintf (code, "$TEXT(%s)\201", lref);
1172: codptr = code;
1173:
1174: expr (STRING);
1175:
1176: if (merr () != OK) {
1177: stcpy (code, old_code);
1178: codptr = old_codptr;
1179: return (char *) NULL;
1180: }
1181:
1182: stcpy (buf, argptr);
1183: stcpy (code, old_code);
1184: codptr = old_codptr;
1185:
1186: return buf;
1187: }
1188:
1189:
1190:
1191: /* routine_get_line()
1192: * char *entryref: [cstr/in] M entryref
1193: * char *buf: [cstr/out] buffer to contain resulting line
1194: *
1195: * returns a pointer to buf [cstr] on success; otherwise NULL */
1196: char *routine_get_line(char *entryref, char *buf)
1197: {
1198: FILE *fp;
1199: char routine_path[PATHLEN];
1200:
1201: char *routine_p;
1202: char *label_p;
1203: char *offset_p;
1204:
1205: short have_label = FALSE;
1206: short have_offset = FALSE;
1207:
1208: char r[256];
1209: char l[256];
1210: char o[256];
1211: char txtbuf[256];
1212: char line[2048];
1213: int curline;
1214: char curtag[256];
1215: int cur_offset;
1216: int os;
1217:
1218: register int i;
1219: register int j;
1220: char ch;
1221:
1222: short in_tag = FALSE;
1223:
1224: /*
1225: * entryref can be:
1226: * +0 (returns rou_name)
1227: * label
1228: * ^routine
1229: * +offset
1230: * +offset^routine
1231: * label^routine
1232: * label+offset^routine
1233: */
1234:
1235: /* handle +0 */
1236: if (strcmp (entryref, "+0") == 0) {
1237: stcpy (buf, rou_name);
1238: stcnv_m2c (buf);
1239: return buf;
1240: }
1241:
1242: if ((routine_p = strchr (entryref, '^')) != NULL) {
1243: /* have a routine */
1244: stcpy (r, routine_p);
1245: stcnv_m2c (r);
1246:
1247: if ((entryref[0] != '^') && (isalpha (entryref[0]))) {
1248: /* we have a label */
1249: char ch;
1250: char *src;
1251: char *dst;
1252:
1253: src = entryref;
1254: dst = l;
1255:
1256: while (((ch = *src++) != '\0') && (ch != '^') && (ch != '+')) {
1257: *dst++ = ch;
1258: }
1259: *dst = '\0';
1260: have_label = TRUE;
1261: }
1262: }
1263: else {
1264: /* no routine implies current routine */
1265: stcpy (r, rou_name);
1266: stcnv_m2c (r);
1267: }
1268:
1269: if (r[0] == '^') {
1270: strcpy (txtbuf, &(r[1]));
1271: strcpy (r, txtbuf);
1272: }
1273:
1274: if (rtn_get_path (r, routine_path) == FALSE) {
1275: sprintf (buf, "");
1276: return NULL;
1277: }
1278:
1279: if ((fp = fopen (routine_path, "r")) == NULL) {
1280: sprintf (buf, "");
1281: return NULL;
1282: }
1283:
1284: if ((offset_p = strchr (entryref, '+')) != NULL) {
1285: stcpy (o, offset_p + 1);
1286: os = atoi (o);
1287: sprintf (o, "%d\0", os);
1288: have_offset = TRUE;
1289: }
1290: else {
1291: have_offset = FALSE;
1292: os = 1;
1293: }
1294:
1295: in_tag = FALSE;
1296: cur_offset = 0;
1297: while (fgets (line, sizeof (line) - 1, fp) != NULL) {
1298:
1299: if (!have_label && !have_offset) {
1300: strcpy (buf, line);
1301: fclose (fp);
1302: return buf;
1303: }
1304:
1305: if ((isalpha (line[0])) && (line[0] != ' ') && (line[0] != '\t')) {
1306: j = 0;
1307:
1308: for (i = 0; i < strlen (line); i++) {
1309: ch = line[i];
1310:
1311: if ((!isalpha (ch)) && (!isdigit (ch))) {
1312: curtag[j] = '\0';
1313: cur_offset = 0;
1314: if (have_label && (strcmp (curtag, l) == 0)) {
1315: in_tag = TRUE;
1316: if (!have_offset) {
1317: strcpy (buf, line);
1318: fclose (fp);
1319: return buf;
1320: }
1321: }
1322: else {
1323: in_tag = FALSE;
1324: }
1325: break;
1326: }
1327: else {
1328: curtag[j++] = ch;
1329: }
1330: }
1331: }
1332: else {
1333: cur_offset++;
1334:
1335: if (in_tag && (cur_offset == os)) {
1336: strcpy (buf, line);
1337: fclose (fp);
1338: return buf;
1339: }
1340: }
1341:
1342: }
1343:
1344: fclose (fp);
1345: return FALSE;
1346:
1347: }
1348:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to routine.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / src