![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to imain.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx|
Return to imain.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 root 1: /*
2: * Initialization and error routines.
3: */
4:
5: #include "../h/rt.h"
6: #include "../h/version.h"
7: #include "gc.h"
8: #include "../h/header.h"
9: #include <signal.h>
10: #include <ctype.h>
11: #ifndef VMS
12: #ifndef MSDOS
13: #include <sys/types.h>
14: #include <sys/times.h>
15: #else MSDOS
16: #ifdef LATTICE
17: #include <fcntl.h>
18: #include <time.h>
19: #endif LATTICE
20: #ifdef MSoft
21: #include <sys/types.h>
22: #include <fcntl.h>
23: #include SysTime
24: #endif MSoft
25: #endif MSDOS
26: #else VMS
27: #include <types.h>
28: struct tms {
29: time_t tms_utime; /* user time */
30: time_t tms_stime; /* system time */
31: time_t tms_cutime; /* user time, children */
32: time_t tms_cstime; /* system time, children */
33: };
34: #endif VMS
35:
36: /*
37: * A number of important variables follow.
38: */
39:
40: #ifndef MaxHeader
41: #define MaxHeader MaxHdr
42: #endif MaxHeader
43:
44: extern putpos(); /* assignment function for &pos */
45: extern putran(); /* assignment function for &random */
46: extern putsub(); /* assignment function for &subject */
47: extern puttrc(); /* assignment function for &trace */
48:
49: word *stack; /* interpreter stack */
50: int line = 0; /* source program line number */
51: int k_level = 0; /* &level */
52: struct descrip k_main; /* &main */
53: char *code; /* interpreter code buffer */
54: word *records; /* pointer to record procedure blocks */
55: word *ftab; /* pointer to record/field table */
56: struct descrip *globals, *eglobals; /* pointer to global variables */
57: struct descrip *gnames, *egnames; /* pointer to global variable names */
58: struct descrip *statics, *estatics; /* pointer to static variables */
59: char *ident; /* pointer to identifier table */
60:
61: int numbufs = NumBuf; /* number of i/o buffers */
62: char (*bufs)[BUFSIZ]; /* pointer to buffers */
63: FILE **bufused; /* pointer to buffer use markers */
64:
65: word tallybin[16]; /* counters for tallying */
66: int tallyopt = 0; /* want tally results output? */
67:
68: int mstksize = MStackSize; /* initial size of main stack */
69: int stksize = StackSize; /* co-expression stack size */
70: struct b_coexpr *stklist; /* base of co-expression block list */
71:
72: word statsize = MaxStatSize; /* size of static region */
73: word statincr = MaxStatSize/4; /* increment for static region */
74: char *statbase; /* start of static space */
75: char *statend; /* end of static space */
76: char *statfree; /* static space free pointer */
77:
78: word ssize = MaxStrSpace; /* initial string space size (bytes) */
79: char *strbase; /* start of string space */
80: char *strend; /* end of string space */
81: char *strfree; /* string space free pointer */
82: char *currend; /* current end of memory region */
83:
84: word abrsize = MaxAbrSize; /* initial size of allocated block
85: region (bytes) */
86: char *blkbase; /* start of block region */
87: char *maxblk; /* end of allocated blocks */
88: char *blkfree; /* block region free pointer */
89:
90: uword statneed; /* stated need for static space */
91: uword strneed; /* stated need for string space */
92: uword blkneed; /* stated need for block space */
93:
94: struct descrip **quallist; /* string qualifier list */
95: struct descrip **qualfree; /* qualifier list free pointer */
96: struct descrip **equallist; /* end of qualifier list */
97:
98: int dodump; /* if non-zero, core dump on error */
99: int noerrbuf; /* if non-zero, do not buffer stderr */
100:
101: struct descrip current; /* current expression stack pointer */
102: struct descrip maps2; /* second cached argument of map */
103: struct descrip maps3; /* third cached argument of map */
104:
105: int ntended = 0; /* number of active tended descrips */
106: long starttime; /* start time of job in milliseconds */
107:
108: /*
109: * Next there are several structures for built-in values. Parts of some
110: * of these structures are initialized later.
111: */
112:
113: /*
114: * Built-in csets
115: */
116:
117: /*
118: * &ascii; 128 bits on, second 128 bits off.
119: */
120: struct b_cset k_ascii = {
121: T_Cset,
122: 128,
123: cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0,
124: 0, 0, 0, 0, 0, 0, 0, 0)
125: };
126:
127: /*
128: * &cset; all 256 bits on.
129: */
130: struct b_cset k_cset = {
131: T_Cset,
132: 256,
133: cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0,
134: ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0)
135: };
136:
137:
138:
139: /*
140: * Cset for &lcase; bits corresponding to lowercase letters are on.
141: */
142: struct b_cset k_lcase = {
143: T_Cset,
144: 26,
145: cset_display( 0, 0, 0, 0, 0, 0, ~01, 03777,
146: 0, 0, 0, 0, 0, 0, 0, 0)
147: };
148:
149: /*
150: * &ucase; bits corresponding to uppercase characters are on.
151: */
152: struct b_cset k_ucase = {
153: T_Cset,
154: 26,
155: cset_display(0, 0, 0, 0, ~01, 03777, 0, 0,
156: 0, 0, 0, 0, 0, 0, 0, 0)
157: };
158:
159: /*
160: * Built-in files.
161: */
162:
163: struct b_file k_errout; /* &errout */
164: struct b_file k_input; /* &input */
165: struct b_file k_output; /* &outout */
166:
167: /*
168: * Keyword trapped variables.
169: */
170:
171: /*
172: * &pos.
173: */
174: struct b_tvkywd tvky_pos = {
175: T_Tvkywd,
176: /* putpos, */
177: /* D_Integer, */
178: /* 1, */
179: /* 4, */
180: /* "&pos" */
181: };
182:
183: /*
184: * &random.
185: */
186: struct b_tvkywd tvky_ran = {
187: T_Tvkywd,
188: /* putran, */
189: /* D_Integer, */
190: /* 0, */
191: /* 7, */
192: /* "&random" */
193: };
194:
195: /*
196: * &subject.
197: */
198: struct b_tvkywd tvky_sub = {
199: T_Tvkywd,
200: /* putsub, */
201: /* 0, */
202: /* 0, */
203: /* 8, */
204: /* "&subject" */
205: };
206:
207: /*
208: * &trace.
209: */
210: struct b_tvkywd tvky_trc = {
211: T_Tvkywd,
212: /* puttrc, */
213: /* D_Integer, */
214: /* 0, */
215: /* 6, */
216: /* "&trace" */
217: };
218:
219: /*
220: * Co-expression block header for &main.
221: */
222:
223: static struct b_coexpr *mainhead;
224:
225: #if IntSize == 16
226: /*
227: * Long integer block for &random.
228: */
229: struct b_int long_ran = {
230: T_Longint,
231: 0L
232: };
233: #endif IntSize == 16
234:
235: /*
236: * Various constant descriptors.
237: */
238:
239: struct descrip blank = {1, /*" "*/};
240: struct descrip emptystr = {0, /*""*/};
241: struct descrip errout = {D_File, /*&k_errout*/};
242: struct descrip input = {D_File, /*&k_input*/};
243: struct descrip lcase = {26, /*lowercase*/};
244: struct descrip letr = {1, /*"r"*/};
245: struct descrip nulldesc = {D_Null, /*0*/};
246: struct descrip onedesc = {D_Integer, /*1*/};
247: struct descrip ucase = {26, /*uppercase*/};
248: struct descrip zerodesc = {D_Integer, /*0*/};
249:
250: #ifdef RunStats
251: #endif RunStats
252:
253: /*
254: * init - initialize memory and prepare for Icon execution.
255: */
256:
257: init(name)
258: char *name;
259: {
260: register int i;
261: word cbread;
262: int f;
263: char c, *p;
264: struct descrip *dp;
265: struct header hdr;
266: #ifndef MSDOS
267: struct tms tp;
268: extern char *brk(), *sbrk(), *index();
269: #else MSDOS
270: #ifdef LPTR
271: long longread();
272: #endif LPTR
273: #endif MSDOS
274: extern fpetrap(), segvtrap();
275:
276: /*
277: * Catch floating point traps and memory faults.
278: */
279: #ifndef MSoft
280: signal(SIGFPE, fpetrap);
281: #endif MSoft
282: #ifndef MSDOS
283: #ifdef PYRAMID
284: {
285: struct sigvec a;
286:
287: a.sv_handler = fpetrap;
288: a.sv_mask = 0;
289: a.sv_onstack = 0;
290: sigvec(SIGFPE, &a, 0);
291: sigsetmask(1 << SIGFPE);
292: }
293: #else PYRAMID
294: signal(SIGFPE, fpetrap);
295: #endif PYRAMID
296: #endif MSDOS
297:
298: /*
299: * Initializations that cannot be performed statically (at least for
300: * some compilers).
301: */
302:
303: k_errout.title = T_File;
304: k_errout.fd = stderr;
305: k_errout.status = Fs_Write;
306: k_errout.fname.dword = 7;
307: StrLoc(k_errout.fname) = "&errout";
308:
309: k_input.title = T_File;
310: k_input.fd = stdin;
311: k_input.status = Fs_Read;
312: k_input.fname.dword = 6;
313: StrLoc(k_input.fname) = "&input";
314:
315: k_output.title = T_File;
316: k_output.fd = stdout;
317: k_output.status = Fs_Write;
318: k_output.fname.dword = 7;
319: StrLoc(k_output.fname) = "&output";
320:
321: tvky_pos.putval = putpos;
322: ((tvky_pos.kyval).dword) = D_Integer;
323: IntVal(tvky_pos.kyval) = 1;
324: StrLen(tvky_pos.kyname) = 4;
325: StrLoc(tvky_pos.kyname) = "&pos";
326:
327: tvky_ran.putval = putran;
328: #if IntSize == 16
329: ((tvky_ran.kyval).dword) = D_Longint;
330: #else IntSize == 16
331: ((tvky_ran.kyval).dword) = D_Integer;
332: #endif IntSize == 16
333: StrLen(tvky_ran.kyname) = 7;
334: StrLoc(tvky_ran.kyname) = "&random";
335:
336: tvky_sub.putval = putsub;
337: StrLen(tvky_sub.kyval) = 0;
338: StrLen(tvky_sub.kyname) = 8;
339: StrLoc(tvky_sub.kyname) = "&subject";
340:
341: tvky_trc.putval = puttrc;
342: ((tvky_trc.kyval).dword) = D_Integer;
343: StrLen(tvky_trc.kyname) = 6;
344: StrLoc(tvky_trc.kyname) = "&trace";
345: #if IntSize == 16
346: BlkLoc(tvky_ran.kyval) = (union block *) &long_ran;
347: #else IntSize == 16
348: IntVal(tvky_ran.kyval) = 0;
349: #endif IntSize == 16
350: IntVal(tvky_trc.kyval) = 0;
351: StrLoc(tvky_sub.kyval) = "";
352:
353:
354: StrLoc(k_subject) = "";
355: IntVal(nulldesc) = 0;
356: maps2 = nulldesc;
357: maps3 = nulldesc;
358: IntVal(zerodesc) = 0;
359: IntVal(onedesc) = 1;
360: StrLoc(emptystr) = "";
361: StrLoc(blank) = " ";
362: StrLoc(letr) = "r";
363: BlkLoc(input) = (union block *) &k_input;
364: BlkLoc(errout) = (union block *) &k_errout;
365: StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz";
366: StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
367:
368: /*
369: * Open the icode file and read the header.
370: */
371: i = strlen(name);
372: #ifndef MSDOS
373: f = open(name, 0);
374: #else MSDOS
375: #ifdef LATTICE
376: f = open(name,O_RDONLY | O_RAW);
377: #endif LATTICE
378: #ifdef MSoft
379: f = open(name,O_RDONLY | O_BINARY);
380: #endif MSoft
381: #endif MSDOS
382: if (f < 0)
383: error("can't open interpreter file");
384: #ifndef NoHeader
385: lseek(f, (long)MaxHeader, 0);
386: #endif NoHeader
387: if (read(f, (char *)&hdr, sizeof(hdr)) != sizeof(hdr))
388: error("can't read interpreter file header");
389:
390: /*
391: * Establish pointers to data regions.
392: */
393: code = (char *)sbrk((word)0);
394: k_trace = hdr.trace;
395: records = (word *) (word)(code + hdr.records);
396: ftab = (word *) (word)(code + hdr.ftab);
397: globals = (struct descrip *) (code + hdr.globals);
398: gnames = eglobals = (struct descrip *) (code + hdr.gnames);
399: statics = egnames = (struct descrip *) (code + hdr.statics);
400: estatics = (struct descrip *) (code + hdr.ident);
401: ident = (char *) estatics;
402:
403: /*
404: * Examine the environment and make appropriate settings.
405: */
406: envlook();
407:
408: /*
409: * Convert stack sizes from words to bytes.
410: */
411: stksize *= WordSize;
412: mstksize *= WordSize;
413:
414: /*
415: * Set up allocated memory. The regions are:
416: *
417: * Static memory region
418: * Allocated string region
419: * Allocate block region
420: * String qualifier list
421: */
422: /*
423: * Align bufs on a word boundary
424: */
425: bufs = (char **)((word)(code + hdr.hsize + 3) & ~03);
426: bufused = (FILE **) (bufs + numbufs);
427: statfree = statbase = (char *)(((word)(bufused + numbufs) + 63) & ~077);
428: statend = statbase + mstksize + statsize;
429: strfree = strbase = (char *)((word)(statend + 63) & ~077);
430: blkfree = blkbase = strend = (char *)((word)(strbase + ssize + 63) & ~077);
431: quallist = qualfree = equallist =
432: (struct descrip **)(maxblk = (char *)((word)(blkbase + abrsize + 63) & ~077));
433:
434: /*
435: * Try to move the break back to the end of memory to allocate (the
436: * end of the string qualifier list) and die if the space isn't
437: * available.
438: */
439: if ((int)brk(equallist) == -1)
440: error("insufficient memory");
441: currend = sbrk(0); /* keep track of end of memory */
442:
443: /*
444: * Allocate stack and initialize &main.
445: */
446: stack = (word *)malloc(mstksize);
447: mainhead = (struct b_coexpr *)stack;
448: mainhead->title = T_Coexpr;
449: mainhead->activator.dword = D_Coexpr;
450: BlkLoc(mainhead->activator) = (union block *)mainhead;
451: mainhead->size = 0;
452: mainhead->freshblk = nulldesc; /* &main has no refresh block. */
453: /* This really is a bug. */
454:
455: /*
456: * Point &main at the stack for the main procedure and set current,
457: * the pointer to the current co-expression to &main.
458: */
459: k_main.dword = D_Coexpr;
460: BlkLoc(k_main) = (union block *) mainhead;
461: current = k_main;
462:
463: /*
464: * Read the interpretable code and data into memory.
465: */
466: #ifndef MSDOS
467: if ((cbread = read(f, code, hdr.hsize)) != hdr.hsize) {
468: #else MSDOS
469: #ifdef SPTR
470: if ((cbread = read(f, code, hdr.hsize)) != hdr.hsize) {
471: #else /* Handle the case where hdr.hsize is long */
472: if ((cbread = longread(f, code, hdr.hsize)) != hdr.hsize) {
473: #endif SPTR
474: #endif MSDOS
475: fprintf(stderr,"Tried to read %ld bytes of code, and got %ld\n",
476: (long)hdr.hsize,(long)cbread);
477: error("can't read interpreter code");
478: }
479: close(f);
480:
481: /*
482: * Make sure the version number of the icode matches the interpreter version.
483: */
484:
485: if (strcmp((char *)hdr.config,IVersion)) {
486: fprintf(stderr,"icode version mismatch\n");
487: fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config);
488: fprintf(stderr,"\texpected version: %s\n",IVersion);
489: fflush(stderr);
490: if (dodump)
491: abort();
492: c_exit(ErrorExit);
493: }
494:
495: /*
496: * Resolve references from icode to runtime system.
497: */
498: resolve();
499:
500: /*
501: * Mark all buffers as available.
502: */
503: c = (char) NULL;
504: for (i = 0; i < numbufs; i++)
505: bufused[i] = (FILE *) c;
506:
507: /*
508: * Buffer stdin if a buffer is available.
509: */
510: #ifndef VMS
511: if (numbufs >= 1) {
512: setbuf(stdin, bufs[0]);
513: bufused[0] = stdin;
514: }
515: else
516: setbuf(stdin, NULL);
517:
518: /*
519: * Buffer stdout if a buffer is available.
520: */
521: if (numbufs >= 2) {
522: setbuf(stdout, bufs[1]);
523: bufused[1] = stdout;
524: }
525: else
526: setbuf(stdout, NULL);
527:
528: /*
529: * Buffer stderr if a buffer is available.
530: */
531: if (numbufs >= 3 && !noerrbuf) {
532: setbuf(stderr, bufs[2]);
533: bufused[2] = stderr;
534: }
535: else
536: setbuf(stderr, NULL);
537: #endif VMS
538:
539: /*
540: * Initialize memory monitoring if enabled.
541: */
542: MMInit();
543:
544: /*
545: * Get startup time.
546: */
547: #ifndef MSDOS
548: times(&tp);
549: starttime = tp.tms_utime;
550: #else MSDOS
551: time(&starttime);
552: #endif MSDOS
553: }
554:
555: /*
556: * Check for environment variables that Icon uses and set system
557: * values as is appropriate.
558: */
559: envlook()
560: {
561: register char *p;
562: extern char *getenv();
563:
564: if ((p = getenv("TRACE")) != NULL && *p != '\0')
565: k_trace = atoi(p);
566: if ((p = getenv("NBUFS")) != NULL && *p != '\0')
567: numbufs = atoi(p);
568: if ((p = getenv("COEXPSIZE")) != NULL && *p != '\0')
569: stksize = atoi(p);
570: if ((p = getenv("STRSIZE")) != NULL && *p != '\0')
571: ssize = atoi(p);
572: if ((p = getenv("HEAPSIZE")) != NULL && *p != '\0')
573: abrsize = atoi(p);
574: if ((p = getenv("STATSIZE")) != NULL && *p != '\0')
575: statsize = atoi(p);
576: if ((p = getenv("STATINCR")) != NULL && *p != '\0')
577: statincr = atoi(p);
578: if ((p = getenv("MSTKSIZE")) != NULL && *p != '\0')
579: mstksize = atoi(p);
580: if ((p = getenv("ICONCORE")) != NULL && *p != '\0') {
581: #ifndef MSoft
582: signal(SIGFPE, SIG_DFL);
583: #endif MSoft
584: #ifndef MSDOS
585: signal(SIGSEGV, SIG_DFL);
586: #endif MSDOS
587: dodump++;
588: }
589: if ((p = getenv("NOERRBUF")) != NULL)
590: noerrbuf++;
591: }
592:
593: /*
594: * Produce run-time error 204 on floating point traps.
595: */
596: #ifdef PYRAMID
597: fpetrap(code, subcode, sp)
598: int code, subcode, sp;
599: {
600: runerr(subcode == FPE_wordOVF_EXC ? 203 : 204, NULL);
601: }
602: #else PYRAMID
603: fpetrap()
604: {
605: runerr(204, NULL);
606: }
607: #endif PYRAMID
608:
609: /*
610: * Produce run-time error 302 on segmentation faults.
611: */
612: segvtrap()
613: {
614: runerr(302, NULL);
615: }
616:
617: /*
618: * error - print error message s; used only in startup code.
619: */
620: error(s)
621: char *s;
622: {
623: fprintf(stderr, "error in startup code\n%s\n", s);
624: fflush(stderr);
625: if (dodump)
626: abort();
627: c_exit(ErrorExit);
628: }
629:
630: /*
631: * syserr - print s as a system error.
632: */
633: syserr(s)
634: char *s;
635: {
636: struct b_proc *bp;
637:
638: bp = (struct b_proc *)BlkLoc(argp[0]);
639: if (line > 0)
640: fprintf(stderr, "System error at line %ld in %s\n%s\n", (long)line,
641: bp->filename, s);
642: else
643: fprintf(stderr, "System error in startup code\n%s\n", s);
644: fflush(stderr);
645: if (dodump)
646: abort();
647: c_exit(ErrorExit);
648: }
649:
650: /*
651: * errtab maps run-time error numbers into messages.
652: */
653: struct errtab {
654: int errno;
655: char *errmsg;
656: } errtab[] = {
657: 101, "integer expected",
658: 102, "numeric expected",
659: 103, "string expected",
660: 104, "cset expected",
661: 105, "file expected",
662: 106, "procedure or integer expected",
663: 107, "record expected",
664: 108, "list expected",
665: 109, "string or file expected",
666: 110, "string or list expected",
667: 111, "variable expected",
668: 112, "invalid type to size operation",
669: 113, "invalid type to random operation",
670: 114, "invalid type to subscript operation",
671: 115, "list or table expected",
672: 116, "invalid type to element generator",
673: 117, "missing main procedure",
674: 118, "co-expression expected",
675: 119, "set expected",
676:
677: 201, "division by zero",
678: 202, "remaindering by zero",
679: 203, "integer overflow",
680: 204, "real overflow, underflow, or division by zero",
681: 205, "value out of range",
682: 206, "negative first operand to real exponentiation",
683: 207, "invalid field name",
684: 208, "second and third arguments to map of unequal length",
685: 209, "invalid second argument to open",
686: 210, "argument to system function too long",
687: 211, "by clause equal to zero",
688: 212, "attempt to read file not open for reading",
689: 213, "attempt to write file not open for writing",
690: 214, "recursive co-expression activation",
691:
692: 301, "interpreter stack overflow",
693: 302, "C stack overflow",
694: 303, "unable to expand memory region",
695: 304, "memory region size changed",
696:
697: 0, 0
698: };
699:
700: /*
701: * runerr - print message corresponding to error n and if v is nonnull,
702: * print it as the offending value.
703: */
704: #ifdef PCIX
705: /*
706: * For PC/IX, runerr is an assembly language routine that jumps into this
707: * xruner procedure past the call to csv which occurs at the beginning of
708: * all C procedures. This is necessary to defeat the stack data collision
709: * testing which is done in csv in pc/ix and which would cause a loop,
710: * since one of the possible reasons for calling runerr in the first place
711: * might be stack/data collision.
712: */
713: xruner(n, v)
714: #else PCIX
715: runerr(n, v)
716: #endif PCIX
717: register int n;
718: struct descrip *v;
719: {
720: register struct errtab *p;
721: struct b_proc *bp;
722:
723: if (line > 0) {
724: bp = (struct b_proc *)BlkLoc(argp[0]);
725: fprintf(stderr, "Run-time error %d at line %ld in %s\n", n,
726: (long)line, bp->filename);
727: }
728: else
729: fprintf(stderr, "Run-time error %d in startup code\n", n);
730: for (p = errtab; p->errno > 0; p++)
731: if (p->errno == n) {
732: fprintf(stderr, "%s\n", p->errmsg);
733: break;
734: }
735: if (v != NULL) {
736: fprintf(stderr, "offending value: ");
737: outimage(stderr, v, 0);
738: putc('\n', stderr);
739: }
740: fflush(stderr);
741: if (dodump)
742: abort();
743: c_exit(ErrorExit);
744: }
745:
746: /*
747: * resolve - perform various fixups on the data read from the interpretable
748: * file.
749: */
750: resolve()
751: {
752: register word i;
753: register struct b_proc *pp;
754: register struct descrip *dp;
755: extern mkrec();
756: extern struct b_proc *functab[];
757:
758: /*
759: * Scan the global variable list for procedures and fill in appropriate
760: * addresses.
761: */
762: for (dp = globals; dp < eglobals; dp++) {
763: if ((*dp).dword != D_Proc)
764: continue;
765: /*
766: * The second word of the descriptor for procedure variables tells
767: * where the procedure is. Negative values are used for built-in
768: * procedures and positive values are used for Icon procedures.
769: */
770: i = IntVal(*dp);
771: if (i < 0) {
772: /*
773: * *dp names a built-in function, negate i and use it as an index
774: * into functab to get the location of the procedure block.
775: */
776: BlkLoc(*dp) = (union block *) functab[-i-1];
777: }
778: else {
779: /*
780: * *dp names an Icon procedure or a record. i is an offset to
781: * location of the procedure block in the code section. Point
782: * pp at the block and replace BlkLoc(*dp).
783: */
784: pp = (struct b_proc *) (code + i);
785: BlkLoc(*dp) = (union block *) pp;
786: /*
787: * Relocate the address of the name of the procedure.
788: */
789: StrLoc(pp->pname) += (word)ident;
790: if (pp->ndynam == -2)
791: /*
792: * This procedure is a record constructor. Make its entry point
793: * be the entry point of mkrec().
794: */
795: pp->entryp.ccode = mkrec;
796: else {
797: /*
798: * This is an Icon procedure. Relocate the entry point and
799: * the names of the parameters, locals, and static variables.
800: */
801: pp->entryp.icode = code + (word)pp->entryp.icode;
802: if (pp->ndynam >= 0)
803: pp->filename += (word)ident;
804: for (i = 0; i < pp->nparam+pp->ndynam+pp->nstatic; i++)
805: StrLoc(pp->lnames[i]) += (word)ident;
806: }
807: }
808: }
809: /*
810: * Relocate the names of the global variables.
811: */
812: for (dp = gnames; dp < egnames; dp++)
813: StrLoc(*dp) += (word)ident;
814: }
815:
816:
817: /*
818: * c_exit(i) - flush all buffers and exit with status i.
819: */
820: c_exit(i)
821: int i;
822: {
823: int j;
824:
825: #ifdef MemMon
826: MMTerm();
827: #endif MemMon
828: if (tallyopt) {
829: fprintf(stderr,"tallies: ");
830: for (j=0; j<16; j++)
831: fprintf(stderr," %ld", (long)tallybin[j]);
832: fprintf(stderr,"\n");
833: }
834: exit(i);
835: }
836:
837: err()
838: {
839: syserr("call to 'err'\n");
840: }
841:
842: #ifdef MSDOS
843: #ifdef LPTR
844: /* Write a long string in 32k chunks */
845: long longread(file,s,len)
846: int file;
847: char *s;
848: long int len;
849: {
850: long int loopnum;
851: long int leftover;
852: long int tally;
853: unsigned i;
854: char *p;
855:
856: tally = 0;
857: leftover = len % 32768;
858: for(p = s, loopnum = len/32768;loopnum;loopnum--) {
859: i = read(file,p,32768);
860: tally += i;
861: if (i != 32768) return tally;
862: p += 32768;
863: }
864: if(leftover) tally += read(file,p,leftover);
865: return tally;
866: }
867: #endif LPTR
868: #endif MSDOS
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.