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