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