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