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