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