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