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