diff options
Diffstat (limited to 'src')
121 files changed, 1026 insertions, 31657 deletions
diff --git a/src/Makefile b/src/Makefile index 2aaa971..7726ec3 100644 --- a/src/Makefile +++ b/src/Makefile @@ -5,14 +5,13 @@ what: @echo "What do you want to make?" Clean Pure: - cd iconc; rm -f *.o iconc - cd common; rm -f *.o doincl patchstr infer - cd preproc; rm -f *.o pp - cd rtt; rm -f *.o rtt - cd runtime; rm -f *.o *.c rt.db rt.a rttcur.lst rttfull.lst iconx - cd icont; rm -f *.o icont hdr.h ixhdr.hdr newhdr - cd wincap; rm -f *.o *.a - cd xpm; rm -f *.o *.a + cd common; rm -f *.o *.exe patchstr infer + cd preproc; rm -f *.o *.exe pp + cd rtt; rm -f *.o *.exe rtt + cd runtime; rm -f *.o *.exe *.c rt.db rt.a rtt*.lst iconx + cd icont; rm -f *.o *.exe icont hdr.h ixhdr.hdr newhdr + cd wincap; rm -f *.o *.exe *.a + cd xpm; rm -f *.o *.exe *.a # force full runtime system rebuild touch h/define.h rm -f h/arch.h @@ -20,12 +19,11 @@ Clean Pure: # The following entry forces rebuilding of everthing from first-generation # files, even files not normally recreated. Doing this requires uncommenting -# some lines in common/Makefile, icont/Makefile, and iconc/Makefile. +# some lines in common/Makefile and icont/Makefile. Force-rebuild: Clean cd h; rm -f kdefs.h cd common; rm -f *.o yacctok.h lextab.h icontype.h \ - doincl fixgram mktoktab patchstr pscript typespec + fixgram mktoktab patchstr pscript typespec cd icont; rm -f *.o icont mkkwd trash \ hdr.h keyword.h tgram.g ttoken.h tparse.c - cd iconc; rm -f *.o iconc cgram.g ctoken.h cparse.h diff --git a/src/common/Makefile b/src/common/Makefile index bb5546a..9456be5 100644 --- a/src/common/Makefile +++ b/src/common/Makefile @@ -3,13 +3,9 @@ include ../../Makedefs OBJS = long.o getopt.o time.o filepart.o identify.o strtbl.o rtdb.o\ munix.o literals.o rswitch.o alloc.o long.o getopt.o time.o\ - xwindow.o dlrgint.o ipp.o + xwindow.o ipp.o -common: doincl $(OBJS) gpxmaybe - -doincl: doincl.c ../h/arch.h - $(CC) $(CFLAGS) -o doincl doincl.c - -./doincl -o ../../bin/rt.h ../h/rt.h +common: $(OBJS) gpxmaybe patchstr: patchstr.c $(CC) $(CFLAGS) -o patchstr patchstr.c @@ -40,20 +36,13 @@ literals.o: ../h/esctab.h rtdb.o: ../h/version.h icontype.h -dlrgint.o: ../h/rproto.h ../h/rexterns.h ../h/rmacros.h ../h/rstructs.h - xwindow.o: ../h/graphics.h ../h/xwin.h -# for rswitch, $(CFLAGS) is deliberately omitted (-O may cause problems) -rswitch.o: ../h/define.h ../h/arch.h $(RSW) - $(CC) -c $(RSW) - # The following section is needed if changes are made to the Icon grammar, # but it is not run as part of the normal installation process. If it is -# needed, it is run by changing ../icont/Makefile and/or ../iconc/Makefile; -# see the comments there for details. icont must be in the search path -# for this section to work. +# needed, it is run by changing ../icont/Makefile; see the comments there +# for details. icont must be in the search path for this section to work. gfiles: lextab.h yacctok.h fixgram pscript diff --git a/src/common/alloc.c b/src/common/alloc.c index 7a048b1..e3b7503 100644 --- a/src/common/alloc.c +++ b/src/common/alloc.c @@ -4,11 +4,6 @@ #include "../h/gsupport.h" -#ifdef TypTrc - int typealloc = 0; /* type allocation switch */ - long typespace = 0; /* type allocation amount */ -#endif /* TypTrc */ - /* * salloc - allocate and initialize string */ @@ -35,24 +30,6 @@ unsigned int n; { register pointer a; -#ifdef AllocTrace - static int sum = 0; -#endif /* AllocTrace */ - -#ifdef TypTrc - if (typealloc) - typespace += (long)n; -#endif /* TypTrc */ - -#ifdef AllocTrace - sum = sum + n; - if (sum > 5000) { - fprintf(stderr, "."); - fflush(stderr); - sum = 0; - }; -#endif /* AllocTrace */ - if (n == 0) /* Work-around for 0 allocation */ n = 1; diff --git a/src/common/dlrgint.c b/src/common/dlrgint.c deleted file mode 100644 index 3ca79d1..0000000 --- a/src/common/dlrgint.c +++ /dev/null @@ -1,252 +0,0 @@ -/* - * dlrgint.c - versions of "large integer" routines for compiled programs - * that do not support large integers. - */ -#define COMPILER 1 -#include "../h/rt.h" - -/* - ***************************************************************** - * - * Routines in the first set are only called when large integers - * exist and thus these versions will never be called. They need - * only have the correct signature and compile without error. - */ - -/* - * bignum -> file - */ -void bigprint(f, da) -FILE *f; -dptr da; - { - } - -/* - * bignum -> real - */ -double bigtoreal(da) -dptr da; - { - return 0.0; - } - -/* - * bignum -> string - */ -int bigtos(da, dx) -dptr da, dx; - { - return 0; - } - -/* - * da -> dx - */ -int cpbignum(da, dx) -dptr da, dx; - { - return 0; - } - -/* - * da / db -> dx - */ -int bigdiv(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * da % db -> dx - */ -int bigmod(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * iand(da, db) -> dx - */ -int bigand(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * ior(da, db) -> dx - */ -int bigor(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * xor(da, db) -> dx - */ -int bigxor(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * negative if da < db - * zero if da == db - * positive if da > db - */ -word bigcmp(da, db) -dptr da, db; - { - return (word)0; - } - -/* - * ?da -> dx - */ -int bigrand(da, dx) -dptr da, dx; - { - return 0; - } - -/* - ************************************************************* - * - * The following routines are called when overflow has occurred - * during ordinary arithmetic. - */ - -/* - * da + db -> dx - */ -int bigadd(da, db, dx) -dptr da, db; -dptr dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * da * db -> dx - */ -int bigmul(da, db, dx) -dptr da, db, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * -i -> dx - */ -int bigneg(da, dx) -dptr da, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * da - db -> dx - */ -int bigsub(da, db, dx) -dptr da, db, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * ******************************************************** - * - * The remaining routines each requires different handling. - */ - -/* - * real -> bignum - */ -int realtobig(da, dx) -dptr da, dx; - { - return Failed; /* conversion cannot be done */ - } - -/* - * da ^ db -> dx - */ -int bigpow(da, db, dx) -dptr da, db, dx; - { - C_integer r; - extern int over_flow; - - /* - * Just do ordinary interger exponentiation and check for overflow. - */ - r = iipow(IntVal(*da), IntVal(*db)); - if (over_flow) { - k_errornumber = 203; - k_errortext = ""; - k_errorvalue = nulldesc; - have_errval = 0; - return Error; - } - MakeInt(r, dx); - return Succeeded; - } - -/* - * string -> bignum - */ -word bigradix(sign, r, s, end_s, result) -int sign; /* '-' or not */ -int r; /* radix 2 .. 36 */ -char *s, *end_s; /* input string */ -union numeric *result; /* output T_Integer or T_Lrgint */ - { - /* - * Just do string to ordinary integer. - */ - return radix(sign, r, s, end_s, result); - } - -/* - * bigshift(da, db) -> dx - */ -int bigshift(da, db, dx) -dptr da, db, dx; - { - uword ci; /* shift in 0s, even if negative */ - C_integer cj; - - /* - * Do an ordinary shift - note that db is always positive when this - * routine is called. - */ - ci = (uword)IntVal(*da); - cj = IntVal(*db); - /* - * Check for a shift of WordSize or greater; return an explicit 0 because - * this is beyond C's defined behavior. Otherwise shift as requested. - */ - if (cj >= WordBits) - ci = 0; - else - ci <<= cj; - MakeInt(ci, dx); - return Succeeded; - } diff --git a/src/common/doincl.c b/src/common/doincl.c deleted file mode 100644 index 8f80c87..0000000 --- a/src/common/doincl.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * doincl.c -- expand include directives (recursively) - * - * Usage: doinclude [-o outfile] filename... - * - * Doinclude copies a C source file, expanding non-system include directives. - * For each line of the form - * #include "filename" - * the named file is interpolated; all other lines are copied verbatim. - * - * No error is generated if a file cannot be opened. - */ - -#include "../h/rt.h" - -void doinclude (char *fname); - -#define MAXLINE 500 /* maximum line length */ - -FILE *outfile; /* output file */ - -int main(argc, argv) -int argc; -char *argv[]; - { - char *progname = argv[0]; - - outfile = stdout; - if (argc > 3 && strcmp(argv[1], "-o") == 0) { - if ((outfile = fopen(argv[2], "w")) != NULL) { - argv += 2; - argc -= 2; - } - else { - perror(argv[2]); - exit(1); - } - } - if (argc < 2) { - fprintf(stderr, "usage: %s [-o outfile] filename...\n", progname); - exit(1); - } - - fprintf(outfile, - "/***** do not edit -- this file was generated mechanically *****/\n\n"); - while (--argc > 0) - doinclude(*++argv); - exit(0); - /*NOTREACHED*/ - } - -void doinclude(fname) -char *fname; - { - FILE *f; - char line[MAXLINE], newname[MAXLINE], *p; - - fprintf(outfile, "\n\n/****************************************"); - fprintf(outfile, " from %s: */\n\n", fname); - if ((f = fopen(fname, "r")) != NULL) { - while (fgets(line, MAXLINE, f)) - if (sscanf(line, " # include \"%s\"", newname) == 1) { - for (p = newname; *p != '\0' && *p != '"'; p++) - ; - *p = '\0'; /* strip off trailing '"' */ - doinclude(newname); /* include file */ - } - else - fputs(line, outfile); /* not an include directive */ - fclose(f); - } - else { - fprintf(outfile, "/* [file not found] */\n"); - } - fprintf(outfile, "\n/****************************************"); - fprintf(outfile, " end %s */\n", fname); - } diff --git a/src/common/error.h b/src/common/error.h index 0c5cb83..77ce243 100644 --- a/src/common/error.h +++ b/src/common/error.h @@ -2,8 +2,6 @@ * error.h -- routines for producing error messages. * * This source file contains the routines for issuing error messages. - * It is built by inclusion in ../icont/tlex.c and ../iconc/clex.c, - * with slight variations depending on whether "Iconc" is defined. */ /* @@ -110,25 +108,6 @@ char *s1, *s2; nocode++; } -#ifdef Iconc -/* - * twarn produces s1 and s2 (if nonnull) as translator warning messages. - * The location of the error is found in tok_loc. - */ -void twarn(s1, s2) -char *s1, *s2; - { - - if (tok_loc.n_file) - fprintf(stderr, "File %s; ", tok_loc.n_file); - fprintf(stderr, "Line %d # ", tok_loc.n_line); - if (s2) - fprintf(stderr, "\"%s\": ", s2); - fprintf(stderr, "%s\n", s1); - twarns++; - } -#endif /* Iconc */ - /* * tsyserr is called for fatal errors. The message s is produced and the * translator exits. @@ -162,18 +141,12 @@ void quitf(msg,arg) char *msg, *arg; { extern char *progname; + extern char *ofile; fprintf(stderr,"%s: ",progname); fprintf(stderr,msg,arg); fprintf(stderr,"\n"); - - #if !defined(Iconc) - { - extern char *ofile; - if (ofile) - remove(ofile); /* remove bad icode file */ - } - #endif /* !Iconc */ - + if (ofile) + remove(ofile); /* remove bad icode file */ exit(EXIT_FAILURE); } diff --git a/src/common/filepart.c b/src/common/filepart.c index ab8049a..3c0b2de 100644 --- a/src/common/filepart.c +++ b/src/common/filepart.c @@ -38,22 +38,14 @@ static char *tryfile (char *buf, char *dir, char *name, char *extn); char *pathfind(buf, path, name, extn) char *buf, *path, *name, *extn; { - char *s; char pbuf[MaxPath]; if (tryfile(buf, (char *)NULL, name, extn)) /* try curr directory first */ return buf; - if (!path) /* if no path, use default */ + if (!path) /* if no path, use default */ path = DefPath; - #if CYGWIN - s = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); - cygwin_win32_to_posix_path_list(path, s); - #else /* CYGWIN */ - s = path; - #endif /* CYGWIN */ - - while ((s = pathelem(s, pbuf)) != 0) /* for each path element */ + while ((path = pathelem(path, pbuf)) != 0) /* for each path element */ if (tryfile(buf, pbuf, name, extn)) /* look for file */ return buf; return NULL; /* return NULL if no file found */ @@ -123,12 +115,6 @@ char *s; int n; char *p, *q; - #if CYGWIN - char posix_s[_POSIX_PATH_MAX + 1]; - cygwin_conv_to_posix_path(s, posix_s); - s = posix_s; - #endif /* CYGWIN */ - q = s; fp.ext = p = s + strlen(s); while (--p >= s) { diff --git a/src/common/identify.c b/src/common/identify.c index a1b7038..a9e4319 100644 --- a/src/common/identify.c +++ b/src/common/identify.c @@ -1,7 +1,5 @@ #include "../h/gsupport.h" -#undef COMPILER -#define COMPILER 1 /* insure compiler Version number */ #include "../h/version.h" extern char *progname; diff --git a/src/common/infer.c b/src/common/infer.c index 819bf8b..aa38ea8 100644 --- a/src/common/infer.c +++ b/src/common/infer.c @@ -23,8 +23,8 @@ int main(int argc, char *argv[]) { assert (sizeof(int) >= 4); /* need 32-bit ints or better */ assert (sizeof(long) <= 8); /* but can't handle over 64 */ printf("/* generated by infer.c */\n"); - printf("#define IntBits %d\n", 8 * sizeof(int)); - printf("#define WordBits %d\n", 8 * sizeof(void *)); + printf("#define IntBits %d\n", (int) (8 * sizeof(int))); + printf("#define WordBits %d\n", (int) (8 * sizeof(void *))); if (offsetof(tstruct, d) > sizeof(void *)) printf("#define Double\n"); if (atdepth(2) > atdepth(1)) diff --git a/src/common/ipp.c b/src/common/ipp.c index 8913ee5..36a0990 100644 --- a/src/common/ipp.c +++ b/src/common/ipp.c @@ -18,7 +18,7 @@ * ppinit(fname,inclpath,m4flag) -- open input file * ppdef(s,v) -- "$define s v", or "$undef s" if v is a null pointer * ppch() -- return next preprocessed character - * ppecho() -- preprocess to stdout (for icont/iconc -E) + * ppecho() -- preprocess to stdout (for icont -E) * * See ../h/features.h for the set of predefined symbols. */ @@ -115,7 +115,7 @@ static char *lpath; /* LPATH for finding source files */ static int ifdepth; /* depth of $if nesting */ -extern int tfatals, nocode; /* provided by icont, iconc */ +extern int tfatals, nocode; /* provided by icont */ /* * ppinit(fname, inclpath, m4) -- initialize preprocessor to read from fname. diff --git a/src/common/munix.c b/src/common/munix.c index 132f397..f7dc6d0 100644 --- a/src/common/munix.c +++ b/src/common/munix.c @@ -29,12 +29,6 @@ char *relfile(char *prog, char *mod) { if (baseloc[0] == 0) { /* if argv[0] not already found */ - #if CYGWIN - char posix_prog[_POSIX_PATH_MAX + 1]; - cygwin_conv_to_posix_path(prog, posix_prog); - prog = posix_prog; - #endif /* CYGWIN */ - if (findexe(prog, baseloc, sizeof(baseloc)) == NULL) { fprintf(stderr, "cannot find location of %s\n", prog); exit(EXIT_FAILURE); @@ -102,14 +96,6 @@ char *findonpath(char *name, char *buf, size_t len) { if (path == NULL || *path == '\0') path = "."; - #if CYGWIN - else { - char *posix_path; - posix_path = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); - cygwin_win32_to_posix_path_list(path, posix_path); - path = posix_path; - } - #endif /* CYGWIN */ end = path + strlen(path); for (next = path; next <= end; next = sep + 1) { diff --git a/src/common/pscript.icn b/src/common/pscript.icn index d9b2ee7..10d10d2 100644 --- a/src/common/pscript.icn +++ b/src/common/pscript.icn @@ -6,11 +6,7 @@ procedure sws() return tab( many( ' \t' ) ) | "" end -$ifdef _CYGWIN - $define YY_STATE "yystate" -$else # _CYGWIN - $define YY_STATE "yy_state" -$endif # _CYGWIN +$define YY_STATE "yy_state" procedure main() local line, prefix diff --git a/src/common/rswitch.c b/src/common/rswitch.c new file mode 100644 index 0000000..9373b4e --- /dev/null +++ b/src/common/rswitch.c @@ -0,0 +1,173 @@ +/* + * rswitch.c -- context switch code using POSIX threads and semaphores + * + * This code implements co-expression context switching on any system that + * provides POSIX threads and semaphores. + * + * Anonymous semaphores are used unless NamedSemaphores is defined. + * (This is for MacOS which does not have anonymous semaphores.) + */ + +#include <fcntl.h> +#include <limits.h> +#include <pthread.h> +#include <semaphore.h> +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <sys/stat.h> + +#include "../h/define.h" + +extern void new_context(int, void *); +extern void syserr(char *msg); +extern void *alloc(unsigned int n); + +extern long stksize; /* value of COEXPSIZE */ + +static int inited = 0; /* has first-time initialization been done? */ +static pthread_attr_t attribs; /* thread creation attributes */ + +/* + * Define a "context" struct to hold the thread information we need. + */ +typedef struct { + pthread_t thread; /* thread ID (thread handle) */ + sem_t sema; /* synchronization semaphore (if unnamed) */ + sem_t *semp; /* pointer to semaphore */ + int alive; /* set zero when thread is to die */ + } context; + +static void makesem(context *ctx); +static void *nctramp(void *arg); +static void uerror(char *msg); + +/* + * Treat an Icon "cstate" array as an array of context pointers. + * cstate[0] is used by Icon code that thinks it's setting a stack pointer. + * We use cstate[1] to point to the actual context struct. + * (Both of these are initialized to NULL by Icon 9.4.1 or later.) + */ +typedef context **cstate; + +/* + * coswitch(old, new, first) -- switch contexts. + */ +int coswitch(void *o, void *n, int first) { + + cstate ocs = o; /* old cstate pointer */ + cstate ncs = n; /* new cstate pointer */ + context *old, *new; /* old and new context pointers */ + size_t newsize; /* stack size for new thread */ + size_t pagesize; /* system page size */ + + if (inited) /* if not first call */ + old = ocs[1]; /* load current context pointer */ + else { + /* + * This is the first coswitch() call. + * Allocate and initialize the context struct for &main. + */ + old = ocs[1] = alloc(sizeof(context)); + makesem(old); + old->thread = pthread_self(); + old->alive = 1; + + /* + * Set up thread attributes to honor COEXPSIZE for setting stack size. + */ + pagesize = sysconf(_SC_PAGESIZE); + newsize = stksize; + #ifdef PTHREAD_STACK_MIN + if (newsize < PTHREAD_STACK_MIN) /* ensure system minimum is met */ + newsize = PTHREAD_STACK_MIN; + #endif + if (pagesize > 0 && (newsize % pagesize) != 0) { + /* some systems require an exact multiple of the system page size */ + newsize = newsize + pagesize - (newsize % pagesize); + } + pthread_attr_init(&attribs); + if (pthread_attr_setstacksize(&attribs, newsize) != 0) { + uerror("cannot set stacksize for thread"); + } + + inited = 1; + } + + if (first != 0) /* if not first call for this cstate */ + new = ncs[1]; /* load new context pointer */ + else { + /* + * This is a newly allocated cstate array. + * Allocate and initialize a context struct. + */ + new = ncs[1] = alloc(sizeof(context)); + makesem(new); + if (pthread_create(&new->thread, &attribs, nctramp, new) != 0) + uerror("cannot create thread"); + new->alive = 1; + } + + sem_post(new->semp); /* unblock the new thread */ + sem_wait(old->semp); /* block this thread */ + + if (!old->alive) + pthread_exit(NULL); /* if unblocked because unwanted */ + return 0; /* else return to continue running */ + } + +/* + * coclean(old) -- clean up co-expression state before freeing. + */ +void coclean(void *o) { + cstate ocs = o; /* old cstate pointer */ + context *old = ocs[1]; /* old context pointer */ + if (old == NULL) /* if never initialized, do nothing */ + return; + old->alive = 0; /* signal thread to exit */ + sem_post(old->semp); /* unblock it */ + pthread_join(old->thread, NULL); /* wait for thread to exit */ + #ifdef NamedSemaphores + sem_close(old->semp); /* close associated semaphore */ + #else + sem_destroy(old->semp); /* destroy associated semaphore */ + #endif + free(old); /* free context block */ + } + +/* + * makesem(ctx) -- initialize semaphore in context struct. + */ +static void makesem(context *ctx) { + #ifdef NamedSemaphores /* if cannot use unnamed semaphores */ + char name[50]; + sprintf(name, "i%ld.sem", (long)getpid()); + ctx->semp = sem_open(name, O_CREAT, S_IRUSR | S_IWUSR, 0); + if (ctx->semp == (sem_t *)SEM_FAILED) + uerror("cannot create semaphore"); + sem_unlink(name); + #else /* NamedSemaphores */ + if (sem_init(&ctx->sema, 0, 0) == -1) + uerror("cannot init semaphore"); + ctx->semp = &ctx->sema; + #endif /* NamedSemaphores */ + } + +/* + * nctramp() -- trampoline for calling new_context(0,0). + */ +static void *nctramp(void *arg) { + context *new = arg; /* new context pointer */ + sem_wait(new->semp); /* wait for signal */ + new_context(0, 0); /* call new_context; will not return */ + syserr("new_context returned to nctramp"); + return NULL; + } + +/* + * uerror(s) -- abort due to Unix error. + */ +static void uerror(char *msg) { + perror(msg); + syserr(NULL); + } diff --git a/src/common/rtdb.c b/src/common/rtdb.c index 5467244..d656d29 100644 --- a/src/common/rtdb.c +++ b/src/common/rtdb.c @@ -1066,9 +1066,6 @@ static struct il_c *db_ilc() case 'g': db_chstr("$cg", "oto"); *nxtp = new_ilc(ILC_CGto); -#ifdef MultiThread - #undef code -#endif /* MultiThead */ (*nxtp)->code[0] = db_ilc(); c = getc(db); SkipWhSp(c); diff --git a/src/common/yylex.h b/src/common/yylex.h index 9850417..37643f5 100644 --- a/src/common/yylex.h +++ b/src/common/yylex.h @@ -2,14 +2,10 @@ * yylex.h -- the lexical analyzer. * * This source file contains the lexical analyzer, yylex(), and its - * support routines. It is built by inclusion in ../icont/tlex.c and - * ../iconc/clex.c, with slight variations depending on whether "Iconc" - * is defined. + * support routines. It is built by inclusion in ../icont/tlex.c. */ -#if !defined(Iconc) - #include "../h/esctab.h" -#endif /* !Iconc */ +#include "../h/esctab.h" /* * Prototypes. @@ -23,11 +19,9 @@ static struct toktab *getstring (int ac,int *cc); static int setfilenm (int c); static int setlineno (void); -#if !defined(Iconc) - static int ctlesc (void); - static int hexesc (void); - static int octesc (int ac); -#endif /* !Iconc */ +static int ctlesc (void); +static int hexesc (void); +static int octesc (int ac); #define isletter(s) (isupper(c) | islower(c)) #define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) @@ -399,16 +393,6 @@ int *cc; c = NextChar; if (c == EOF) break; - -#if defined(Iconc) - AppChar(lex_sbuf, Escape); - if (c == '^') { - c = NextChar; - if (c == EOF) - break; - AppChar(lex_sbuf, '^'); - } -#else /* Iconc */ if (isoctal(c)) c = octesc(c); else if (c == 'x') @@ -417,9 +401,8 @@ int *cc; c = ctlesc(); else c = esctab[c]; -#endif /* Iconc */ - } + AppChar(lex_sbuf, c); c = NextChar; @@ -451,8 +434,6 @@ int *cc; } } -#if !defined(Iconc) - /* * ctlesc - translate a control escape -- backslash followed by * caret and one character. @@ -523,8 +504,6 @@ static int hexesc() return c; } - -#endif /* !Iconc */ /* * setlineno - set line number from #line comment, return following char. diff --git a/src/h/config.h b/src/h/config.h index bc48ada..2045dd7 100644 --- a/src/h/config.h +++ b/src/h/config.h @@ -9,70 +9,14 @@ /* * A number of symbols are defined here. * Some enable or disable certain Icon features, for example: - * NoCoexpr disables co-expressions * LoadFunc enables dynamic loading * - * Other definitions may occur for different configurations. These include: - * DeBug debugging code - * MultiThread support for multiple programs under the interpreter - * * Many definitions reflect remnants of past research projects. * Changing them to values not used in standard configurations * may result in an unbuildable or nonfunctioning system. */ /* - * If COMPILER is not defined, code for the interpreter is compiled. - */ - -#ifndef COMPILER - #define COMPILER 0 -#endif - -/* - * The following definitions serve to cast common conditionals is - * a positive way, while allowing defaults for the cases that - * occur most frequently. That is, if co-expressions are not supported, - * NoCoexpr is defined in define.h, but if they are supported, no - * definition is needed in define.h; nonetheless subsequent conditionals - * can be cast as #ifdef Coexpr. - */ - -#ifndef NoCoexpr - #undef Coexpr - #define Coexpr -#endif /* NoCoexpr */ - -#ifdef NoCoexpr - #undef MultiThread - #undef EventMon - #undef Eve -#endif /* NoCoexpr */ - -#if COMPILER - #undef Eve - #undef MultiThread - #undef EventMon -#endif /* COMPILER */ - -#ifdef Eve - #undef EventMon - #undef MultiThread - #define EventMon - #define MultiThread -#endif /* Eve */ - -#ifndef NoLargeInts - #undef LargeInts - #define LargeInts -#endif /* NoLargeInts */ - -#ifdef EventMon - #undef MultiThread - #define MultiThread -#endif /* EventMon */ - -/* * Graphics definitions. */ #ifdef Graphics @@ -99,14 +43,9 @@ #undef Polling #define Polling - #ifndef ICONC_XLIB - #ifdef WinGraphics - #define ICONC_XLIB "-luser32 -lgdi32 -lcomdlg32 -lwinmm" - #else /* WinGraphics */ - #define ICONC_XLIB "-L/usr/X11R6/lib -lX11" - #endif /* WinGraphics */ - #endif /* ICONC_XLIB */ - +#else /* Graphics */ + #undef XWindows + #undef WinGraphics #endif /* Graphics */ /* @@ -123,15 +62,6 @@ * Other defaults. */ -#ifdef DeBug - #undef DeBugTrans - #undef DeBugLinker - #undef DeBugIconx - #define DeBugTrans - #define DeBugLinker - #define DeBugIconx -#endif /* DeBug */ - #ifndef MaxHdr /* * Maximum allowable BinaryHeader size. @@ -141,7 +71,7 @@ #endif /* MaxHdr */ #ifndef MaxPath - #define MaxPath 256 + #define MaxPath 512 #endif /* MaxPath */ #ifndef SourceSuffix @@ -206,18 +136,10 @@ #define DBSuffix ".db" #endif /* DBSuffix */ -#ifndef PPInit - #define PPInit "" -#endif /* PPInit */ - #ifndef PPDirectives #define PPDirectives {"passthru", PpKeep}, #endif /* PPDirectives */ -#ifndef NoSrcColumnInfo - #define SrcColumnInfo -#endif /* NoSrcColumnInfo */ - #ifndef ExecSuffix #define ExecSuffix "" #endif /* ExecSuffix */ @@ -226,66 +148,34 @@ #define CSuffix ".c" #endif /* CSuffix */ -#ifndef HSuffix - #define HSuffix ".h" -#endif /* HSuffix */ - -#ifndef ObjSuffix - #define ObjSuffix ".o" -#endif /* ObjSuffix */ - -#ifndef LibSuffix - #define LibSuffix ".a" -#endif /* LibSuffix */ - -#ifndef CComp - #define CComp "cc" -#endif /* CComp */ - -#ifndef COpts - #define COpts "" -#endif /* COpts */ - /* * Note, size of the hash table is a power of 2: */ #define IHSize 128 #define IHasher(x) (((unsigned int)(unsigned long)(x))&(IHSize-1)) -#if COMPILER - - /* - * Code for the compiler. - */ - #undef MultiThread /* no way -- interpreter only */ - #undef EventMon /* presently not supported in the compiler */ - -#else /* COMPILER */ - - /* - * Code for the interpreter. - */ - #ifndef IcodeSuffix - #define IcodeSuffix "" - #endif /* IcodeSuffix */ - - #ifndef IcodeASuffix - #define IcodeASuffix "" - #endif /* IcodeASuffix */ +/* + * Code for the interpreter. + */ +#ifndef IcodeSuffix + #define IcodeSuffix "" +#endif /* IcodeSuffix */ - #ifndef U1Suffix - #define U1Suffix ".u1" - #endif /* U1Suffix */ +#ifndef IcodeASuffix + #define IcodeASuffix "" +#endif /* IcodeASuffix */ - #ifndef U2Suffix - #define U2Suffix ".u2" - #endif /* U2Suffix */ +#ifndef U1Suffix + #define U1Suffix ".u1" +#endif /* U1Suffix */ - #ifndef USuffix - #define USuffix ".u" - #endif /* USuffix */ +#ifndef U2Suffix + #define U2Suffix ".u2" +#endif /* U2Suffix */ -#endif /* COMPILER */ +#ifndef USuffix + #define USuffix ".u" +#endif /* USuffix */ /* * Vsizeof is for use with variable-sized (i.e., indefinite) diff --git a/src/h/cpuconf.h b/src/h/cpuconf.h index 228ce6b..acd0194 100644 --- a/src/h/cpuconf.h +++ b/src/h/cpuconf.h @@ -4,10 +4,6 @@ * included before this file. */ -#ifndef CStateSize - #define CStateSize 15 /* size of C state for co-expressions */ -#endif /* CStateSize */ - /* * The following definitions depend on the sizes of ints and pointers. */ @@ -215,11 +211,7 @@ #endif /* MinAbrSize */ #ifndef MStackSize - #ifdef MultiThread - #define MStackSize 20000 /* size of the main stack in words */ - #else /* MultiThread */ - #define MStackSize 10000 /* size of the main stack in words */ - #endif /* MultiThread */ + #define MStackSize 10000 /* size of the main stack in words */ #endif /* MStackSize */ #ifndef StackSize @@ -231,11 +223,7 @@ #endif /* QualLstSize */ #ifndef ActStkBlkEnts - #ifdef Coexpr - #define ActStkBlkEnts 25 /* number of entries in an astkblk */ - #else /* Coexpr */ - #define ActStkBlkEnts 1 /* number of entries in an astkblk */ - #endif /* Coexpr */ + #define ActStkBlkEnts 25 /* number of entries in an astkblk */ #endif /* ActStkBlkEnts */ #ifndef RegionCushion diff --git a/src/h/fdefs.h b/src/h/fdefs.h index 8f35509..c5a36fc 100644 --- a/src/h/fdefs.h +++ b/src/h/fdefs.h @@ -20,6 +20,7 @@ FncDef(cset,1) FncDef(delay,1) FncDef(delete,2) FncDefV(detab) +FncDef(display,2) FncDef(dtor,1) FncDefV(entab) FncDef(errorclear,0) @@ -47,10 +48,12 @@ FncDef(map,3) FncDef(match,4) FncDef(member,1) FncDef(move,1) +FncDef(name,1) FncDef(numeric,1) FncDef(ord,1) FncDef(pop,1) FncDef(pos,1) +FncDef(proc,2) FncDef(pull,1) FncDefV(push) FncDefV(put) @@ -81,6 +84,7 @@ FncDef(tan,1) FncDef(trim,2) FncDef(type,1) FncDef(upto,4) +FncDef(variable,1) FncDef(where,1) FncDefV(write) FncDefV(writes) @@ -91,18 +95,6 @@ FncDefV(writes) FncDef(open,3) #endif /* Graphics */ -#ifdef MultiThread - FncDef(display,3) - FncDef(name,2) - FncDef(proc,3) - FncDef(variable,3) -#else /* MultiThread */ - FncDef(display,2) - FncDef(name,1) - FncDef(proc,2) - FncDef(variable,1) -#endif /* MultiThread */ - /* * Dynamic loading. */ @@ -111,13 +103,6 @@ FncDefV(writes) #endif /* LoadFunc */ /* - * External functions. - */ -#ifdef ExternalFunctions - FncDefV(callout) -#endif /* ExternalFunctions */ - -/* * File attribute function. */ #ifdef FAttrib @@ -134,16 +119,6 @@ FncDefV(writes) #endif /* KeyboardFncs */ /* - * Event processing functions. - */ -#ifdef EventMon - FncDef(EvGet,2) - FncDef(event,3) - FncDef(eventmask,2) - FncDef(opmask,2) -#endif /* EventMon */ - -/* * Graphics functions. */ #ifdef Graphics @@ -211,22 +186,3 @@ FncDefV(writes) FncDefV(WinSelectDialog) #endif /* WinExtns */ #endif /* Graphics */ - -#ifdef MultiThread - /* - * These functions are part of the MultiThread extensions. - */ - FncDef(cofail,1) - FncDef(globalnames,1) - FncDef(fieldnames,1) - FncDef(localnames,2) - FncDef(staticnames,2) - FncDef(paramnames,2) - FncDef(structure,1) - /* - * These functions are inherent to MultiThread and multiple Icon programs - */ - FncDefV(load) - FncDef(parent,1) - FncDef(keyword,2) -#endif /* MultiThread */ diff --git a/src/h/features.h b/src/h/features.h index 047b4df..b22633a 100644 --- a/src/h/features.h +++ b/src/h/features.h @@ -18,6 +18,14 @@ Feature(1, "_V9", 0) /* Version 9 (unconditional) */ +#if UNIX + Feature(1, "_UNIX", "UNIX") +#endif /* UNIX */ + +#if MACINTOSH + Feature(1, "_MACINTOSH", "Macintosh") +#endif /* MACINTOSH */ + #if MSWIN Feature(1, "_MS_WINDOWS", "MS Windows") #endif /* MSWIN */ @@ -26,15 +34,9 @@ Feature(1, "_CYGWIN", "Cygwin") #endif /* CYGWIN */ -#if UNIX - Feature(1, "_UNIX", "UNIX") -#endif /* UNIX */ - Feature(1, "_ASCII", "ASCII") -#ifdef Coexpr Feature(1, "_CO_EXPRESSIONS", "co-expressions") -#endif /* Coexpr */ #ifdef LoadFunc Feature(1, "_DYNAMIC_LOADING", "dynamic loading") @@ -42,25 +44,15 @@ Feature(1, "", "environment variables") -#ifdef EventMon - Feature(1, "_EVENT_MONITOR", "event monitoring") -#endif /* EventMon */ - -#ifdef ExternalFunctions - Feature(1, "_EXTERNAL_FUNCTIONS", "external functions") -#endif /* ExternalFunctions */ +#ifdef LoadFunc + Feature(1, "_EXTERNAL_VALUES", "external values") +#endif /* LoadFunc */ #ifdef KeyboardFncs Feature(1, "_KEYBOARD_FUNCTIONS", "keyboard functions") #endif /* KeyboardFncs */ -#ifdef LargeInts Feature(largeints, "_LARGE_INTEGERS", "large integers") -#endif /* LargeInts */ - -#ifdef MultiThread - Feature(1, "_MULTITASKING", "multiple programs") -#endif /* MultiThread */ #ifdef Pipes Feature(1, "_PIPES", "pipes") diff --git a/src/h/grttin.h b/src/h/grttin.h index 1247ca2..4a0be07 100644 --- a/src/h/grttin.h +++ b/src/h/grttin.h @@ -72,63 +72,6 @@ */ #define Protect(notnull,orelse) do {if ((notnull)==NULL) orelse;} while(0) -#ifdef EventMon -/* - * perform what amounts to "function inlining" of EVVal - */ -#begdef EVVal(value,event) - do { - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - MakeInt(value, &(curpstate->parent->eventval)); - actparent(event); - } while (0) -#enddef /* EVVal */ -#begdef EVValD(dp,event) - do { - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - curpstate->parent->eventval = *(dp); - actparent(event); - } while (0) -#enddef /* EVValD */ -#begdef EVValX(bp,event) - do { - struct progstate *parent = curpstate->parent; - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - parent->eventval.dword = D_Coexpr; - BlkLoc(parent->eventval) = (union block *)(bp); - actparent(event); - } while (0) -#enddef /* EVValX */ - -#define InterpEVVal(arg1,arg2) { ExInterp; EVVal(arg1,arg2); EntInterp; } -#define InterpEVValD(arg1,arg2) { ExInterp; EVValD(arg1,arg2); EntInterp; } -#define InterpEVValX(arg1,arg2) { ExInterp; EVValX(arg1,arg2); EntInterp; } - -/* - * Macro with construction of event descriptor. - */ - -#begdef Desc_EVValD(bp, code, type) - do { - eventdesc.dword = type; - eventdesc.vword.bptr = (union block *)(bp); - EVValD(&eventdesc, code); - } while (0) -#enddef /* Desc_EVValD */ - -#else /* EventMon */ - #define EVVal(arg1,arg2) - #define EVValD(arg1,arg2) - #define EVValX(arg1,arg2) - #define InterpEVVal(arg1,arg2) - #define InterpEVValD(arg1,arg2) - #define InterpEVValX(arg1,arg2) - #define Desc_EVValD(bp, code, type) -#endif /* EventMon */ - /* * dummy typedefs for things defined in #include files */ diff --git a/src/h/header.h b/src/h/header.h index 3b131f1..6c9e3f4 100644 --- a/src/h/header.h +++ b/src/h/header.h @@ -15,14 +15,6 @@ struct header { word Strcons; /* location of identifier table */ word Filenms; /* location of ipc/file name table */ - #ifdef FieldTableCompression - short FtabWidth; /* width of field table entries, 1 | 2 | 4 */ - short FoffWidth; /* width of field offset entries, 1 | 2 | 4 */ - word Nfields; /* number of field names */ - word Fo; /* The start of the Fo array */ - word Bm; /* The start of the Bm array */ - #endif /* FieldTableCompression */ - word linenums; /* location of ipc/line number table */ word config[16]; /* icode version */ }; diff --git a/src/h/monitor.h b/src/h/monitor.h deleted file mode 100644 index e359e9e..0000000 --- a/src/h/monitor.h +++ /dev/null @@ -1,213 +0,0 @@ -/* - * This file contains definitions for the various event codes and values - * that go to make up event streams. - */ - -/* - * Note: the blank character should *not* be used as an event code. - */ - -#ifdef EventMon - -/* - * Allocation events use lowercase codes. - */ -#define E_Lrgint '\114' /* Large integer allocation */ -#define E_Real '\144' /* Real allocation */ -#define E_Cset '\145' /* Cset allocation */ -#define E_File '\147' /* File allocation */ -#define E_Record '\150' /* Record allocation */ -#define E_Tvsubs '\151' /* Substring tv allocation */ -#define E_External '\152' /* External allocation */ -#define E_List '\153' /* List allocation */ -#define E_Lelem '\155' /* List element allocation */ -#define E_Table '\156' /* Table allocation */ -#define E_Telem '\157' /* Table element allocation */ -#define E_Tvtbl '\160' /* Table-element tv allocation */ -#define E_Set '\161' /* Set allocation */ -#define E_Selem '\164' /* Set element allocation */ -#define E_Slots '\167' /* Hash header allocation */ -#define E_Coexpr '\170' /* Co-expression allocation */ -#define E_Refresh '\171' /* Refresh allocation */ -#define E_Alien '\172' /* Alien allocation */ -#define E_Free '\132' /* Free region */ -#define E_String '\163' /* String allocation */ - -/* - * Some other monitoring codes. - */ -#define E_BlkDeAlc '\055' /* Block deallocation */ -#define E_StrDeAlc '\176' /* String deallocation */ - -/* - * These are not "events"; they are provided for uniformity in tools - * that deal with types. - */ -#define E_Integer '\100' /* Integer value pseudo-event */ -#define E_Null '\044' /* Null value pseudo-event */ -#define E_Proc '\045' /* Procedure value pseudo-event */ -#define E_Kywdint '\136' /* Integer keyword value pseudo-event */ -#define E_Kywdpos '\046' /* Position value pseudo-event */ -#define E_Kywdsubj '\052' /* Subject value pseudo-event */ - -/* - * Codes for main sequence events - */ - - /* - * Timing events - */ -#define E_Tick '\056' /* Clock tick */ - - /* - * Code-location event - */ -#define E_Loc '\174' /* Location change */ -#define E_Line '\355' /* Line change */ - - /* - * Virtual-machine instructions - */ -#define E_Opcode '\117' /* Virtual-machine instruction */ - - /* - * Type-conversion events - */ -#define E_Aconv '\111' /* Conversion attempt */ -#define E_Tconv '\113' /* Conversion target */ -#define E_Nconv '\116' /* Conversion not needed */ -#define E_Sconv '\121' /* Conversion success */ -#define E_Fconv '\112' /* Conversion failure */ - - /* - * Structure events - */ -#define E_Lbang '\301' /* List generation */ -#define E_Lcreate '\302' /* List creation */ -#define E_Lget '\356' /* List get/pop -- only E_Lget used */ -#define E_Lpop '\356' /* List get/pop */ -#define E_Lpull '\304' /* List pull */ -#define E_Lpush '\305' /* List push */ -#define E_Lput '\306' /* List put */ -#define E_Lrand '\307' /* List random reference */ -#define E_Lref '\310' /* List reference */ -#define E_Lsub '\311' /* List subscript */ -#define E_Rbang '\312' /* Record generation */ -#define E_Rcreate '\313' /* Record creation */ -#define E_Rrand '\314' /* Record random reference */ -#define E_Rref '\315' /* Record reference */ -#define E_Rsub '\316' /* Record subscript */ -#define E_Sbang '\317' /* Set generation */ -#define E_Screate '\320' /* Set creation */ -#define E_Sdelete '\321' /* Set deletion */ -#define E_Sinsert '\322' /* Set insertion */ -#define E_Smember '\323' /* Set membership */ -#define E_Srand '\336' /* Set random reference */ -#define E_Sval '\324' /* Set value */ -#define E_Tbang '\325' /* Table generation */ -#define E_Tcreate '\326' /* Table creation */ -#define E_Tdelete '\327' /* Table deletion */ -#define E_Tinsert '\330' /* Table insertion */ -#define E_Tkey '\331' /* Table key generation */ -#define E_Tmember '\332' /* Table membership */ -#define E_Trand '\337' /* Table random reference */ -#define E_Tref '\333' /* Table reference */ -#define E_Tsub '\334' /* Table subscript */ -#define E_Tval '\335' /* Table value */ - - /* - * Scanning events - */ - -#define E_Snew '\340' /* Scanning environment creation */ -#define E_Sfail '\341' /* Scanning failure */ -#define E_Ssusp '\342' /* Scanning suspension */ -#define E_Sresum '\343' /* Scanning resumption */ -#define E_Srem '\344' /* Scanning environment removal */ -#define E_Spos '\346' /* Scanning position */ - - /* - * Assignment - */ - -#define E_Assign '\347' /* Assignment */ -#define E_Value '\350' /* Value assigned */ - - /* - * Sub-string assignment - */ - -#define E_Ssasgn '\354' /* Sub-string assignment */ - /* - * Interpreter stack events - */ - -#define E_Intcall '\351' /* interpreter call */ -#define E_Intret '\352' /* interpreter return */ -#define E_Stack '\353' /* stack depth */ - - /* - * Expression events - */ -#define E_Ecall '\143' /* Call of operation */ -#define E_Efail '\146' /* Failure from expression */ -#define E_Bsusp '\142' /* Suspension from operation */ -#define E_Esusp '\141' /* Suspension from alternation */ -#define E_Lsusp '\154' /* Suspension from limitation */ -#define E_Eresum '\165' /* Resumption of expression */ -#define E_Erem '\166' /* Removal of a suspended generator */ - - /* - * Co-expression events - */ - -#define E_Coact '\101' /* Co-expression activation */ -#define E_Coret '\102' /* Co-expression return */ -#define E_Cofail '\104' /* Co-expression failure */ - - /* - * Procedure events - */ - -#define E_Pcall '\103' /* Procedure call */ -#define E_Pfail '\106' /* Procedure failure */ -#define E_Pret '\122' /* Procedure return */ -#define E_Psusp '\123' /* Procedure suspension */ -#define E_Presum '\125' /* Procedure resumption */ -#define E_Prem '\126' /* Suspended procedure removal */ - -#define E_Fcall '\072' /* Function call */ -#define E_Ffail '\115' /* Function failure */ -#define E_Fret '\120' /* Function return */ -#define E_Fsusp '\127' /* Function suspension */ -#define E_Fresum '\131' /* Function resumption */ -#define E_Frem '\133' /* Function suspension removal */ - -#define E_Ocall '\134' /* Operator call */ -#define E_Ofail '\135' /* Operator failure */ -#define E_Oret '\140' /* Operator return */ -#define E_Osusp '\173' /* Operator suspension */ -#define E_Oresum '\175' /* Operator resumption */ -#define E_Orem '\177' /* Operator suspension removal */ - - /* - * Garbage collections - */ - -#define E_Collect '\107' /* Garbage collection */ -#define E_EndCollect '\360' /* End of garbage collection */ -#define E_TenureString '\361' /* Tenure a string region */ -#define E_TenureBlock '\362' /* Tenure a block region */ - -/* - * Termination Events - */ -#define E_Error '\105' /* Run-time error */ -#define E_Exit '\130' /* Program exit */ - - /* - * I/O events - */ -#define E_MXevent '\370' /* monitor input event */ - -#endif /* EventMon */ diff --git a/src/h/mswin.h b/src/h/mswin.h index 2734cb1..a16ab8a 100644 --- a/src/h/mswin.h +++ b/src/h/mswin.h @@ -132,8 +132,8 @@ } #define EVQUEEMPTY(ws) (BlkLoc((ws)->listp)->list.size == 0) -#define SHARED 0 -#define MUTABLE 1 +#define CSHARED 0 +#define CMUTABLE 1 #define MAXCOLORNAME 40 /* * color structure, inspired by X code (xwin.h) @@ -142,7 +142,7 @@ typedef struct wcolor { int refcount; char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ SysColor c; - int type; /* SHARED or MUTABLE */ + int type; /* CSHARED or CMUTABLE */ } *wclrp; /* diff --git a/src/h/rexterns.h b/src/h/rexterns.h index 804424c..026bdaa 100644 --- a/src/h/rexterns.h +++ b/src/h/rexterns.h @@ -56,133 +56,91 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ /* * Externals that are conditional on features. */ -#ifdef FncTrace - extern struct descrip kywd_ftrc; /* descriptor for &ftrace */ -#endif /* FncTrace */ - #ifdef Polling extern int pollctr; #endif /* Polling */ -#ifdef EventMon - extern char typech[]; - extern word oldsum; - extern struct descrip csetdesc; /* cset descriptor */ - extern struct descrip eventdesc; /* event descriptor */ - extern struct b_iproc mt_llist; - extern struct descrip rzerodesc; /* real descriptor */ - extern struct b_real realzero; /* real zero block */ -#endif /* EventMon */ - /* - * Externals conditional on multithreading. + * Externals that were conditional on multithreading. */ - extern struct region rootstring; - extern struct region rootblock; -#ifndef MultiThread - extern dptr glbl_argp; /* argument pointer */ - extern struct region *curstring; - extern struct region *curblock; - extern struct descrip k_current; /* ¤t */ - extern char *k_errortext; /* value of &errortext */ - extern int have_errval; /* &errorvalue has a legal value */ - extern int k_errornumber; /* value of &errornumber */ - extern int t_errornumber; /* tentative k_errornumber value */ - extern int t_have_val; /* tentative have_errval flag */ - extern struct b_file k_errout; /* value of &errout */ - extern struct b_file k_input; /* value of &input */ - extern struct b_file k_output; /* value of &output */ - extern struct descrip k_errorvalue; /* value of &errorvalue */ - extern struct descrip kywd_err; /* &error */ - extern struct descrip kywd_pos; /* descriptor for &pos */ - extern struct descrip kywd_prog; /* descriptor for &prog */ - extern struct descrip kywd_ran; /* descriptor for &random */ - extern struct descrip k_subject; /* &subject */ - extern struct descrip kywd_trc; /* descriptor for &trace */ - extern struct descrip k_eventcode; /* &eventcode */ - extern struct descrip k_eventsource; /* &eventsource */ - extern struct descrip k_eventvalue; /* &eventvalue */ - extern struct descrip k_main; /* value of &main */ - extern struct descrip t_errorvalue; /* tentative k_errorvalue value */ - extern uword blktotal; /* cumul total of all block allocs */ - extern uword strtotal; /* cumul total of all string allocs */ - extern word coll_tot; /* total number of collections */ - extern word coll_stat; /* collections from static reqests */ - extern word coll_str; /* collections from string requests */ - extern word coll_blk; /* collections from block requests */ - extern dptr globals; /* start of global variables */ - extern dptr eglobals; /* end of global variables */ - extern dptr gnames; /* start of global variable names */ - extern dptr egnames; /* end of global variable names */ - extern dptr estatics; /* end of static variables */ - extern int n_globals; /* number of global variables */ - extern int n_statics; /* number of static variables */ - extern struct b_coexpr *mainhead; /* &main */ -#endif /* MultiThread */ +extern struct region rootstring; +extern struct region rootblock; +extern dptr glbl_argp; /* argument pointer */ +extern struct region *curstring; +extern struct region *curblock; +extern struct descrip k_current; /* ¤t */ +extern char *k_errortext; /* value of &errortext */ +extern int have_errval; /* &errorvalue has a legal value */ +extern int k_errornumber; /* value of &errornumber */ +extern int t_errornumber; /* tentative k_errornumber value */ +extern int t_have_val; /* tentative have_errval flag */ +extern struct b_file k_errout; /* value of &errout */ +extern struct b_file k_input; /* value of &input */ +extern struct b_file k_output; /* value of &output */ +extern struct descrip k_errorvalue; /* value of &errorvalue */ +extern struct descrip kywd_err; /* &error */ +extern struct descrip kywd_pos; /* descriptor for &pos */ +extern struct descrip kywd_prog; /* descriptor for &prog */ +extern struct descrip kywd_ran; /* descriptor for &random */ +extern struct descrip k_subject; /* &subject */ +extern struct descrip kywd_trc; /* descriptor for &trace */ +extern struct descrip k_eventcode; /* &eventcode */ +extern struct descrip k_eventsource; /* &eventsource */ +extern struct descrip k_eventvalue; /* &eventvalue */ +extern struct descrip k_main; /* value of &main */ +extern struct descrip t_errorvalue; /* tentative k_errorvalue value */ +extern uword blktotal; /* cumul total of all block allocs */ +extern uword strtotal; /* cumul total of all string allocs */ +extern word coll_tot; /* total number of collections */ +extern word coll_stat; /* collections from static reqests */ +extern word coll_str; /* collections from string requests */ +extern word coll_blk; /* collections from block requests */ +extern dptr globals; /* start of global variables */ +extern dptr eglobals; /* end of global variables */ +extern dptr gnames; /* start of global variable names */ +extern dptr egnames; /* end of global variable names */ +extern dptr estatics; /* end of static variables */ +extern int n_globals; /* number of global variables */ +extern int n_statics; /* number of static variables */ +extern struct b_coexpr *mainhead; /* &main */ /* - * Externals that differ between compiler and interpreter. + * External declarations that differed for the compiler. */ -#if !COMPILER - /* - * External declarations for the interpreter. - */ - - extern int ixinited; /* iconx has initialized */ - extern inst ipc; /* interpreter program counter */ - extern int ilevel; /* interpreter level */ - extern int ntended; /* number of active tended descriptors*/ - extern struct b_cset k_ascii; /* value of &ascii */ - extern struct b_cset k_cset; /* value of &cset */ - extern struct b_cset k_digits; /* value of &lcase */ - extern struct b_cset k_lcase; /* value of &lcase */ - extern struct b_cset k_letters; /* value of &letters */ - extern struct b_cset k_ucase; /* value of &ucase */ - extern struct descrip tended[]; /* tended descriptors */ - extern struct ef_marker *efp; /* expression frame pointer */ - extern struct gf_marker *gfp; /* generator frame pointer */ - extern struct pf_marker *pfp; /* procedure frame pointer */ - extern word *sp; /* interpreter stack pointer */ - extern word *stack; /* interpreter stack base */ - extern word *stackend; /* end of evaluation stack */ - - extern struct pstrnm pntab[]; - extern int pnsize; - - #ifdef MultiThread - extern struct progstate *curpstate; - extern struct progstate rootpstate; - extern int noMTevents; /* no MT events during GC */ - #else /* MultiThread */ - extern char *code; /* start of icode */ - extern char *ecode; /* end of icode */ - extern dptr statics; /* start of static variables */ - extern char *strcons; /* start of the string constants */ - extern dptr fnames; /* field names */ - extern dptr efnames; /* end of field names */ - extern word *records; - extern int *ftabp; /* field table pointer */ - #ifdef FieldTableCompression - extern word ftabwidth, foffwidth; - extern unsigned char *ftabcp; - extern short *ftabsp; - #endif /* FieldTableCompression */ - extern dptr xargp; - extern word xnargs; - - extern word lastop; - #endif /* MultiThread */ - -#else /* COMPILER */ - - extern struct descrip statics[]; /* array of static variables */ - extern struct b_proc *builtins[]; /* pointers to builtin functions */ - extern int noerrbuf; /* error buffering */ - extern struct p_frame *pfp; /* procedure frame pointer */ - extern struct descrip trashcan; /* dummy descriptor, never read */ - extern int largeints; /* flag: large integers supported */ - -#endif /* COMPILER */ + +extern int ixinited; /* iconx has initialized */ +extern inst ipc; /* interpreter program counter */ +extern int ilevel; /* interpreter level */ +extern int ntended; /* number of active tended descriptors*/ +extern struct b_cset k_ascii; /* value of &ascii */ +extern struct b_cset k_cset; /* value of &cset */ +extern struct b_cset k_digits; /* value of &lcase */ +extern struct b_cset k_lcase; /* value of &lcase */ +extern struct b_cset k_letters; /* value of &letters */ +extern struct b_cset k_ucase; /* value of &ucase */ +extern struct descrip tended[]; /* tended descriptors */ +extern struct ef_marker *efp; /* expression frame pointer */ +extern struct gf_marker *gfp; /* generator frame pointer */ +extern struct pf_marker *pfp; /* procedure frame pointer */ +extern word *sp; /* interpreter stack pointer */ +extern word *stack; /* interpreter stack base */ +extern word *stackend; /* end of evaluation stack */ + +extern struct pstrnm pntab[]; +extern int pnsize; + +extern char *code; /* start of icode */ +extern char *ecode; /* end of icode */ +extern dptr statics; /* start of static variables */ +extern char *strcons; /* start of the string constants */ +extern dptr fnames; /* field names */ +extern dptr efnames; /* end of field names */ +extern word *records; +extern int *ftabp; /* field table pointer */ +extern dptr xargp; +extern word xnargs; + +extern word lastop; /* * graphics @@ -198,7 +156,6 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ extern int win_highwater, canvas_serial, context_serial; extern clock_t starttime; /* start time in milliseconds */ - #ifndef MultiThread extern struct descrip kywd_xwin[]; extern struct descrip lastEventWin; extern int lastEvFWidth, lastEvLeading, lastEvAscent; @@ -208,7 +165,6 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ extern struct descrip amperY; extern struct descrip amperInterval; extern uword xmod_control, xmod_shift, xmod_meta; - #endif /* MultiThread */ #ifdef XWindows extern struct _wdisplay * wdsplys; diff --git a/src/h/rmacros.h b/src/h/rmacros.h index cce26dd..ac9ca64 100644 --- a/src/h/rmacros.h +++ b/src/h/rmacros.h @@ -276,11 +276,7 @@ #define T_String -1 /* string -- for reference; not used */ #define T_Null 0 /* null value */ #define T_Integer 1 /* integer */ - -#ifdef LargeInts - #define T_Lrgint 2 /* long integer */ -#endif /* LargeInts */ - +#define T_Lrgint 2 /* long integer */ #define T_Real 3 /* real number */ #define T_Cset 4 /* cset */ #define T_File 5 /* file */ @@ -316,21 +312,13 @@ #define k_trace kywd_trc.vword.integr /* value of &trace */ #define k_dump kywd_dmp.vword.integr /* value of &dump */ -#ifdef FncTrace - #define k_ftrace kywd_ftrc.vword.integr /* value of &ftrace */ -#endif /* FncTrace */ - /* * Descriptor types and flags. */ #define D_Null (T_Null | D_Typecode) #define D_Integer (T_Integer | D_Typecode) - -#ifdef LargeInts - #define D_Lrgint (T_Lrgint | D_Typecode | F_Ptr) -#endif /* LargeInts */ - +#define D_Lrgint (T_Lrgint | D_Typecode | F_Ptr) #define D_Real (T_Real | D_Typecode | F_Ptr) #define D_Cset (T_Cset | D_Typecode | F_Ptr) #define D_File (T_File | D_Typecode | F_Ptr) @@ -402,284 +390,148 @@ #define blkend (curblock->end) #define blkfree (curblock->free) -#if COMPILER - - #ifdef Graphics - #define Poll() if (!pollctr--) pollctr = pollevent() - #else /* Graphics */ - #define Poll() - #endif /* Graphics */ - -#else /* COMPILER */ - - /* - * Definitions for the interpreter. - */ - - /* - * Codes returned by invoke to indicate action. - */ - #define I_Builtin 201 /* A built-in routine is to be invoked */ - #define I_Fail 202 /* goal-directed evaluation failed */ - #define I_Continue 203 /* Continue execution in the interp loop */ - #define I_Vararg 204 /* A function with a variable number of args */ - - /* - * Generator types. - */ - #define G_Csusp 1 - #define G_Esusp 2 - #define G_Psusp 3 - #define G_Fsusp 4 - #define G_Osusp 5 - - /* - * Evaluation stack overflow margin - */ - #define PerilDelta 100 +/* + * Codes returned by invoke to indicate action. + */ +#define I_Builtin 201 /* A built-in routine is to be invoked */ +#define I_Fail 202 /* goal-directed evaluation failed */ +#define I_Continue 203 /* Continue execution in the interp loop */ +#define I_Vararg 204 /* A function with a variable number of args */ - /* - * Macros for pushing values on the interpreter stack. - */ +/* + * Generator types. + */ +#define G_Csusp 1 +#define G_Esusp 2 +#define G_Psusp 3 +#define G_Fsusp 4 +#define G_Osusp 5 - /* - * Push descriptor. - */ - #define PushDescSP(SP,d) {*++SP=((d).dword); SP++; *SP =((d).vword.integr);} +/* + * Evaluation stack overflow margin + */ +#define PerilDelta 100 - /* - * Push null-valued descriptor. - */ - #define PushNullSP(SP) {*++SP = D_Null; SP++; *SP = 0;} +/* + * Macros for pushing values on the interpreter stack. + */ - /* - * Push word. - */ - #define PushValSP(SP,v) {*++SP = (word)(v);} +/* + * Push descriptor. + */ +#define PushDescSP(SP,d) {*++SP=((d).dword); SP++; *SP =((d).vword.integr);} - /* - * Shorter Versions of the Push*SP macros that assume sp points to the top - * of the stack. - */ - #define PushDesc(d) PushDescSP(sp,d) - #define PushNull PushNullSP(sp) - #define PushVal(x) PushValSP(sp,x) - #define PushAVal(x) PushValSP(sp,x) +/* + * Push null-valued descriptor. + */ +#define PushNullSP(SP) {*++SP = D_Null; SP++; *SP = 0;} - /* - * Macros related to function and operator definition. - */ +/* + * Push word. + */ +#define PushValSP(SP,v) {*++SP = (word)(v);} - /* - * Procedure block for a function. - */ +/* + * Shorter Versions of the Push*SP macros that assume sp points to the top + * of the stack. + */ +#define PushDesc(d) PushDescSP(sp,d) +#define PushNull PushNullSP(sp) +#define PushVal(x) PushValSP(sp,x) +#define PushAVal(x) PushValSP(sp,x) - #define FncBlock(f,nargs,deref) \ - struct b_iproc Cat(B,f) = {\ - T_Proc,\ - Vsizeof(struct b_proc),\ - Cat(Z,f),\ - nargs,\ - -1,\ - deref, 0,\ - {sizeof(Lit(f))-1,Lit(f)}}; +/* + * Macros related to function and operator definition. + */ - /* - * Procedure block for an operator. - */ - #define OpBlock(f,nargs,sname,xtrargs)\ - struct b_iproc Cat(B,f) = {\ - T_Proc,\ - Vsizeof(struct b_proc),\ - Cat(O,f),\ - nargs,\ - -1,\ - xtrargs,\ - 0,\ - {sizeof(sname)-1,sname}}; +/* + * Procedure block for a function. + */ - /* - * Operator declaration. - */ - #define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp; +#define FncBlock(f,nargs,deref) \ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(Z,f),\ + nargs,\ + -1,\ + deref, 0,\ + {sizeof(Lit(f))-1,Lit(f)}}; - /* - * Operator declaration with extra working argument. - */ - #define OpDclE(nm,n,pn) OpBlock(nm,-n,pn,0) Cat(O,nm)(cargp) register dptr cargp; +/* + * Procedure block for an operator. + */ +#define OpBlock(f,nargs,sname,xtrargs)\ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(O,f),\ + nargs,\ + -1,\ + xtrargs,\ + 0,\ + {sizeof(sname)-1,sname}}; - /* - * Agent routine declaration. - */ - #define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp; +/* + * Operator declaration. + */ +#define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp; - /* - * Macros to access Icon arguments in C functions. - */ +/* + * Operator declaration with extra working argument. + */ +#define OpDclE(nm,n,pn) OpBlock(nm,-n,pn,0) Cat(O,nm)(cargp) register dptr cargp; - /* - * n-th argument. - */ - #define Arg(n) (cargp[n]) +/* + * Agent routine declaration. + */ +#define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp; - /* - * Type field of n-th argument. - */ - #define ArgType(n) (cargp[n].dword) +/* + * Macros to access Icon arguments in C functions. + */ - /* - * Value field of n-th argument. - */ - #define ArgVal(n) (cargp[n].vword.integr) +/* + * n-th argument. + */ +#define Arg(n) (cargp[n]) - /* - * Specific arguments. - */ - #define Arg0 (cargp[0]) - #define Arg1 (cargp[1]) - #define Arg2 (cargp[2]) - #define Arg3 (cargp[3]) - #define Arg4 (cargp[4]) - #define Arg5 (cargp[5]) - #define Arg6 (cargp[6]) - #define Arg7 (cargp[7]) - #define Arg8 (cargp[8]) +/* + * Type field of n-th argument. + */ +#define ArgType(n) (cargp[n].dword) - /* - * Miscellaneous macro definitions. - */ +/* + * Value field of n-th argument. + */ +#define ArgVal(n) (cargp[n].vword.integr) - #ifdef MultiThread - #define glbl_argp (curpstate->Glbl_argp) - #define kywd_err (curpstate->Kywd_err) - #define kywd_pos (curpstate->Kywd_pos) - #define kywd_prog (curpstate->Kywd_prog) - #define kywd_ran (curpstate->Kywd_ran) - #define k_eventcode (curpstate->eventcode) - #define k_eventsource (curpstate->eventsource) - #define k_eventvalue (curpstate->eventval) - #define k_subject (curpstate->ksub) - #define kywd_trc (curpstate->Kywd_trc) - #define mainhead (curpstate->Mainhead) - #define code (curpstate->Code) - #define ecode (curpstate->Ecode) - #define records (curpstate->Records) - #define ftabp (curpstate->Ftabp) - #ifdef FieldTableCompression - #define ftabwidth (curpstate->Ftabwidth) - #define foffwidth (curpstate->Foffwidth) - #define ftabcp (curpstate->Ftabcp) - #define ftabsp (curpstate->Ftabsp) - #define focp (curpstate->Focp) - #define fosp (curpstate->Fosp) - #define fo (curpstate->Fo) - #define bm (curpstate->Bm) - #endif /* FieldTableCompression */ - #define fnames (curpstate->Fnames) - #define efnames (curpstate->Efnames) - #define globals (curpstate->Globals) - #define eglobals (curpstate->Eglobals) - #define gnames (curpstate->Gnames) - #define egnames (curpstate->Egnames) - #define statics (curpstate->Statics) - #define estatics (curpstate->Estatics) - #define n_globals (curpstate->NGlobals) - #define n_statics (curpstate->NStatics) - #define strcons (curpstate->Strcons) - #define filenms (curpstate->Filenms) - #define efilenms (curpstate->Efilenms) - #define ilines (curpstate->Ilines) - #define elines (curpstate->Elines) - #define current_line_ptr (curpstate->Current_line_ptr) - - #ifdef Graphics - #define amperX (curpstate->AmperX) - #define amperY (curpstate->AmperY) - #define amperRow (curpstate->AmperRow) - #define amperCol (curpstate->AmperCol) - #define amperInterval (curpstate->AmperInterval) - #define lastEventWin (curpstate->LastEventWin) - #define lastEvFWidth (curpstate->LastEvFWidth) - #define lastEvLeading (curpstate->LastEvLeading) - #define lastEvAscent (curpstate->LastEvAscent) - #define kywd_xwin (curpstate->Kywd_xwin) - #define xmod_control (curpstate->Xmod_Control) - #define xmod_shift (curpstate->Xmod_Shift) - #define xmod_meta (curpstate->Xmod_Meta) - #endif /* Graphics */ - - #ifdef EventMon - #define linenum (curpstate->Linenum) - #define column (curpstate->Column) - #define lastline (curpstate->Lastline) - #define lastcol (curpstate->Lastcol) - #endif /* EventMon */ - - #define coexp_ser (curpstate->Coexp_ser) - #define list_ser (curpstate->List_ser) - #define set_ser (curpstate->Set_ser) - #define table_ser (curpstate->Table_ser) - - #define curstring (curpstate->stringregion) - #define curblock (curpstate->blockregion) - #define strtotal (curpstate->stringtotal) - #define blktotal (curpstate->blocktotal) - - #define coll_tot (curpstate->colltot) - #define coll_stat (curpstate->collstat) - #define coll_str (curpstate->collstr) - #define coll_blk (curpstate->collblk) - - #define lastop (curpstate->Lastop) - #define lastopnd (curpstate->Lastopnd) - - #define xargp (curpstate->Xargp) - #define xnargs (curpstate->Xnargs) - - #define k_current (curpstate->K_current) - #define k_errornumber (curpstate->K_errornumber) - #define k_errortext (curpstate->K_errortext) - #define k_errorvalue (curpstate->K_errorvalue) - #define have_errval (curpstate->Have_errval) - #define t_errornumber (curpstate->T_errornumber) - #define t_have_val (curpstate->T_have_val) - #define t_errorvalue (curpstate->T_errorvalue) - - #define k_main (curpstate->K_main) - #define k_errout (curpstate->K_errout) - #define k_input (curpstate->K_input) - #define k_output (curpstate->K_output) - - #define ENTERPSTATE(p) if (((p)!=NULL)) { curpstate = (p); } - #endif /* MultiThread */ - -#endif /* COMPILER */ +/* + * Specific arguments. + */ +#define Arg0 (cargp[0]) +#define Arg1 (cargp[1]) +#define Arg2 (cargp[2]) +#define Arg3 (cargp[3]) +#define Arg4 (cargp[4]) +#define Arg5 (cargp[5]) +#define Arg6 (cargp[6]) +#define Arg7 (cargp[7]) +#define Arg8 (cargp[8]) /* * Constants controlling expression evaluation. */ -#if COMPILER - #define A_Resume -1 /* expression failed: resume a generator */ - #define A_Continue -2 /* expression returned: continue execution */ - #define A_FallThru -3 /* body function: fell through end of code */ - #define A_Coact 1 /* co-expression activation */ - #define A_Coret 2 /* co-expression return */ - #define A_Cofail 3 /* co-expression failure */ -#else /* COMPILER */ - #define A_Resume 1 /* routine failed */ - #define A_Pret_uw 2 /* interp unwind for Op_Pret */ - #define A_Unmark_uw 3 /* interp unwind for Op_Unmark */ - #define A_Pfail_uw 4 /* interp unwind for Op_Pfail */ - #define A_Lsusp_uw 5 /* interp unwind for Op_Lsusp */ - #define A_Eret_uw 6 /* interp unwind for Op_Eret */ - #define A_Continue 7 /* routine returned */ - #define A_Coact 8 /* co-expression activated */ - #define A_Coret 9 /* co-expression returned */ - #define A_Cofail 10 /* co-expression failed */ - #ifdef MultiThread - #define A_MTEvent 11 /* multithread event */ - #endif /* MultiThread */ -#endif /* COMPILER */ +#define A_Resume 1 /* routine failed */ +#define A_Pret_uw 2 /* interp unwind for Op_Pret */ +#define A_Unmark_uw 3 /* interp unwind for Op_Unmark */ +#define A_Pfail_uw 4 /* interp unwind for Op_Pfail */ +#define A_Lsusp_uw 5 /* interp unwind for Op_Lsusp */ +#define A_Eret_uw 6 /* interp unwind for Op_Eret */ +#define A_Continue 7 /* routine returned */ +#define A_Coact 8 /* co-expression activated */ +#define A_Coret 9 /* co-expression returned */ +#define A_Cofail 10 /* co-expression failed */ /* * Address of word containing cset bit b (c is a struct descrip of type Cset). diff --git a/src/h/rproto.h b/src/h/rproto.h index 3a5cc30..6394726 100644 --- a/src/h/rproto.h +++ b/src/h/rproto.h @@ -46,7 +46,7 @@ void coclean (word *old); void coacttrace (struct b_coexpr *ccp,struct b_coexpr *ncp); void cofailtrace (struct b_coexpr *ccp,struct b_coexpr *ncp); void corettrace (struct b_coexpr *ccp,struct b_coexpr *ncp); -int coswitch (word *old, word *new, int first); +int coswitch (word *oldctx, word *newctx, int firsttime); int cplist (dptr dp1,dptr dp2,word i,word j); int cpset (dptr dp1,dptr dp2,word size); void cpslots (dptr dp1,dptr slotptr,word i, word j); @@ -116,7 +116,8 @@ int qtos (dptr dp,char *sbuf); int radix (int sign, register int r, register char *s, register char *end_s, union numeric *result); char *reserve (int region, word nbytes); -void retderef (dptr valp, word *low, word *high); +void resolve (void); +void retderef (dptr valp, word *low, word *high); void segvtrap (int); void stkdump (int); word sub (word a,word b); @@ -124,49 +125,31 @@ void syserr (char *s); struct b_coexpr *topact (struct b_coexpr *ce); void xmfree (void); -#ifdef MultiThread - void resolve (struct progstate *pstate); - struct b_coexpr *loadicode (char *name, struct b_file *theInput, - struct b_file *theOutput, struct b_file *theError, - C_integer bs, C_integer ss, C_integer stk); - void actparent (int eventcode); - int mt_activate (dptr tvalp, dptr rslt, struct b_coexpr *ncp); -#else /* MultiThread */ - void resolve (void); -#endif /* MultiThread */ - -#ifdef EventMon - void EVAsgn (dptr dx); -#endif /* EventMon */ - -#ifdef ExternalFunctions - dptr extcall (dptr x, int nargs, int *signal); -#endif /* ExternalFunctions */ - -#ifdef LargeInts - struct b_bignum *alcbignum (word n); - word bigradix (int sign, int r, char *s, char *x, +/* + * for large integers + */ +struct b_bignum *alcbignum (word n); +word bigradix (int sign, int r, char *s, char *x, union numeric *result); - double bigtoreal (dptr da); - int realtobig (dptr da, dptr dx); - int bigtos (dptr da, dptr dx); - void bigprint (FILE *f, dptr da); - int cpbignum (dptr da, dptr db); - int bigadd (dptr da, dptr db, dptr dx); - int bigsub (dptr da, dptr db, dptr dx); - int bigmul (dptr da, dptr db, dptr dx); - int bigdiv (dptr da, dptr db, dptr dx); - int bigmod (dptr da, dptr db, dptr dx); - int bigneg (dptr da, dptr dx); - int bigpow (dptr da, dptr db, dptr dx); - int bigpowri (double a, dptr db, dptr drslt); - int bigand (dptr da, dptr db, dptr dx); - int bigor (dptr da, dptr db, dptr dx); - int bigxor (dptr da, dptr db, dptr dx); - int bigshift (dptr da, dptr db, dptr dx); - word bigcmp (dptr da, dptr db); - int bigrand (dptr da, dptr dx); -#endif /* LargeInts */ +double bigtoreal (dptr da); +int realtobig (dptr da, dptr dx); +int bigtos (dptr da, dptr dx); +void bigprint (FILE *f, dptr da); +int cpbignum (dptr da, dptr db); +int bigadd (dptr da, dptr db, dptr dx); +int bigsub (dptr da, dptr db, dptr dx); +int bigmul (dptr da, dptr db, dptr dx); +int bigdiv (dptr da, dptr db, dptr dx); +int bigmod (dptr da, dptr db, dptr dx); +int bigneg (dptr da, dptr dx); +int bigpow (dptr da, dptr db, dptr dx); +int bigpowri (double a, dptr db, dptr drslt); +int bigand (dptr da, dptr db, dptr dx); +int bigor (dptr da, dptr db, dptr dx); +int bigxor (dptr da, dptr db, dptr dx); +int bigshift (dptr da, dptr db, dptr dx); +word bigcmp (dptr da, dptr db); +int bigrand (dptr da, dptr dx); #ifdef FAttrib char *make_mode(mode_t st_mode); @@ -385,10 +368,11 @@ void xmfree (void); * Prototypes for the run-time system. */ -struct b_external *alcextrnl (int n); +struct b_external *alcexternal (long nbytes, struct b_extlfuns *f, void *data); struct b_record *alcrecd (int nflds,union block *recptr); struct b_tvsubs *alcsubs (word len,word pos,dptr var); int bfunc (void); +struct descrip callextfunc (int (*)(int, dptr), dptr, dptr); long ckadd (long i, long j); long ckmul (long i, long j); long cksub (long i, long j); @@ -401,6 +385,10 @@ int cvcset (dptr dp,int * *cs,int *csbuf); int cvnum (dptr dp,union numeric *result); int cvreal (dptr dp,double *r); void deref (dptr dp1, dptr dp2); +int extlcmp (int argc, dptr argv); +int extlcopy (int argc, dptr argv); +int extlimage (int argc, dptr argv); +int extlname (int argc, dptr argv); void envset (void); int eq (dptr dp1,dptr dp2); int get_name (dptr dp1, dptr dp2); @@ -432,50 +420,25 @@ int tvcmp4 (struct dpair *dp1,struct dpair *dp2); int tvtbl_asgn (dptr dest, const dptr src); void varargs (dptr argp, int nargs, dptr rslt); -#ifdef MultiThread - struct b_coexpr *alccoexp (long icodesize, long stacksize); -#else /* MultiThread */ - struct b_coexpr *alccoexp (void); -#endif /* MultiThread */ - -#if COMPILER - - struct b_refresh *alcrefresh (int na, int nl, int nt, int wk_sz); - void atrace (void); - void ctrace (void); - void failtrace (void); - void initalloc (void); - int invoke (int n, dptr args, dptr rslt, continuation c); - void rtrace (void); - void strace (void); - void tracebk (struct p_frame *lcl_pfp, dptr argp); - int xdisp (struct p_frame *fp, dptr dp, int n, FILE *f); - -#else /* COMPILER */ - - struct b_refresh *alcrefresh (word *e, int nl, int nt); - void atrace (dptr dp); - void ctrace (dptr dp, int nargs, dptr arg); - void failtrace (dptr dp); - int invoke (int nargs, dptr *cargs, int *n); - void rtrace (dptr dp, dptr rval); - void strace (dptr dp, dptr rval); - void tracebk (struct pf_marker *lcl_pfp, dptr argp); - int xdisp (struct pf_marker *fp, dptr dp, int n, FILE *f); +struct b_coexpr *alccoexp (void); - #define Fargs dptr cargp - int Obscan (int nargs, Fargs); - int Ocreate (word *entryp, Fargs); - int Oescan (int nargs, Fargs); - int Ofield (int nargs, Fargs); - int Olimit (int nargs, Fargs); - int Ollist (int nargs, Fargs); - int Omkrec (int nargs, Fargs); +struct b_refresh *alcrefresh (word *e, int nl, int nt); +void atrace (dptr dp); +void ctrace (dptr dp, int nargs, dptr arg); +void failtrace (dptr dp); +int invoke (int nargs, dptr *cargs, int *n); +void rtrace (dptr dp, dptr rval); +void strace (dptr dp, dptr rval); +void tracebk (struct pf_marker *lcl_pfp, dptr argp); +int xdisp (struct pf_marker *fp, dptr dp, int n, FILE *f); - #ifdef MultiThread - void initalloc (word codesize, struct progstate *p); - #else /* MultiThread */ - void initalloc (word codesize); - #endif /* MultiThread */ +#define Fargs dptr cargp +int Obscan (int nargs, Fargs); +int Ocreate (word *entryp, Fargs); +int Oescan (int nargs, Fargs); +int Ofield (int nargs, Fargs); +int Olimit (int nargs, Fargs); +int Ollist (int nargs, Fargs); +int Omkrec (int nargs, Fargs); -#endif /* COMPILER */ +void initalloc (word codesize); diff --git a/src/h/rstructs.h b/src/h/rstructs.h index 5ee3fbb..9b32dd5 100644 --- a/src/h/rstructs.h +++ b/src/h/rstructs.h @@ -17,7 +17,6 @@ struct errtab { /* * Descriptor */ - struct descrip { /* descriptor */ word dword; /* type field */ union { @@ -33,7 +32,10 @@ struct sdescrip { char *string; /* pointer to string */ }; -#ifdef LargeInts +/* + * Heap Blocks + */ + struct b_bignum { /* large integer block */ word title; /* T_Lrgint */ word blksize; /* block size */ @@ -41,7 +43,6 @@ struct b_bignum { /* large integer block */ int sign; /* sign; 0 positive, 1 negative */ DIGIT digits[1]; /* digits */ }; -#endif /* LargeInts */ struct b_real { /* real block */ word title; /* T_Real */ @@ -83,16 +84,11 @@ struct b_list { /* list-header block */ struct b_proc { /* procedure block */ word title; /* T_Proc */ word blksize; /* size of block */ - - #if COMPILER - int (*ccode)(); - #else /* COMPILER */ - union { /* entry points for */ - int (*ccode)(); /* C routines */ - uword ioff; /* and icode as offset */ - pointer icode; /* and icode as absolute pointer */ - } entryp; - #endif /* COMPILER */ + union { /* entry points for */ + int (*ccode)(); /* C routines */ + uword ioff; /* and icode as offset */ + pointer icode; /* and icode as absolute pointer */ + } entryp; word nparam; /* number of parameters */ word ndynam; /* number of dynamic locals */ @@ -178,7 +174,9 @@ struct b_tvtbl { /* table element trapped variable block */ struct b_external { /* external block */ word title; /* T_External */ word blksize; /* size of block */ - word exdata[1]; /* words of external data */ + word id; /* identification number */ + struct b_extlfuns *funcs; /* dispatch table; distinguishes extl types */ + word data[]; /* actual external data */ }; struct astkblk { /* co-expression activator-stack block */ @@ -225,6 +223,17 @@ struct dpair { }; /* + * Structure for dispatching to user-provided C functions + * associated with external data. Any entry can be null. + */ +struct b_extlfuns { + int (*extlcmp) (int argc, dptr argv); + int (*extlcopy) (int argc, dptr argv); + int (*extlname) (int argc, dptr argv); + int (*extlimage)(int argc, dptr argv); + }; + +/* * Allocated memory region structure. Each program has linked lists of * string and block regions. */ @@ -246,20 +255,6 @@ struct region { }; #endif /* Double */ -#if COMPILER - -/* - * Structures for the compiler. - */ - struct p_frame { - struct p_frame *old_pfp; - struct descrip *old_argp; - struct descrip *rslt; - continuation succ_cont; - struct tend_desc tend; - }; - #endif /* COMPILER */ - /* * when debugging is enabled a debug struct is placed after the tended * descriptors in the procedure frame. @@ -273,46 +268,9 @@ struct debug { union numeric { /* long integers or real numbers */ long integer; double real; - #ifdef LargeInts - struct b_bignum *big; - #endif /* LargeInts */ - }; - -#if COMPILER -struct b_coexpr { /* co-expression stack block */ - word title; /* T_Coexpr */ - word size; /* number of results produced */ - word id; /* identification number */ - struct b_coexpr *nextstk; /* pointer to next allocated stack */ - continuation fnc; /* function containing co-expression code */ - struct p_frame *es_pfp; /* current procedure frame pointer */ - dptr es_argp; /* current argument pointer */ - struct tend_desc *es_tend; /* current tended pointer */ - char *file_name; /* current file name */ - word line_num; /* current line_number */ - dptr tvalloc; /* where to place transmitted value */ - struct descrip freshblk; /* refresh block pointer */ - struct astkblk *es_actstk; /* pointer to activation stack structure */ - word cstate[CStateSize]; /* C state information */ - struct p_frame pf; /* initial procedure frame */ - }; - -struct b_refresh { /* co-expression block */ - word title; /* T_Refresh */ - word blksize; /* size of block */ - word nlocals; /* number of local variables */ - word nargs; /* number of arguments */ - word ntemps; /* number of temporary descriptors */ - word wrk_size; /* size of non-descriptor work area */ - struct descrip elems[1]; /* locals and arguments */ + struct b_bignum *big; }; -#else /* COMPILER */ - -/* - * Structures for the interpreter. - */ - /* * Declarations for entries in tables associating icode location with * source program location. @@ -327,105 +285,6 @@ struct ipc_line { int line; /* line number */ }; -#ifdef MultiThread -/* - * Program state encapsulation. This consists of the VARIABLE parts of - * many global structures. - */ -struct progstate { - long hsize; /* size of the icode */ - struct progstate *parent; - struct descrip parentdesc; /* implicit "&parent" */ - struct descrip eventmask; /* implicit "&eventmask" */ - struct descrip opcodemask; /* implicit "&opcodemask" */ - struct descrip eventcode; /* &eventcode */ - struct descrip eventval; /* &eventval */ - struct descrip eventsource; /* &eventsource */ - dptr Glbl_argp; /* global argp */ - - /* - * trapped variable keywords' values - */ - struct descrip Kywd_err; - struct descrip Kywd_pos; - struct descrip ksub; - struct descrip Kywd_prog; - struct descrip Kywd_ran; - struct descrip Kywd_trc; - struct b_coexpr *Mainhead; - char *Code; - char *Ecode; - word *Records; - int *Ftabp; - #ifdef FieldTableCompression - short Ftabwidth, Foffwidth; - unsigned char *Ftabcp, *Focp; - short *Ftabsp, *Fosp; - int *Fo; - char *Bm; - #endif /* FieldTableCompression */ - dptr Fnames, Efnames; - dptr Globals, Eglobals; - dptr Gnames, Egnames; - dptr Statics, Estatics; - int NGlobals, NStatics; - char *Strcons; - struct ipc_fname *Filenms, *Efilenms; - struct ipc_line *Ilines, *Elines; - struct ipc_line * Current_line_ptr; - - #ifdef Graphics - struct descrip AmperX, AmperY, AmperRow, AmperCol;/* &x, &y, &row, &col */ - struct descrip AmperInterval; /* &interval */ - struct descrip LastEventWin; /* last Event() win */ - int LastEvFWidth; - int LastEvLeading; - int LastEvAscent; - uword PrevTimeStamp; /* previous timestamp */ - uword Xmod_Control, Xmod_Shift, Xmod_Meta; /* control,shift,meta */ - struct descrip Kywd_xwin[2]; /* &window + ... */ - #endif /* Graphics */ - - #ifdef EventMon - word Linenum, Column, Lastline, Lastcol; - #endif /* EventMon */ - - word Coexp_ser; /* this program's serial numbers */ - word List_ser; - word Set_ser; - word Table_ser; - - uword stringtotal; /* cumulative total allocation */ - uword blocktotal; /* cumulative total allocation */ - word colltot; /* total number of collections */ - word collstat; /* number of static collect requests */ - word collstr; /* number of string collect requests */ - word collblk; /* number of block collect requests */ - struct region *stringregion; - struct region *blockregion; - - word Lastop; - - dptr Xargp; - word Xnargs; - - struct descrip K_current; - int K_errornumber; - char *K_errortext; - struct descrip K_errorvalue; - int Have_errval; - int T_errornumber; - int T_have_val; - struct descrip T_errorvalue; - - struct descrip K_main; - struct b_file K_errout; - struct b_file K_input; - struct b_file K_output; - }; - -#endif /* MultiThread */ - /* * Frame markers */ @@ -445,11 +304,6 @@ struct pf_marker { /* procedure frame marker */ inst pf_ipc; /* saved ipc */ word pf_ilevel; /* saved ilevel */ dptr pf_scan; /* saved scanning environment */ - - #ifdef MultiThread - struct progstate *pf_prog;/* saved program state pointer */ - #endif /* MultiThread */ - struct descrip pf_locals[1]; /* descriptors for locals */ }; @@ -511,12 +365,7 @@ struct b_coexpr { /* co-expression stack block */ dptr tvalloc; /* where to place transmitted value */ struct descrip freshblk; /* refresh block pointer */ struct astkblk *es_actstk; /* pointer to activation stack structure */ - - #ifdef MultiThread - struct progstate *program; - #endif /* MultiThread */ - - word cstate[CStateSize]; /* C state information */ + word cstate[2]; /* was C state, now rswitch data */ }; struct b_refresh { /* co-expression block */ @@ -528,7 +377,6 @@ struct b_refresh { /* co-expression block */ struct descrip elems[1]; /* arguments and locals, including Arg0 */ }; -#endif /* COMPILER */ union block { /* general block */ struct b_real realblk; @@ -548,8 +396,5 @@ union block { /* general block */ struct b_coexpr coexpr; struct b_external externl; struct b_slots slots; - - #ifdef LargeInts - struct b_bignum bignumblk; - #endif /* LargeInts */ + struct b_bignum bignumblk; }; @@ -13,7 +13,6 @@ #include "../h/cstructs.h" #include "../h/mproto.h" #include "../h/cpuconf.h" -#include "../h/monitor.h" #include "../h/rmacros.h" #include "../h/rstructs.h" diff --git a/src/h/sys.h b/src/h/sys.h index fecfd96..b858a7e 100644 --- a/src/h/sys.h +++ b/src/h/sys.h @@ -35,22 +35,22 @@ * Operating-system-dependent includes. */ #if MSWIN - #include <windows.h> - #include <sys/cygwin.h> - #include <sys/select.h> - #ifdef WinGraphics + #include <windows.h> + #include <sys/cygwin.h> + #include <sys/select.h> + #define int_PASCAL int PASCAL #define LRESULT_CALLBACK LRESULT CALLBACK #define BOOL_CALLBACK BOOL CALLBACK #include <mmsystem.h> #include <process.h> #include "../wincap/dibutil.h" - #endif /* WinGraphics */ - #undef Type - #undef lst1 - #undef lst2 + #undef Type + #undef lst1 + #undef lst2 + #endif /* WinGraphics */ #endif /* MSWIN */ /* diff --git a/src/h/typedefs.h b/src/h/typedefs.h index 984af9a..041a1f7 100644 --- a/src/h/typedefs.h +++ b/src/h/typedefs.h @@ -39,43 +39,35 @@ typedef word C_integer; */ typedef int (*continuation) (void); -#if !COMPILER - - /* - * Typedefs for the interpreter. - */ - - /* - * Icode consists of operators and arguments. Operators are small integers, - * while arguments may be pointers. To conserve space in icode files on - * computers with 16-bit ints, icode is written by the linker as a mixture - * of ints and words (longs). When an icode file is read in and processed - * by the interpreter, it looks like a C array of mixed ints and words. - * Accessing this "nonstandard" structure is handled by a union of int and - * word pointers and incrementing is done by incrementing the appropriate - * member of the union (see the interpreter). This is a rather dubious - * method and certainly not portable. A better way might be to address - * icode with a char *, but the incrementing code might be inefficient - * (at a place that experiences a lot of execution activity). - * - * For the moment, the dubious coding is isolated under control of the - * size of integers. - */ - - #if IntBits != WordBits +/* + * Icode consists of operators and arguments. Operators are small integers, + * while arguments may be pointers. To conserve space in icode files on + * computers with 16-bit ints, icode is written by the linker as a mixture + * of ints and words (longs). When an icode file is read in and processed + * by the interpreter, it looks like a C array of mixed ints and words. + * Accessing this "nonstandard" structure is handled by a union of int and + * word pointers and incrementing is done by incrementing the appropriate + * member of the union (see the interpreter). This is a rather dubious + * method and certainly not portable. A better way might be to address + * icode with a char *, but the incrementing code might be inefficient + * (at a place that experiences a lot of execution activity). + * + * For the moment, the dubious coding is isolated under control of the + * size of integers. + */ - typedef union { - int *op; - word *opnd; - } inst; +#if IntBits != WordBits - #else /* IntBits != WordBits */ + typedef union { + int *op; + word *opnd; + } inst; - typedef union { - word *op; - word *opnd; - } inst; +#else /* IntBits != WordBits */ - #endif /* IntBits != WordBits */ + typedef union { + word *op; + word *opnd; + } inst; -#endif /* COMPILER */ +#endif /* IntBits != WordBits */ diff --git a/src/h/version.h b/src/h/version.h index c3a8b8d..c7ac2a0 100644 --- a/src/h/version.h +++ b/src/h/version.h @@ -11,8 +11,8 @@ * Icon version number and date. * These are the only two entries that change any more. */ -#define VersionNumber "9.4.3" -#define VersionDate "November 14, 2005" +#define VersionNumber "9.5.0" +#define VersionDate "April 12, 2010" /* * Version number to insure format of data base matches version of iconc @@ -20,47 +20,22 @@ */ #define DVersion "9.0.00" -#if COMPILER - - /* - * &version - */ - #define Version "Icon Version " VersionNumber "-C, " VersionDate - -#else /* COMPILER */ - - /* - * &version - */ - #define Version "Icon Version " VersionNumber ", " VersionDate - - /* - * Version numbers to be sure that ucode is compatible with the linker - * and that icode is compatible with the run-time system. - */ - - #define UVersion "U9.0.00" - - #ifdef FieldTableCompression - - #if IntBits == 32 - #define IVersion "I9.2.00FT/32" - #endif /* IntBits == 32 */ - - #if IntBits == 64 - #define IVersion "I9.2.00FT/64" - #endif /* IntBits == 64 */ - - #else /* FieldTableCompression */ +/* + * &version + */ +#define Version "Icon Version " VersionNumber ", " VersionDate - #if IntBits == 32 - #define IVersion "I9.0.00/32" - #endif /* IntBits == 32 */ +/* + * Version numbers to be sure that ucode is compatible with the linker + * and that icode is compatible with the run-time system. + */ - #if IntBits == 64 - #define IVersion "I9.0.00/64" - #endif /* IntBits == 64 */ +#define UVersion "U9.0.00" - #endif /* FieldTableCompression */ +#if IntBits == 32 + #define IVersion "I9.0.00/32" +#endif /* IntBits == 32 */ -#endif /* COMPILER */ +#if IntBits == 64 + #define IVersion "I9.0.00/64" +#endif /* IntBits == 64 */ diff --git a/src/h/xwin.h b/src/h/xwin.h index a8ff24c..2469747 100644 --- a/src/h/xwin.h +++ b/src/h/xwin.h @@ -74,8 +74,8 @@ #define WMAXCOLORS 256 #define MAXCOLORNAME 40 #define MAXDISPLAYNAME 64 -#define SHARED 0 -#define MUTABLE 1 +#define CSHARED 0 +#define CMUTABLE 1 #define NUMCURSORSYMS 78 /* @@ -165,7 +165,7 @@ typedef struct wcolor { unsigned long c; /* X pixel value */ int refcount; /* reference count */ - int type; /* SHARED or MUTABLE */ + int type; /* CSHARED or CMUTABLE */ int next; /* next entry in hash chain */ unsigned short r, g, b; /* rgb for colorsearch */ char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ diff --git a/src/iconc/Makefile b/src/iconc/Makefile deleted file mode 100644 index bce6aa8..0000000 --- a/src/iconc/Makefile +++ /dev/null @@ -1,73 +0,0 @@ -# Makefile for the Icon compiler, iconc. -# -# This is no longer supported and may not work. - -include ../../Makedefs - - -OBJS = cmain.o ctrans.o dbase.o clex.o\ - cparse.o csym.o cmem.o ctree.o ccode.o ccomp.o\ - ivalues.o codegen.o fixcode.o inline.o chkinv.o\ - typinfer.o types.o lifetime.o incheck.o - -COBJS = ../common/long.o ../common/getopt.o ../common/time.o\ - ../common/filepart.o ../common/identify.o ../common/munix.o\ - ../common/strtbl.o ../common/rtdb.o ../common/literals.o \ - ../common/alloc.o ../common/ipp.o - - - -iconc: $(OBJS) $(COBJS) - $(CC) -o iconc $(OBJS) $(COBJS) - cp iconc ../../bin - strip ../../bin/iconc$(EXE) - -$(OBJS): ../h/config.h ../h/cpuconf.h ../h/cstructs.h ../h/define.h\ - ../h/mproto.h ../h/typedefs.h ../h/gsupport.h \ - ccode.h cglobals.h cproto.h csym.h ctrans.h ctree.h - -$(COBJS): ../h/mproto.h - cd ../common; $(MAKE); $(MAKE) xpm - -ccode.o: ../h/lexdef.h ctoken.h -chkinv.o: ctoken.h -clex.o: ../h/lexdef.h ../h/parserr.h ctoken.h \ - ../common/lextab.h ../common/yylex.h ../common/error.h -clocal.o: ../h/config.h -cparse.o: ../h/lexdef.h -ctrans.o: ctoken.h -ctree.o: ../h/lexdef.h ctoken.h -csym.o: ctoken.h -dbase.o: ../h/lexdef.h -lifetime.o: ../h/lexdef.h ctoken.h -typinfer.o: ../h/lexdef.h ctoken.h -types.o: ../h/lexdef.h ctoken.h - - - -# The following sections are commented out because they do not need to -# be performed unless changes are made to cgrammar.c, ../h/grammar.h, -# ../common/tokens.txt, or ../common/op.txt. Such changes involve -# modifications to the syntax of Icon and are not part of the installation -# process. However, if the distribution files are unloaded in a fashion -# such that their dates are not set properly, the following sections would -# be attempted. -# -# Note that if any changes are made to the files mentioned above, the comment -# characters at the beginning of the following lines should be removed. -# icont must be on your search path for these actions to work. -# -#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \ -# ../common/tokens.txt ../common/op.txt -# cd ../common; $(MAKE) gfiles -# -#cparse.c ctoken.h: cgram.g ../common/pscript -## expect 218 shift/reduce conflicts -# yacc -d cgram.g -# ../common/pscript <y.tab.c >cparse.c -# mv y.tab.h ctoken.h -# rm -f y.tab.c -# -#cgram.g: cgrammar.c ../h/define.h ../h/grammar.h \ -# ../common/yacctok.h ../common/fixgram -# $(CC) -E -C cgrammar.c | ../common/fixgram >cgram.g diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c deleted file mode 100644 index 108cd15..0000000 --- a/src/iconc/ccode.c +++ /dev/null @@ -1,4954 +0,0 @@ -/* - * ccode.c - routines to produce internal representation of C code. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "ctoken.h" -#include "cproto.h" - -#ifdef OptimizeLit - -#define NO_LIMIT 0 -#define LIMITED 1 -#define LIMITED_TO_INT 2 -#define NO_TOUCH 3 - -struct lit_tbl { - int modified; - int index; - int safe; - struct code *initial; - struct code *end; - struct val_loc *vloc; - struct centry *csym; - struct lit_tbl *prev; - struct lit_tbl *next; -}; -#endif /* OptimizeLit */ - -/* - * Prototypes for static functions. - */ -static struct c_fnc *alc_fnc (void); -static struct tmplftm *alc_lftm (int num, union field *args); -static int alc_tmp (int n, struct tmplftm *lifetm_ary); - -#ifdef OptimizePoll - static int analyze_poll (void); - static void remove_poll (void); -#endif /* OptimizePoll */ - -#ifdef OptimizeLit - static int instr (const char *str, int chr); - static void invalidate (struct val_loc *val,struct code *end,int code); - static void analyze_literals (struct code *start, struct code *top, int lvl); - static int eval_code (struct code *cd, struct lit_tbl *cur); - static void propagate_literals (void); - static void free_tbl (void); - static struct lit_tbl *alc_tbl (void); - static void tbl_add (truct lit_tbl *add); -#endif /* OptimizeLit */ - -static struct code *asgn_null (struct val_loc *loc1); -static struct val_loc *bound (struct node *n, struct val_loc *rslt, - int catch_fail); -static struct code *check_var (struct val_loc *d, struct code *lbl); -static void deref_cd (struct val_loc *src, struct val_loc *dest); -static void deref_ret (struct val_loc *src, struct val_loc *dest, - int subtypes); -static void endlife (int kind, int indx, int old, nodeptr n); -static struct val_loc *field_ref(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_act (nodeptr n, struct val_loc *rslt); -static struct val_loc *gen_apply(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_args (struct node *n, int frst_arg, int nargs); -static struct val_loc *gen_case (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_creat(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_lim (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_scan (struct node *n, struct val_loc *rslt); -static struct val_loc *gencode (struct node *n, struct val_loc *rslt); -static struct val_loc *genretval(struct node *n, struct node *expr, - struct val_loc *dest); -static struct val_loc *inv_prc (nodeptr n, struct val_loc *rslt); -static struct val_loc *inv_op (nodeptr n, struct val_loc *rslt); -static nodeptr max_lftm (nodeptr n1, nodeptr n2); -static void mk_callop (char *oper_nm, int ret_flag, - struct val_loc *arg1rslt, int nargs, - struct val_loc *rslt, int optim); -static struct code *mk_cpyval (struct val_loc *loc1, struct val_loc *loc2); -static struct code *new_call (void); -static char *oper_name (struct implement *impl); -static void restr_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void save_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void setloc (nodeptr n); -static struct val_loc *tmp_loc (int n); -static struct val_loc *var_ref (struct lentry *sym); -static struct val_loc *vararg_sz(int n); - -#define FrstArg 2 - -/* - * Information that must be passed between a loop and its next and break - * expressions. - */ -struct loop_info { - struct code *next_lbl; /* where to branch for a next expression */ - struct code *end_loop; /* label at end of loop */ - struct code *on_failure; /* where to go if the loop fails */ - struct scan_info *scan_info; /* scanning environment upon entering loop */ - struct val_loc *rslt; /* place to put result of loop */ - struct c_fnc *succ_cont; /* the success continuation for the loop */ - struct loop_info *prev; /* link to info for outer loop */ - }; - -/* - * The allocation status of a temporary variable can either be "in use", - * "not allocated", or reserved for use at a code position (indicated - * by a specific negative number). - */ -#define InUse 1 -#define NotAlc 0 - -/* - * tmplftm is used to precompute lifetime information for use in allocating - * temporary variables. - */ -struct tmplftm { - int cur_status; - nodeptr lifetime; - }; - -/* - * Places where &subject and &pos are saved during string scanning. "outer" - * values are saved when the scanning expression is executed. "inner" - * values are saved when the scanning expression suspends. - */ -struct scan_info { - struct val_loc *outer_sub; - struct val_loc *outer_pos; - struct val_loc *inner_sub; - struct val_loc *inner_pos; - struct scan_info *next; - }; - -struct scan_info scan_base = {NULL, 0, NULL, 0, NULL}; -struct scan_info *nxt_scan = &scan_base; - -struct val_loc ignore; /* no values, just something to point at */ -static struct val_loc proc_rslt; /* result location for procedure */ - -int *tmp_status = NULL; /* allocation status of temp descriptor vars */ -int *itmp_status = NULL; /* allocation status of temp C int vars*/ -int *dtmp_status = NULL; /* allocation status of temp C double vars */ -int *sbuf_status = NULL; /* allocation of string buffers */ -int *cbuf_status = NULL; /* allocation of cset buffers */ -int num_tmp; /* number of temp descriptors actually used */ -int num_itmp; /* number of temp C ints actually used */ -int num_dtmp; /* number of temp C doubles actually used */ -int num_sbuf; /* number of string buffers actually used */ -int num_cbuf; /* number of cset buffers actually used */ -int status_sz = 20; /* current size of tmp_status array */ -int istatus_sz = 20; /* current size of itmp_status array */ -int dstatus_sz = 20; /* current size of dtmp_status array */ -int sstatus_sz = 20; /* current size of sbuf_status array */ -int cstatus_sz = 20; /* current size of cbuf_status array */ -struct freetmp *freetmp_pool = NULL; - -static char frm_prfx[PrfxSz + 1];/* prefix for procedure frame */ -static char *lastfiln; /* last file name set in code */ -static int lastline; /* last line number set in code */ - -#ifdef OptimizePoll -static struct code *lastpoll; -#endif /* OptimizePoll */ - -#ifdef OptimizeLit -static struct lit_tbl *tbl = NULL; -static struct lit_tbl *free_lit_tbl = NULL; -#endif /* OptimizeLit */ - -static struct c_fnc *fnc_lst; /* list of C functions implementing proc */ -static struct c_fnc **flst_end; /* pointer to null pointer at end of fnc_lst */ -struct c_fnc *cur_fnc; /* C function currently being built */ -static int create_lvl = 0; /* co-expression create level */ - -struct pentry *cur_proc; /* procedure currently being translated */ - -struct code *on_failure; /* place to go on failure */ - -static struct code *p_ret_lbl; /* label for procedure return */ -static struct code *p_fail_lbl; /* label for procedure fail */ -struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -struct code resume; -struct code contin; -struct code fallthru; -struct code next_fail; - -int lbl_seq_num = 0; /* next label sequence number */ - -#ifdef OptimizeLit -static void print_tbl(struct lit_tbl *start) { - struct lit_tbl *ptr; - - for (ptr=start; ptr != NULL ;ptr=ptr->next) { - printf("mod (%2d) strchr (%2d) ",ptr->modified,ptr->index); - if (ptr->csym != NULL) { - printf("image (%13s) ",ptr->csym->image); - } - if (ptr->vloc != NULL) { - printf("val (%6d) type (%d)",ptr->vloc->u.tmp,ptr->vloc->loc_type); - } - if (ptr->end == NULL) - printf(" END IS NULL"); - printf("\n"); - } -} - - -static void free_tbl() { -/* - struct lit_tbl *ptr, *next; -*/ - free_lit_tbl = tbl; - tbl = NULL; -/* - ptr = tbl; - while (ptr != NULL) { - next = ptr->next; - free(ptr); - ptr = next; - } - tbl = NULL; -*/ -} - - -static struct lit_tbl *alc_tbl() { - struct lit_tbl *new; - static int cnt=0; - - - if (free_lit_tbl != NULL) { - new = free_lit_tbl; - free_lit_tbl = new->next; - } - else - new = (struct lit_tbl *)alloc(sizeof(struct lit_tbl)); - new->modified = NO_LIMIT; - new->index = -1; - new->safe = 1; - new->initial = NULL; - new->end = NULL; - new->vloc = NULL; - new->csym = NULL; - new->prev = NULL; - new->next = NULL; - return new; -} -#endif /* OptimizeLit */ - -/* - * proccode - generate code for a procedure. - */ -void proccode(proc) -struct pentry *proc; - { - struct c_fnc *fnc; - struct code *cd; - struct code *cd1; - struct code *lbl; - nodeptr n; - nodeptr failer; - int gen; - int i; -#ifdef OptimizeLit - struct code *procstart; -#endif /* OptimizeLit */ - - /* - * Initialize arrays used for allocating temporary variables. - */ - if (tmp_status == NULL) - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - if (itmp_status == NULL) - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - if (dtmp_status == NULL) - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - if (sbuf_status == NULL) - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - if (cbuf_status == NULL) - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Initialize standard signals. - */ - resume.cd_id = C_Resume; - contin.cd_id = C_Continue; - fallthru.cd_id = C_FallThru; - - /* - * Initialize procedure result and the transcan locations. - */ - proc_rslt.loc_type = V_PRslt; - proc_rslt.mod_access = M_None; - ignore.loc_type = V_Ignore; - ignore.mod_access = M_None; - - cur_proc = proc; /* current procedure */ - lastfiln = NULL; /* file name */ - lastline = 0; /* line number */ - -#ifdef OptimizePoll - lastpoll = NULL; -#endif /* OptimizePoll */ - - /* - * Procedure frame prefix is the procedure prefix. - */ - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = cur_proc->prefix[i]; - frm_prfx[PrfxSz] = '\0'; - - /* - * Initialize the continuation list and allocate the outer function for - * this procedure. - */ - fnc_lst = NULL; - flst_end = &fnc_lst; - cur_fnc = alc_fnc(); - -#ifdef OptimizeLit - procstart = cur_fnc->cursor; -#endif /* OptimizeLit */ - - /* - * If the procedure is not used anywhere don't generate code for it. - * This can happen when using libraries containing several procedures, - * but not all are needed. However, if there is a block for the - * procedure, we need at least a dummy function. - */ - if (!cur_proc->reachable) { - if (!(glookup(cur_proc->name)->flag & F_SmplInv)) - outerfnc(fnc_lst); - return; - } - - /* - * Allocate labels for the code for procedure failure, procedure return, - * and allocate the bounding signal for this procedure (at this point - * signals and labels are not distinguished). - */ - p_fail_lbl = alc_lbl("proc fail", 0); - p_ret_lbl = alc_lbl("proc return", 0); - bound_sig = alc_lbl("bound", 0); - - n = proc->tree; - setloc(n); - if (Type(Tree1(n)) != N_Empty) { - /* - * initial clause. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - lbl = alc_lbl("end initial", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!first_time"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "first_time = 0;"; - cd_add(cd); - bound(Tree1(n), &ignore, 1); - cur_fnc->cursor = lbl; - } - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - bound(Tree2(n), &ignore, 1); - - /* - * Place code to perform procedure failure and return and the - * end of the outer function. - */ - setloc(Tree3(n)); - cd_add(p_fail_lbl); - cd = NewCode(0); - cd->cd_id = C_PFail; - cd_add(cd); - cd_add(p_ret_lbl); - cd = NewCode(0); - cd->cd_id = C_PRet; - cd_add(cd); - - /* - * Fix up signal handling code and perform peephole optimizations. - */ - fix_fncs(fnc_lst); - -#ifdef OptimizeLit - analyze_literals(procstart, NULL, 0); - propagate_literals(); -#endif /* OptimizeLit */ - - /* - * The outer function is the first one on the list. It has the - * procedure interface; the others are just continuations. - */ - outerfnc(fnc_lst); - for (fnc = fnc_lst->next; fnc != NULL; fnc = fnc->next) - if (fnc->ref_cnt > 0) - prt_fnc(fnc); -#ifdef OptimizeLit - free_tbl(); -#endif /* OptimizeLit */ -} - -/* - * gencode - generate code for a syntax tree. - */ -static struct val_loc *gencode(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *lbl1; - struct code *lbl2; - struct code *cursor_sav; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct implement *impl; - struct implement *impl1; - struct val_loc *r1[3]; - struct val_loc *r2[2]; - struct val_loc *frst_arg; - struct lentry *single; - struct freetmp *freetmp; - struct freetmp *ft; - struct tmplftm *lifetm_ary; - char *sbuf; - int i; - int tmp_indx; - int nargs; - static struct loop_info *loop_info = NULL; - struct loop_info *li_sav; - - switch (n->n_type) { - case N_Activat: - rslt = gen_act(n, rslt); - break; - - case N_Alt: - rslt = chk_alc(rslt, n->lifetime); /* insure a result location */ - - fail_sav = on_failure; - fnc_sav = cur_fnc; - - /* - * If the first alternative fails, execution must go to the - * "alt" label. - */ - lbl1 = alc_lbl("alt", 0); - on_failure = lbl1; - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* 1st alternative goes before label */ - gencode(Tree0(n), rslt); - - /* - * Each alternative must call the same success continuation. - */ - fnc = alc_fnc(); - callc_add(fnc); - - cur_fnc = fnc_sav; /* return to the context of the label */ - cur_fnc->cursor = lbl1; /* 2nd alternative goes after label */ - on_failure = fail_sav; /* on failure, alternation fails */ - gencode(Tree1(n), rslt); - callc_add(fnc); /* call continuation */ - - /* - * Code following the alternation goes in the continuation. If - * the code fails, the continuation returns the resume signal. - */ - cur_fnc = fnc; - on_failure = &resume; - break; - - case N_Apply: - rslt = gen_apply(n, rslt); - break; - - case N_Augop: - impl = Impl0(n); /* assignment */ - impl1 = Impl1(n); /* the operation */ - if (impl == NULL || impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - /* - * allocate an argument list for the operation. - */ - lifetm_ary = alc_lftm(2, &n->n_field[2]); - tmp_indx = alc_tmp(2, lifetm_ary); - r1[0] = tmp_loc(tmp_indx); - r1[1] = tmp_loc(tmp_indx + 1); - - gencode(Tree2(n), r1[0]); /* first argument */ - - /* - * allocate an argument list for the assignment and copy the - * value of the first argument into it. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[1].cur_status = n->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(2, lifetm_ary); - r2[0] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[0])); - r2[1] = tmp_loc(tmp_indx); - - gencode(Tree3(n), r1[1]); /* second argument */ - - /* - * Produce code for the operation. - */ - setloc(n); - implproto(impl1); - mk_callop(oper_name(impl1), impl1->ret_flag, r1[0], 2, r2[1], 0); - - /* - * Produce code for the assignment. - */ - implproto(impl); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, rslt, 0); - - free((char *)lifetm_ary); - break; - - case N_Bar: { - struct val_loc *fail_flg; - - /* - * Allocate an integer variable to keep track of whether the - * repeated alternation should fail when execution reaches - * the top of its loop, and generate code to initialize the - * variable to 0. - */ - fail_flg = itmp_loc(alc_itmp(n->intrnl_lftm)); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - - /* - * Code at the top of the repeated alternation loop checks - * the failure flag. - */ - lbl1 = alc_lbl("rep alt", 0); - cd_add(lbl1); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = fail_flg; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * If the expression fails without producing a value, the - * repeated alternation must fail. - */ - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 1;"; - cd_add(cd); - - /* - * Generate code for the repeated expression. If it produces - * a value before before backtracking occurs, the loop is - * repeated as indicated by the value of the failure flag. - */ - on_failure = lbl1; - rslt = gencode(Tree0(n), rslt); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - } - break; - - case N_Break: - if (loop_info == NULL) { - nfatal(n, "invalid context for a break expression", NULL); - rslt = &ignore; - break; - } - - /* - * If the break is in a different string scanning context from the - * loop itself, generate code to restore the scanning environment. - */ - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - - - if (Tree0(n)->n_type == N_Empty && loop_info->rslt == &ignore) { - /* - * The break has no associated expression and the loop needs - * no value, so just branch out of the loop. - */ - cd_add(sig_cd(loop_info->end_loop, cur_fnc)); - } - else { - /* - * The code for the expression associated with the break is - * actually placed at the end of the loop. Go there and - * add a label to branch to. - */ - cursor_sav = cur_fnc->cursor; - fnc_sav = cur_fnc; - fail_sav = on_failure; - cur_fnc = loop_info->end_loop->Container; - cur_fnc->cursor = loop_info->end_loop->prev; - on_failure = loop_info->on_failure; - lbl1 = alc_lbl("break", 0); - cd_add(lbl1); - - /* - * Make sure a result location has been allocated for the - * loop, restore the loop information for the next outer - * loop, generate code for the break expression, then - * restore the loop information for this loop. - */ - loop_info->rslt = chk_alc(loop_info->rslt, Tree0(n)->lifetime); - li_sav = loop_info; - loop_info = loop_info->prev; - gencode(Tree0(n), li_sav->rslt); - loop_info = li_sav; - - /* - * If this or another break expression suspends so we cannot - * just branch to the end of the loop, all breaks must - * call a common continuation. - */ - if (cur_fnc->cursor->next != loop_info->end_loop && - loop_info->succ_cont == NULL) - loop_info->succ_cont = alc_fnc(); - if (loop_info->succ_cont == NULL) - cd_add(mk_goto(loop_info->end_loop)); /* go to end of loop */ - else - callc_add(loop_info->succ_cont); /* call continuation */ - - /* - * Return to the location of the break and generate a branch to - * the code for its associated expression. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cursor_sav; - on_failure = fail_sav; - cd_add(sig_cd(lbl1, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Case: - rslt = gen_case(n, rslt); - break; - - case N_Create: - rslt = gen_creat(n, rslt); - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - cd = NewCode(2); - cd->cd_id = C_Lit; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->Literal = CSym0(n); - cd_add(cd); - break; - - case N_Empty: - /* - * Assume null value is needed. - */ - if (rslt == &ignore) - break; - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - break; - - case N_Field: - rslt = field_ref(n, rslt); - break; - - case N_Id: - /* - * If the variable reference is not going to be used, don't bother - * building it. - */ - if (rslt == &ignore) - break; - cd = NewCode(2); - cd->cd_id = C_NamedVar; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->NamedVar = LSym0(n); - cd_add(cd); - break; - - case N_If: - if (Type(Tree2(n)) == N_Empty) { - /* - * if-then. Control clause is bounded, but otherwise trivial. - */ - bound(Tree0(n), &ignore, 0); /* control clause */ - rslt = gencode(Tree1(n), rslt); /* then clause */ - } - else { - /* - * if-then-else. Establish an "else" label as the failure - * label of the bounded control clause. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - lbl1 = alc_lbl("else", 0); - on_failure = lbl1; - - bound(Tree0(n), &ignore, 0); /* control clause */ - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* then clause goes before else lbl */ - on_failure = fail_sav; - rslt = chk_alc(rslt, n->lifetime); - gencode(Tree1(n), rslt); /* then clause */ - - /* - * If the then clause is not a generator, execution can - * just go to the end of the if-then-else expression. If it - * is a generator, the continuation for the expression must be - * in a separate function. - */ - if (cur_fnc->cursor->next == lbl1) { - fnc = NULL; - lbl2 = alc_lbl("end if", 0); - cd_add(mk_goto(lbl2)); - cur_fnc->cursor = lbl1; - cd_add(lbl2); - } - else { - lbl2 = NULL; - fnc = alc_fnc(); - callc_add(fnc); - cur_fnc = fnc_sav; - } - - cur_fnc->cursor = lbl1; /* else clause goes after label */ - on_failure = fail_sav; - gencode(Tree2(n), rslt); /* else clause */ - - /* - * If the else clause is not a generator, execution is at - * the end of the if-then-else expression, but the if clause - * may have forced the continuation to be in a separate function. - * If the else clause is a generator, it forces the continuation - * to be in a separate function. - */ - if (fnc == NULL) { - if (cur_fnc->cursor->next == lbl2) - cur_fnc->cursor = lbl2; - else { - fnc = alc_fnc(); - callc_add(fnc); - /* - * The then clause is not a generator, so it has branched - * to lbl2. We must add a call to the continuation there. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl2; - on_failure = fail_sav; - callc_add(fnc); - } - } - else - callc_add(fnc); - - if (fnc != NULL) { - /* - * We produced a continuation for the if-then-else, so code - * generation must proceed in it. - */ - cur_fnc = fnc; - on_failure = &resume; - } - } - break; - - case N_Invok: - /* - * General invocation. - */ - nargs = Val0(n); - if (Tree1(n)->n_type == N_Empty) { - /* - * Mutual evaluation. - */ - for (i = 2; i <= nargs; ++i) - gencode(n->n_field[i].n_ptr, &ignore); /* arg i - 1 */ - rslt = chk_alc(rslt, n->lifetime); - gencode(n->n_field[nargs + 1].n_ptr, rslt); /* last argument */ - } - else { - ++nargs; /* consider the procedure an argument to invoke() */ - frst_arg = gen_args(n, 1, nargs); - setloc(n); - /* - * Assume this operation uses its result location as a work - * area. Give it a location that is tended, where the value - * is retained as long as the operation can be resumed. - */ - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - rslt = chk_alc(rslt, max_lftm(n->lifetime, n->intrnl_lftm)); - mk_callop( "invoke", DoesRet | DoesFail | DoesSusp, frst_arg, nargs, - rslt, 0); - } - break; - - case N_InvOp: - rslt = inv_op(n, rslt); - break; - - case N_InvProc: - rslt = inv_prc(n, rslt); - break; - - case N_InvRec: { - /* - * Directly invoke a record constructor. - */ - struct rentry *rec; - - nargs = Val0(n); /* number of arguments */ - frst_arg = gen_args(n, 2, nargs); - setloc(n); - rec = Rec1(n); - - rslt = chk_alc(rslt, n->lifetime); - - /* - * If error conversion can occur then the record constructor may - * fail and we must check the signal. - */ - if (err_conv) { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + - strlen("signal = R_") + PrfxSz + 1)); - sprintf(sbuf, "signal = R%s_%s(", rec->prefix, rec->name); - } - else { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + PrfxSz +4)); - sprintf(sbuf, "R%s_%s(", rec->prefix, rec->name); - } - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; /* constructor name */ - cd->Str(0) = sbuf; - cd->ElemTyp(1) = A_Intgr; /* number of arguments */ - cd->Intgr(1) = nargs; - cd->ElemTyp(2) = A_Str; /* , */ - cd->Str(2) = ", "; - if (frst_arg == NULL) { /* location of first argument */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "NULL"; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ""; - } - else { - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "&"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = frst_arg; - } - cd->ElemTyp(5) = A_Str; /* , */ - cd->Str(5) = ", "; - cd->ElemTyp(6) = A_Str; /* location of result */ - cd->Str(6) = "&"; - cd->ElemTyp(7) = A_ValLoc; - cd->ValLoc(7) = rslt; - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - if (err_conv) { - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "signal == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - } - break; - - case N_Limit: - rslt = gen_lim(n, rslt); - break; - - case N_Loop: { - struct loop_info li; - - /* - * Set up loop information for use by break and next expressions. - */ - li.end_loop = alc_lbl("end loop", 0); - cd_add(li.end_loop); - cur_fnc->cursor = li.end_loop->prev; /* loop goes before label */ - li.rslt = rslt; - li.on_failure = on_failure; - li.scan_info = nxt_scan; - li.succ_cont = NULL; - li.prev = loop_info; - loop_info = &li; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * "next" in the control clause just fails. - */ - li.next_lbl = &next_fail; - gencode(Tree1(n), &ignore); /* control clause */ - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); /* resume control clause */ - break; - - case REPEAT: - li.next_lbl = alc_lbl("repeat", 0); - cd_add(li.next_lbl); - bound(Tree1(n), &ignore, 1); - cd_add(mk_goto(li.next_lbl)); - break; - - case SUSPEND: /* suspension expression */ - if (create_lvl > 0) { - nfatal(n, "invalid context for suspend", NULL); - return &ignore; - } - /* - * "next" in the control clause just fails. The result - * of the control clause goes in the procedure return - * location. - */ - li.next_lbl = &next_fail; - genretval(n, Tree1(n), &proc_rslt); - - /* - * If necessary, swap scanning environments before suspending. - * if there is no success continuation, just return. - */ - if (nxt_scan != &scan_base) { - save_env(scan_base.inner_sub, scan_base.inner_pos); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - } - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ProcCont; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == NULL"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(p_ret_lbl, cur_fnc); - cd_add(cd); - cd = NewCode(0); - cd->cd_id = C_PSusp; - cd_add(cd); - cur_fnc->flag |= CF_ForeignSig; - - /* - * Force updating file name and line number, and if needed, - * switch scanning environments before resuming. - */ - lastfiln = NULL; - lastline = 0; - if (nxt_scan != &scan_base) { - save_env(scan_base.outer_sub, scan_base.outer_pos); - restr_env(scan_base.inner_sub, scan_base.inner_pos); - } - - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case WHILE: - li.next_lbl = alc_lbl("while", 0); - cd_add(li.next_lbl); - /* - * The control clause and do clause are both bounded expressions, - * but only the do clause establishes a new failure label. - */ - bound(Tree1(n), &ignore, 0); /* control clause */ - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - break; - - case UNTIL: - fail_sav = on_failure; - li.next_lbl = alc_lbl("until", 0); - cd_add(li.next_lbl); - - /* - * If the control clause fails, execution continues in - * the loop. - */ - if (Type(Tree2(n)) == N_Empty) - on_failure = li.next_lbl; - else { - lbl2 = alc_lbl("do", 0); - on_failure = lbl2; - cd_add(lbl2); - cur_fnc->cursor = lbl2->prev; /* control before label */ - } - bound(Tree1(n), &ignore, 0); /* control clause */ - - /* - * If the control clause succeeds, the loop fails. - */ - cd_add(sig_cd(fail_sav, cur_fnc)); - - if (Type(Tree2(n)) != N_Empty) { - /* - * Do clause goes after the label and the loop repeats. - */ - cur_fnc->cursor = lbl2; - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - } - break; - } - - /* - * Go to the end of the loop and see if the loop's success continuation - * is in a separate function. - */ - cur_fnc = li.end_loop->Container; - cur_fnc->cursor = li.end_loop; - if (li.succ_cont != NULL) { - callc_add(li.succ_cont); - cur_fnc = li.succ_cont; - on_failure = &resume; - } - if (li.rslt == NULL) - rslt = &ignore; /* shouldn't be used but must be something valid */ - else - rslt = li.rslt; - loop_info = li.prev; - break; - } - - case N_Next: - /* - * In some contexts "next" just fails. In other contexts it - * transfers control to a label, in which case it may have - * to restore a scanning environment. - */ - if (loop_info == NULL) - nfatal(n, "invalid context for a next expression", NULL); - else if (loop_info->next_lbl == &next_fail) - cd_add(sig_cd(on_failure, cur_fnc)); - else { - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - cd_add(sig_cd(loop_info->next_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Not: - lbl1 = alc_lbl("not", 0); - fail_sav = on_failure; - on_failure = lbl1; - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - bound(Tree0(n), &ignore, 0); - on_failure = fail_sav; - cd_add(sig_cd(on_failure, cur_fnc)); /* convert success to failure */ - cur_fnc->cursor = lbl1; /* convert failure to null */ - if (rslt != &ignore) { - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - } - break; - - case N_Ret: - if (create_lvl > 0) { - nfatal(n, "invalid context for return or fail", NULL); - return &ignore; - } - if (Val0(Tree0(n)) == RETURN) { - /* - * Set up the failure action of the return expression to do a - * procedure fail. - */ - if (nxt_scan != &scan_base) { - /* - * we must switch scanning environments if the expression fails. - */ - lbl1 = alc_lbl("return fail", 0); - cd_add(lbl1); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - on_failure = lbl1; - } - else - on_failure = p_fail_lbl; - - /* - * Produce code to place return value in procedure result location. - */ - genretval(n, Tree1(n), &proc_rslt); - - /* - * See if a scanning environment must be restored and - * transfer control to the procedure return code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_ret_lbl, cur_fnc)); - } - else { - /* - * fail. See if a scanning environment must be restored and - * transfer control to the procedure failure code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Scan: - rslt = gen_scan(n, rslt); - break; - - case N_Sect: - /* - * x[i+:j] or x[i-:j] (x[i:j] handled as ordinary operator) - */ - impl1 = Impl0(n); /* sectioning */ - if (impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - implproto(impl1); - - impl = Impl1(n); /* plus or minus */ - /* - * Allocate work area of temporary variables for sectioning. - */ - lifetm_ary = alc_lftm(3, NULL); - lifetm_ary[0].cur_status = Tree2(n)->postn; - lifetm_ary[0].lifetime = n->intrnl_lftm; - lifetm_ary[1].cur_status = Tree3(n)->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - lifetm_ary[2].cur_status = n->postn; - lifetm_ary[2].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(3, lifetm_ary); - for (i = 0; i < 3; ++i) - r1[i] = tmp_loc(tmp_indx++); - gencode(Tree2(n), r1[0]); /* generate code to compute x */ - gencode(Tree3(n), r1[1]); /* generate code compute i */ - - /* - * Allocate work area of temporary variables for arithmetic. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[0].lifetime = Tree3(n)->lifetime; - lifetm_ary[1].cur_status = Tree4(n)->postn; - lifetm_ary[1].lifetime = Tree4(n)->lifetime; - tmp_indx = alc_tmp(2, lifetm_ary); - for (i = 0; i < 2; ++i) - r2[i] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[1])); /* generate code to copy i */ - gencode(Tree4(n), r2[1]); /* generate code to compute j */ - - /* - * generate code for i op j. - */ - setloc(n); - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, r1[2], 0); - - /* - * generate code for x[i : (i op j)] - */ - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl1),impl1->ret_flag,r1[0],3,rslt,0); - free((char *)lifetm_ary); - break; - - case N_Slist: - bound(Tree0(n), &ignore, 1); - rslt = gencode(Tree1(n), rslt); - break; - - case N_SmplAsgn: { - struct val_loc *var, *val; - - /* - * Optimized assignment to a named variable. Use information - * from type inferencing to determine if the right-hand-side - * is a variable. - */ - var = var_ref(LSym0(Tree2(n))); - if (HasVar(varsubtyp(Tree3(n)->type, &single))) - Val0(n) = AsgnDeref; - if (single != NULL) { - /* - * Right-hand-side results in a named variable. Compute - * the expression but don't bother saving the result, we - * know what it is. Assignment just copies value from - * one variable to the other. - */ - gencode(Tree3(n), &ignore); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - gencode(Tree3(n), var); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = gencode(Tree3(n), NULL); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = gencode(Tree3(n), NULL); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct val_loc *var, *val; - - impl = Impl1(n); /* the operation */ - if (impl == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - implproto(impl); /* insure prototype for operation */ - - /* - * Generate code to compute the arguments for the operation. - */ - frst_arg = gen_args(n, 2, 2); - setloc(n); - - /* - * Use information from type inferencing to determine if the - * operation produces a variable. - */ - if (HasVar(varsubtyp(Typ4(n), &single))) - Val0(n) = AsgnDeref; - var = var_ref(LSym0(Tree2(n))); - if (single != NULL) { - /* - * The operation results in a named variable. Call the operation - * but don't bother saving the result, we know what it is. - * Assignment just copies value from one variable to the other. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - &ignore, 0); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - var, 0); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - - /* - * Free any temporaries whose lifetime ends at this node. - */ - freetmp = n->freetmp; - while (freetmp != NULL) { - switch (freetmp->kind) { - case DescTmp: - tmp_status[freetmp->indx] = freetmp->old; - break; - case CIntTmp: - itmp_status[freetmp->indx] = freetmp->old; - break; - case CDblTmp: - dtmp_status[freetmp->indx] = freetmp->old; - break; - case SBuf: - sbuf_status[freetmp->indx] = freetmp->old; - break; - case CBuf: - cbuf_status[freetmp->indx] = freetmp->old; - break; - } - ft = freetmp->next; - freetmp->next = freetmp_pool; - freetmp_pool = freetmp; - freetmp = ft; - } - return rslt; - } - -/* - * chk_alc - make sure a result location has been allocated. If it is - * a temporary variable, indicate that it is now in use. - */ -struct val_loc *chk_alc(rslt, lifetime) -struct val_loc *rslt; -nodeptr lifetime; - { - struct tmplftm tmplftm; - - if (rslt == NULL) { - if (lifetime == NULL) - rslt = &ignore; - else { - tmplftm.cur_status = InUse; - tmplftm.lifetime = lifetime; - rslt = tmp_loc(alc_tmp(1, &tmplftm)); - } - } - else if (rslt->loc_type == V_Temp) - tmp_status[rslt->u.tmp] = InUse; - return rslt; - } - -/* - * mk_goto - make a code structure for goto label - */ -struct code *mk_goto(label) -struct code *label; - { - register struct code *cd; - - cd = NewCode(1); /* # fields == # fields of C_RetSig & C_Break */ - cd->cd_id = C_Goto; - cd->next = NULL; - cd->prev = NULL; - cd->Lbl = label; - ++label->RefCnt; - return cd; - } - -/* - * mk_cpyval - make code to copy a value from one location to another. - */ -static struct code *mk_cpyval(loc1, loc2) -struct val_loc *loc1; -struct val_loc *loc2; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = loc2; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - return cd; - } - -/* - * asgn_null - make code to assign the null value to a location. - */ -static struct code *asgn_null(loc1) -struct val_loc *loc1; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nulldesc;"; - return cd; - } - -/* - * oper_name - create the name for the most general implementation of an Icon - * operation. - */ -static char *oper_name(impl) -struct implement *impl; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "%c%c%c_%s", impl->oper_typ, impl->prefix[0], impl->prefix[1], - impl->name); - return sbuf; - } - -/* - * gen_args - generate code to evaluate an argument list. - */ -static struct val_loc *gen_args(n, frst_arg, nargs) -struct node *n; -int frst_arg; -int nargs; - { - struct tmplftm *lifetm_ary; - int i; - int tmp_indx; - - if (nargs == 0) - return NULL; - - lifetm_ary = alc_lftm(nargs, &n->n_field[frst_arg]); - tmp_indx = alc_tmp(nargs, lifetm_ary); - for (i = 0; i < nargs; ++i) - gencode(n->n_field[frst_arg + i].n_ptr, tmp_loc(tmp_indx + i)); - free((char *)lifetm_ary); - return tmp_loc(tmp_indx); - } - -/* - * gen_case - generate code for a case expression. - */ -static struct val_loc *gen_case(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *control; - struct node *cases; - struct node *deflt; - struct node *clause; - struct val_loc *r1; - struct val_loc *r2; - struct val_loc *r3; - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *skp_lbl; - struct code *cd_lbl; - struct code *end_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont = NULL; - - control = Tree0(n); - cases = Tree1(n); - deflt = Tree2(n); - - /* - * The control clause is bounded. - */ - r1 = chk_alc(NULL, n); - bound(control, r1, 0); - - /* - * Remember the context in which the case expression occurs and - * establish a label at the end of the expression. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - end_lbl = alc_lbl("end case", 0); - cd_add(end_lbl); - cur_fnc->cursor = end_lbl->prev; /* generate code before the end label */ - - /* - * All cases share the result location of the case expression. - */ - rslt = chk_alc(rslt, n->lifetime); - r2 = chk_alc(NULL, n); /* for result of selection clause */ - r3 = chk_alc(NULL, n); /* for dereferenced result of control clause */ - - while (cases != NULL) { - /* - * See if we are at the end of the case clause list. - */ - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * If the evaluation of the selection code or the comparison of - * its value to the control clause fail, execution will proceed - * to the "skip clause" label and on to the next case. - */ - skp_lbl = alc_lbl("skip clause", 0); - on_failure = skp_lbl; - cd_add(skp_lbl); - cur_fnc->cursor = skp_lbl->prev; /* generate code before end label */ - - /* - * Bound the selection code for this clause. - */ - cd_lbl = alc_lbl("selected code", Bounding); - cd_add(cd_lbl); - cur_fnc->cursor = cd_lbl->prev; - gencode(Tree0(clause), r2); - - /* - * Dereference the results of the control clause and the selection - * clause and compare them. - */ - setloc(clause); - deref_cd(r1, r3); - deref_cd(r2, r2); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!equiv(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = r3; - cd->Cond = cd1; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = r2; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - cd_add(sig_cd(cd_lbl, cur_fnc)); /* transfer control to bounding label */ - - /* - * Generate code for the body of this clause after the bounding label. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cd_lbl; - on_failure = fail_sav; - gencode(Tree1(clause), rslt); - - /* - * If this clause is a generator, call the success continuation - * for the case expression, otherwise branch to the end of the - * expression. - */ - if (cur_fnc->cursor->next != skp_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); /* allocate a continuation function */ - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - else - cd_add(mk_goto(end_lbl)); - - /* - * The code for the next clause goes after the "skip" label of - * this clause. - */ - cur_fnc->cursor = skp_lbl; - } - - if (deflt == NULL) - cd_add(sig_cd(fail_sav, cur_fnc)); /* default action is failure */ - else { - /* - * There is an explicit default action. - */ - on_failure = fail_sav; - gencode(deflt, rslt); - if (cur_fnc->cursor->next != end_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - } - cur_fnc->cursor = end_lbl; - - /* - * If some clauses are generators but others have transferred control - * to here, we must call the success continuation of the case - * expression and generate subsequent code there. - */ - if (succ_cont != NULL) { - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - } - return rslt; - } - -/* - * gen_creat - generate code to create a co-expression. - */ -static struct val_loc *gen_creat(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *fail_sav; - struct code *fail_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct val_loc *co_rslt; - struct freetmp *ft; - char sav_prfx[PrfxSz]; - int *tmp_sv; - int *itmp_sv; - int *dtmp_sv; - int *sbuf_sv; - int *cbuf_sv; - int ntmp_sv; - int nitmp_sv; - int ndtmp_sv; - int nsbuf_sv; - int ncbuf_sv; - int stat_sz_sv; - int istat_sz_sv; - int dstat_sz_sv; - int sstat_sz_sv; - int cstat_sz_sv; - int i; - - - rslt = chk_alc(rslt, n->lifetime); - - fail_sav = on_failure; - fnc_sav = cur_fnc; - for (i = 0; i < PrfxSz; ++i) - sav_prfx[i] = frm_prfx[i]; - - /* - * Temporary variables are allocated independently for the co-expression. - */ - tmp_sv = tmp_status; - itmp_sv = itmp_status; - dtmp_sv = dtmp_status; - sbuf_sv = sbuf_status; - cbuf_sv = cbuf_status; - stat_sz_sv = status_sz; - istat_sz_sv = istatus_sz; - dstat_sz_sv = dstatus_sz; - sstat_sz_sv = sstatus_sz; - cstat_sz_sv = cstatus_sz; - ntmp_sv = num_tmp; - nitmp_sv = num_itmp; - ndtmp_sv = num_dtmp; - nsbuf_sv = num_sbuf; - ncbuf_sv = num_cbuf; - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Put code for co-expression in separate function. We will need a new - * type of procedure frame which contains copies of local variables, - * copies of arguments, and temporaries for use by the co-expression. - */ - fnc = alc_fnc(); - fnc->ref_cnt = 1; - fnc->flag |= CF_Coexpr; - ChkPrefix(fnc->prefix); - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = fnc->frm_prfx[i] = fnc->prefix[i]; - cur_fnc = fnc; - - /* - * Set up a co-expression failure label followed by a context switch - * and a branch back to the failure label. - */ - fail_lbl = alc_lbl("co_fail", 0); - cd_add(fail_lbl); - lastline = 0; /* force setting line number so tracing matches interp */ - setloc(n); - cd = alc_ary(2); - cd->ElemTyp(0) = A_Str; - cd->ElemTyp(1) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)),"; - cd->Str(1) = "NULL, NULL, A_Cofail, 1);"; - cd_add(cd); - cd_add(mk_goto(fail_lbl)); - cur_fnc->cursor = fail_lbl->prev; /* code goes before failure label */ - on_failure = fail_lbl; - - /* - * Generate code for the co-expression body, using the same - * dereferencing rules as for procedure return. - */ - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - ++create_lvl; - co_rslt = genretval(n, Tree0(n), NULL); - --create_lvl; - - /* - * If the co-expression might produce a result, generate a co-expression - * context switch. - */ - if (co_rslt != NULL) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "++BlkLoc(k_current)->coexpr.size;"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)), &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = co_rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL, A_Coret, 1);"; - cd_add(cd); - cd_add(sig_cd(on_failure, cur_fnc)); /* if reactivated, resume expr */ - } - - /* - * Output the new frame definition. - */ - prt_frame(frm_prfx, cur_proc->tnd_loc + num_tmp + Abs(cur_proc->nargs), - num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Now return to original function and produce code to create the - * co-expression. - */ - cur_fnc = fnc_sav; - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = sav_prfx[i]; - on_failure = fail_sav; - - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - cd = NewCode(5); - cd->cd_id = C_Create; - cd->Rslt = rslt; - cd->Cont = fnc; - cd->NTemps = num_tmp; - cd->WrkSize = num_itmp; - cd->NextCreat = cur_fnc->creatlst; - cur_fnc->creatlst = cd; - cd_add(cd); - - /* - * Restore arrays for temporary variable allocation. - */ - free((char *)tmp_status); - free((char *)itmp_status); - free((char *)dtmp_status); - free((char *)sbuf_status); - free((char *)cbuf_status); - tmp_status = tmp_sv; - itmp_status = itmp_sv; - dtmp_status = dtmp_sv; - sbuf_status = sbuf_sv; - cbuf_status = cbuf_sv; - status_sz = stat_sz_sv; - istatus_sz = istat_sz_sv; - dstatus_sz = dstat_sz_sv; - sstatus_sz = sstat_sz_sv; - cstatus_sz = cstat_sz_sv; - num_tmp = ntmp_sv; - num_itmp = nitmp_sv; - num_dtmp = ndtmp_sv; - num_sbuf = nsbuf_sv; - num_cbuf = ncbuf_sv; - - /* - * Temporary variables that exist to the end of the co-expression - * have no meaning in the surrounding code and must not be - * deallocated there. - */ - while (n->freetmp != NULL) { - ft = n->freetmp->next; - n->freetmp->next = freetmp_pool; - freetmp_pool = n->freetmp; - n->freetmp = ft; - } - - return rslt; - } - -/* - * gen_lim - generate code for limitation. - */ -static struct val_loc *gen_lim(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *expr; - struct node *limit; - struct val_loc *lim_desc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct code *fail_sav; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont; - struct val_loc *lim_int; - struct lentry *single; - int deref; - - expr = Tree0(n); - limit = Tree1(n); - - /* - * Generate code to compute the limitation value and dereference it. - */ - deref = HasVar(varsubtyp(limit->type, &single)); - if (single != NULL) { - /* - * Limitation is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(limit, &ignore); - lim_desc = var_ref(single); - } - else { - lim_desc = gencode(limit, NULL); - if (deref) - deref_cd(lim_desc, lim_desc); - } - - setloc(n); - fail_sav = on_failure; - - /* - * Try to convert the limitation value into an integer. - */ - lim_int = itmp_loc(alc_itmp(n->intrnl_lftm)); - cur_symtyps = n->symtyps; - if (largeints || (eval_is(int_typ, 0) & MaybeFalse)) { - /* - * Must call the conversion routine. - */ - lbl = alc_lbl("limit is int", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* conversion goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_c_int(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_desc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = lim_int; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(101, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - /* - * The C integer is in the vword. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = lim_int; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = IntVal("; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = lim_desc; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - } - - /* - * Make sure the limitation value is positive. - */ - lbl = alc_lbl("limit positive", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " >= 0"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(205, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - - /* - * If the limitation value is 0, fail immediately. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * Establish where to go when limit has been reached. - */ - fnc_sav = cur_fnc; - lbl = alc_lbl("limit", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* limited expression goes before label */ - - /* - * Generate code for limited expression and to check the limit value. - */ - rslt = gencode(expr, rslt); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "--"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_int; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(lbl, cur_fnc); - cd_add(cd); - - /* - * Call the success continuation both here and after the limitation - * label. - */ - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl; - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - - return rslt; - } - -/* - * gen_apply - generate code for the apply operator, !. - */ -static struct val_loc *gen_apply(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct val_loc *callee; - struct val_loc *lst; - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - - /* - * Generate code to compute the two operands. - */ - callee = gencode(Tree0(n), NULL); - lst = gencode(Tree1(n), NULL); - rslt = chk_alc(rslt, n->lifetime); - setloc(n); - - /* - * Construct argument list for apply(). - */ - arg_lst = alc_ary(6); - arg_lst->ElemTyp(0) = A_Str; - arg_lst->Str(0) = "&"; - arg_lst->ElemTyp(1) = A_ValLoc; - arg_lst->ValLoc(1) = callee; - arg_lst->ElemTyp(2) = A_Str; - arg_lst->Str(2) = ", &"; - arg_lst->ElemTyp(3) = A_ValLoc; - arg_lst->ValLoc(3) = lst; - arg_lst->ElemTyp(4) = A_Str; - arg_lst->Str(4) = ", &"; - arg_lst->ElemTyp(5) = A_ValLoc; - arg_lst->ValLoc(5) = rslt; - - /* - * Generate code to call apply(). Assume the operation can suspend and - * allocate a continuation. If it returns a "continue" signal, - * just break out of the signal handling code and fall into a call - * to the continuation. - */ - on_ret = NewCode(1); /* #fields for C_Break == #fields for C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - fnc = alc_fnc(); /* success continuation */ - callo_add("apply", DoesFail | DoesRet | DoesSusp, fnc, 1, arg_lst, on_ret); - callc_add(fnc); - cur_fnc = fnc; /* subsequent code goes in the continuation */ - on_failure = &resume; - - return rslt; - } - - -/* - * gen_scan - generate code for string scanning. - */ -static struct val_loc *gen_scan(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *subj; - struct node *body; - struct scan_info *scanp; - struct val_loc *asgn_var; - struct val_loc *new_subj; - struct val_loc *scan_rslt; - struct tmplftm *lifetm_ary; - struct lentry *subj_single; - struct lentry *body_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int subj_deref; - int body_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node '?' or '?:=' */ - subj = Tree1(n); /* subject expression */ - body = Tree2(n); /* scanning expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * The location of the save areas for scanning environments is stored - * in list so they can be accessed by expressions that transfer - * control out of string scanning. Get the next list element and - * allocate the save areas in the procedure frame. - */ - scanp = nxt_scan; - if (nxt_scan->next == NULL) - nxt_scan->next = NewStruct(scan_info); - nxt_scan = nxt_scan->next; - scanp->outer_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->outer_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - scanp->inner_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->inner_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - - subj_deref = HasVar(varsubtyp(subj->type, &subj_single)); - if (subj_single != NULL) { - /* - * The subject value is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(subj, &ignore); - new_subj = var_ref(subj_single); - - if (op_tok == AUGQMARK) { - body_deref = HasVar(varsubtyp(body->type, &body_single)); - if (body_single != NULL) - scan_rslt = &ignore; /* we know where the value will be */ - else - scan_rslt = chk_alc(NULL, n->intrnl_lftm); - } - else - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - else if (op_tok == AUGQMARK) { - /* - * Augmented string scanning using general assignment. The operands - * must be in consecutive locations. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn_var = tmp_loc(tmp_indx++); - scan_rslt = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - gencode(subj, asgn_var); - new_subj = chk_alc(NULL, n->intrnl_lftm); - deref_cd(asgn_var, new_subj); - } - else { - new_subj = gencode(subj, NULL); - if (subj_deref) - deref_cd(new_subj, new_subj); - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - - /* - * Produce code to save the old scanning environment. - */ - setloc(op); - save_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle failure of the body of string scanning. - */ - lbl = alc_lbl("scan fail", 0); - cd_add(lbl); - restr_env(scanp->outer_sub, scanp->outer_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* body goes before label */ - on_failure = lbl; - - /* - * If necessary, try to convert the subject to a string. Note that if - * error conversion occurs, backtracking will restore old subject. - */ - cur_symtyps = n->symtyps; - if (eval_is(str_typ, 0) & MaybeFalse) { - lbl = alc_lbl("&subject is string", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_str(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = new_subj; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &k_subject)"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(103, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = 1;"; - cd_add(cd); - - scan_rslt = gencode(body, scan_rslt); - - setloc(op); - if (op_tok == AUGQMARK) { - /* - * '?:=' - perform assignment. - */ - if (subj_single != NULL) { - /* - * Assignment to a named variable. - */ - if (body_single != NULL) - cd_add(mk_cpyval(new_subj, var_ref(body_single))); - else if (body_deref) - deref_cd(scan_rslt, new_subj); - else - cd_add(mk_cpyval(new_subj, scan_rslt)); - } - else { - /* - * Use general assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, asgn_var, 2, rslt,0); - } - } - } - else { - /* - * '?' - */ - rslt = scan_rslt; - } - - /* - * Produce code restore subject and pos when the body of the - * scanning expression succeeds. The new subject and pos must - * be saved in case of resumption. - */ - save_env(scanp->inner_sub, scanp->inner_pos); - restr_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle resumption of string scanning. - */ - lbl = alc_lbl("scan resume", 0); - cd_add(lbl); - save_env(scanp->outer_sub, scanp->outer_pos); - restr_env(scanp->inner_sub, scanp->inner_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* success continuation goes before label */ - on_failure = lbl; - - nxt_scan = scanp; - return rslt; - } - -/* - * gen_act - generate code for co-expression activation. - */ -static struct val_loc *gen_act(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *transmit; - struct node *coexpr; - struct tmplftm *lifetm_ary; - struct val_loc *trans_loc; - struct val_loc *coexpr_loc; - struct val_loc *asgn1; - struct val_loc *asgn2; - struct val_loc *act_rslt; - struct lentry *c_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int c_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node for '@' or '@:=' */ - transmit = Tree1(n); /* expression for value to transmit */ - coexpr = Tree2(n); /* expression for co-expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * Produce code for the value to be transmitted. - */ - if (op_tok == AUGAT) { - /* - * Augmented activation. This is seldom used so don't try too - * hard to optimize it. Allocate contiguous temporaries for - * the operands to the assignment. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn1 = tmp_loc(tmp_indx++); - asgn2 = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - /* - * Generate code to produce the left-hand-side of the assignment. - * This is also the transmitted value. Activation may need a - * dereferenced value, so this must be in a different location. - */ - gencode(transmit, asgn1); - trans_loc = chk_alc(NULL, n->intrnl_lftm); - setloc(op); - deref_ret(asgn1, trans_loc, varsubtyp(transmit->type, NULL)); - } - else - trans_loc = genretval(op, transmit, NULL); /* ordinary activation */ - - /* - * Determine if the value to be activated needs dereferencing, and - * see if it can only come from a single named variable. - */ - c_deref = HasVar(varsubtyp(coexpr->type, &c_single)); - if (c_single == NULL) { - /* - * The value is something other than a single named variable. - */ - coexpr_loc = gencode(coexpr, NULL); - if (c_deref) - deref_cd(coexpr_loc, coexpr_loc); - } - else { - /* - * The value is in a named variable. Use it directly from the - * variable rather than saving the result of the expression. - */ - gencode(coexpr, &ignore); - coexpr_loc = var_ref(c_single); - } - - /* - * Make sure the value to be activated is a co-expression. Perform - * run-time checking if necessary. - */ - cur_symtyps = n->symtyps; - if (eval_is(coexp_typ, 1) & MaybeFalse) { - lbl = alc_lbl("is co-expression", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = coexpr_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Coexpr"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(118, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = coexpr_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - /* - * Make sure a result location has been allocated. For ordinary - * activation, this is where activate() puts its result. For - * augmented activation, this is where assignment puts its result. - */ - rslt = chk_alc(rslt, n->lifetime); - if (op_tok == AUGAT) - act_rslt = asgn2; - else - act_rslt = rslt; - - /* - * Generate code to call activate(). - */ - setloc(n); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(7); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "activate(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = trans_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (struct b_coexpr *)BlkLoc("; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = coexpr_loc; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = "), &"; - cd1->ElemTyp(5) = A_ValLoc; - cd1->ValLoc(5) = act_rslt; - cd1->ElemTyp(6) = A_Str; - cd1->Str(6) = ") == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * For augmented activation, generate code to call assignment. - */ - if (op_tok == AUGAT) { - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, asgn1, 2, rslt, 0); - } - } - - return rslt; - } - -/* - * save_env - generate code to save scanning environment. - */ -static void save_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = sub_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_subject;"; - cd_add(cd); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = pos_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_pos;"; - cd_add(cd); - } - -/* - * restr_env - generate code to restore scanning environment. - */ -static void restr_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = sub_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = pos_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - -/* - * mk_callop - produce the code to directly call an operation. - */ -static void mk_callop(oper_nm, ret_flag, arg1rslt, nargs, rslt, optim) -char *oper_nm; -int ret_flag; -struct val_loc *arg1rslt; -int nargs; -struct val_loc *rslt; -int optim; - { - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - int n; - int need_cont; - - /* - * If this operation can return an "continue" signal, we will need - * a break statement in the signal switch to handle it. - */ - if (ret_flag & DoesRet) { - on_ret = NewCode(1); /* #fields == #fields C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - } - else - on_ret = NULL; - - /* - * Construct argument list for the C function implementing the - * operation. First compute the size of the code array for the - * argument list; this varies if we are using an optimized calling - * interface. - */ - if (optim) { - n = 0; - if (arg1rslt != NULL) - n += 2; - if (ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) - ++n; - n += 2; - } - } - else - n = 7; - if (n == 0) - arg_lst = NULL; - else { - arg_lst = alc_ary(n); - n = 0; - if (!optim) { - arg_lst->ElemTyp(n) = A_Intgr; /* number of arguments */ - arg_lst->Intgr(n) = nargs; - ++n; - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - if (arg1rslt == NULL) { /* location of first argument */ - if (!optim) { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "NULL"; - ++n; - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = ""; /* nothing, but must fill slot */ - ++n; - } - } - else { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = arg1rslt; - ++n; - } - if (!optim || ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) { - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - arg_lst->ElemTyp(n) = A_Str; /* location of result */ - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = rslt; - } - } - - /* - * Generate code to call the operation and handle returned signals. - */ - if (ret_flag & DoesSusp) { - /* - * The operation suspends, so call it with a continuation, then - * proceed to generate code in the continuation. - */ - fnc = alc_fnc(); - callo_add(oper_nm, ret_flag, fnc, 1, arg_lst, on_ret); - if (ret_flag & DoesRet) - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - } - else { - /* - * No continuation is needed, but if standard calling conventions - * are used, a NULL continuation argument is required. - */ - if (optim) - need_cont = 0; - else - need_cont = 1; - callo_add(oper_nm, ret_flag, NULL, need_cont, arg_lst, on_ret); - } -} - -/* - * genretval - generate code for the expression in a return/suspend or - * for the expression for the value to be transmitted in a co-expression - * context switch. - */ -static struct val_loc *genretval(n, expr, dest) -struct node *n; -struct node *expr; -struct val_loc *dest; - { - int subtypes; - struct lentry *single; - struct val_loc *val; - - subtypes = varsubtyp(expr->type, &single); - - /* - * If we have a single local or argument, we don't need to construct - * a variable reference; we need the value and we know where it is. - */ - if (single != NULL && (subtypes & (HasLcl | HasPrm))) { - gencode(expr, &ignore); - val = var_ref(single); - if (dest == NULL) - dest = val; - else - cd_add(mk_cpyval(dest, val)); - } - else { - dest = gencode(expr, dest); - setloc(n); - deref_ret(dest, dest, subtypes); - } - - return dest; - } - -/* - * deref_ret - produced dereferencing code for values returned from - * procedures or transmitted to co-expressions. - */ -static void deref_ret(src, dest, subtypes) -struct val_loc *src; -struct val_loc *dest; -int subtypes; - { - struct code *cd; - struct code *lbl; - - if (src == NULL) - return; /* no value to dereference */ - - /* - * If there may be values that do not need dereferencing, insure that the - * values are in the destination and make it the source of dereferencing. - */ - if ((subtypes & (HasVal | HasGlb)) && (src != dest)) { - cd_add(mk_cpyval(dest, src)); - src = dest; - } - - if (subtypes & (HasLcl | HasPrm)) { - /* - * Some values may need to be dereferenced. - */ - lbl = NULL; - if (subtypes & HasVal) { - /* - * We may have a non-variable and must check at run time. - */ - lbl = check_var(dest, NULL); - } - - if (subtypes & HasGlb) { - /* - * Make sure we don't dereference any globals, use retderef(). - */ - if (subtypes & HasLcl) { - /* - * We must dereference any locals. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = - ", (word *)pfp->tend.d, (word *)(pfp->tend.d + pfp->tend.num));"; - cd_add(cd); - /* - * We may now have a value. We must check at run-time and skip - * any attempt to dereference an argument. - */ - lbl = check_var(dest, lbl); - } - - if (subtypes & HasPrm) { - /* - * We must dereference any arguments. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", (word *)glbl_argp, (word *)(glbl_argp + "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = Abs(cur_proc->nargs); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - } - } - else /* No globals */ - deref_cd(src, dest); - - if (lbl != NULL) - cur_fnc->cursor = lbl; /* continue after label */ - } - } - -/* - * check_var - generate code to make sure a descriptor contains a variable - * reference. If no label is given to jump to for a non-variable, allocate - * one and generate code before it. - */ -static struct code *check_var(d, lbl) -struct val_loc *d; -struct code *lbl; - { - struct code *cd, *cd1; - - if (lbl == NULL) { - lbl = alc_lbl("not variable", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - } - - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!Var("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = d; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - - return lbl; - } - -/* - * field_ref - generate code for a field reference. - */ -static struct val_loc *field_ref(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *rec; - struct node *fld; - struct fentry *fp; - struct par_rec *rp; - struct val_loc *rec_loc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct lentry *single; - int deref; - int num_offsets; - int offset; - int bad_recs; - - rec = Tree0(n); - fld = Tree1(n); - - /* - * Generate code to compute the record value and dereference it. - */ - deref = HasVar(varsubtyp(rec->type, &single)); - if (single != NULL) { - /* - * The record is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(rec, &ignore); - rec_loc = var_ref(single); - } - else { - rec_loc = gencode(rec, NULL); - if (deref) - deref_cd(rec_loc, rec_loc); - } - - setloc(fld); - - /* - * Make sure the operand is a record. - */ - cur_symtyps = n->symtyps; - if (eval_is(rec_typ, 0) & MaybeFalse) { - lbl = alc_lbl("is record", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rec_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Record"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(107, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - rslt = chk_alc(rslt, n->lifetime); - - /* - * Find the list of records containing this field. - */ - if ((fp = flookup(Str0(fld))) == NULL) { - nfatal(n, "invalid field", Str0(fld)); - return rslt; - } - - /* - * Generate code for declarations and to get the record block pointer. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "{"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "struct b_record *r_rp = (struct b_record *) BlkLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "int r_must_fail = 0;"; - cd_add(cd); - } - - /* - * Determine which records are in the record type. - */ - mark_recs(fp, cur_symtyps->types[0], &num_offsets, &offset, &bad_recs); - - /* - * Generate code to insure that the field belongs to the record - * and to index into the record block. - */ - if (num_offsets == 1 && !bad_recs) { - /* - * We already know the offset of the field. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)&r_rp->fields["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = offset; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "] - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - for (rp = fp->rlist; rp != NULL; rp = rp->next) - rp->mark = 0; - } - else { - /* - * The field appears in several records. generate code to determine - * which one it is. - */ - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "dptr r_dp;"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "switch (r_rp->recdesc->proc.recnum) {"; - cd_add(cd); - - rp = fp->rlist; - while (rp != NULL) { - offset = rp->offset; - while (rp != NULL && rp->offset == offset) { - if (rp->mark) { - rp->mark = 0; - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " case "; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = rp->rec->rec_num; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ":"; - cd_add(cd); - } - rp = rp->next; - } - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_dp = &r_rp->fields["; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = offset; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "];"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " break;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " default:"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " err_msg(207, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - /* - * The peephole analyzer doesn't know how to handle a goto or return - * in a switch statement, so just set a flag here. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_must_fail = 1;"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " }"; - cd_add(cd); - if (err_conv) { - /* - * Now that we are out of the switch statement, see if the flag - * was set to indicate error conversion. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "r_must_fail"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)r_dp - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "}"; - cd_add(cd); - return rslt; - } - -/* - * bound - bound the code for the given sub-tree. If catch_fail is true, - * direct failure to the bounding label. - */ -static struct val_loc *bound(n, rslt, catch_fail) -struct node *n; -struct val_loc *rslt; -int catch_fail; - { - struct code *lbl1; - struct code *fail_sav; - struct c_fnc *fnc_sav; - - fnc_sav = cur_fnc; - fail_sav = on_failure; - - lbl1 = alc_lbl("bound", Bounding); - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - if (catch_fail) - on_failure = lbl1; - - rslt = gencode(n, rslt); - - cd_add(sig_cd(lbl1, cur_fnc)); /* transfer control to bounding label */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl1; - - on_failure = fail_sav; - return rslt; - } - -/* - * cd_add - add a code struct at the cursor in the current function. - */ -void cd_add(cd) -struct code *cd; - { - register struct code *cursor; - - cursor = cur_fnc->cursor; - - cd->next = cursor->next; - cd->prev = cursor; - if (cursor->next != NULL) - cursor->next->prev = cd; - cursor->next = cd; - cur_fnc->cursor = cd; - } - -/* - * sig_cd - convert a signal/label into a goto or return signal in - * the context of the given function. - */ -struct code *sig_cd(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct code *cd; - - if (sig->cd_id == C_Label && sig->Container == fnc) - return mk_goto(sig); - else { - cd = NewCode(1); /* # fields <= # fields of C_Goto */ - cd->cd_id = C_RetSig; - cd->next = NULL; - cd->prev = NULL; - cd->SigRef = add_sig(sig, fnc); - return cd; - } - } - -/* - * add_sig - add signal to list of signals returned by function. - */ -struct sig_lst *add_sig(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct sig_lst *sl; - - for (sl = fnc->sig_lst; sl != NULL && sl->sig != sig; sl = sl->next) - ; - if (sl == NULL) { - sl = NewStruct(sig_lst); - sl->sig = sig; - sl->ref_cnt = 1; - sl->next = fnc->sig_lst; - fnc->sig_lst = sl; - } - else - ++sl->ref_cnt; - return sl; - } - -/* - * callc_add - add code to call a continuation. Note the action to be - * taken if the continuation returns resumption. The actual list - * signals returned and actions to take will be figured out after - * the continuation has been optimized. - */ -void callc_add(cont) -struct c_fnc *cont; - { - struct code *cd; - - cd = new_call(); - cd->OperName = NULL; - cd->Cont = cont; - cd->ArgLst = NULL; - cd->ContFail = on_failure; - cd->SigActs = NULL; - ++cont->ref_cnt; - } - -/* - * callo_add - add code to call an operation. - */ -void callo_add(oper_nm, ret_flag, cont, need_cont, arglist, on_ret) -char *oper_nm; -int ret_flag; -struct c_fnc *cont; -int need_cont; -struct code *arglist; -struct code *on_ret; - { - struct code *cd; - struct code *cd1; - - cd = new_call(); - cd->OperName = oper_nm; - cd->Cont = cont; - if (need_cont) - cd->Flags = NeedCont; - cd->ArgLst = arglist; - cd->ContFail = NULL; /* operation handles failure from the continuation */ - /* - * Decide how to handle the signals produced by the operation. (Those - * produced by the continuation will be examined after the continuation - * is optimized.) - */ - cd->SigActs = NULL; - if (MightFail(ret_flag)) - cd->SigActs = new_sgact(&resume, sig_cd(on_failure,cur_fnc), cd->SigActs); - if (ret_flag & DoesRet) - cd->SigActs = new_sgact(&contin, on_ret, cd->SigActs); - if (ret_flag & DoesFThru) { - cd1 = NewCode(1); /* #fields == #fields C_Goto */ - cd1->cd_id = C_Break; - cd1->next = NULL; - cd1->prev = NULL; - cd->SigActs = new_sgact(&fallthru, cd1, cd->SigActs); - } - if (cont != NULL) - ++cont->ref_cnt; /* increment reference count */ -} - -/* - * Create a call, add it to the code for the current function, and - * add it to the list of calls from the current function. - */ -static struct code *new_call() - { - struct code *cd; - - cd = NewCode(7); - cd->cd_id = C_CallSig; - cd_add(cd); - cd->Flags = 0; - cd->NextCall = cur_fnc->call_lst; - cur_fnc->call_lst = cd; - return cd; - } - -/* - * sig_act - create a new binding of an action to a signal. - */ -struct sig_act *new_sgact(sig, cd, next) -struct code *sig; -struct code *cd; -struct sig_act *next; - { - struct sig_act *sa; - - sa = NewStruct(sig_act); - sa->sig = sig; - sa->cd = cd; - sa->shar_act = NULL; - sa->next = next; - return sa; - } - - -#ifdef OptimizeLit -static int instr(const char *str, int chr) { - int i, found, go; - - found = 0; go = 1; - for(i=0; ((str[i] != '\0') && go) ;i++) { - if (str[i] == chr) { - go = 0; - found = 1; - if ((str[i+1] != '\0') && (chr == '=')) - if (str[i+1] == '=') - found = 0; - if ((chr == '=') && (i > 0)) { - if (str[i-1] == '>') - found = 0; - else if (str[i-1] == '<') - found = 0; - else if (str[i-1] == '!') - found = 0; - } - } - } - return found; -} - -static void tbl_add(struct lit_tbl *add) { - struct lit_tbl *ins; - static struct lit_tbl *ptr = NULL; - int go = 1; - - if (tbl == NULL) { - tbl = add; - ptr = add; - } - else { - ins = ptr; - while ((ins != NULL) && go) { - if (add->index != ins->index) - ins = ins->prev; - else - go = 0; - } - if (ins != NULL) { - if (ins->end == NULL) - ins->end = add->initial; - } - ptr->next = add; - add->prev = ptr; - ptr = add; - } -} - - -static void invalidate(struct val_loc *val, struct code *end, int code) { - struct lit_tbl *ptr, *back; - int index, go = 1; - - if (val == NULL) - return; - if (val->loc_type == V_NamedVar) { - index = val->u.nvar->val.index; - return; - } - else if (val->loc_type == V_Temp) - index = val->u.tmp + cur_proc->tnd_loc; - else - return; - if (tbl == NULL) - return; - back = tbl; - while (back->next != NULL) - back = back->next; - go = 1; - for(ptr=back; ((ptr != NULL) && go) ; ptr=ptr->prev) { - if ((ptr->index == index) && (ptr->modified != NO_TOUCH)) { - ptr->modified = code; - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if ((ptr->index == index) && (ptr->modified == NO_TOUCH)) { - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if (ptr->index == index) - go = 0; - } -} - - -static int eval_code(struct code *cd, struct lit_tbl *cur) { - struct code *tmp; - struct lit_tbl *tmp_tbl; - int i, j; - char *str; - - for (i=0; cd->ElemTyp(i) != A_End ;i++) { - switch(cd->ElemTyp(i)) { - case A_ValLoc: - if (cd->ValLoc(i)->mod_access != M_CInt) - break; - if ((cd->ValLoc(i)->u.tmp + cur_proc->tnd_loc) == cur->index) { - switch (cd->ValLoc(i)->loc_type) { - case V_Temp: - if (cur->csym->flag == F_StrLit) { -#if 0 - cd->ElemTyp(i) = A_Str; - str = (char *)alloc(strlen(cur->csym->image)+8); - sprintf(str, "\"%s\"/*Z*/", cur->csym->image); - cd->Str(i) = str; -#endif - } - else if (cur->csym->flag == F_IntLit) { - cd->ElemTyp(i) = A_Str; - cd->Str(i) = cur->csym->image; - } - break; - default: - break; - } - } - break; - case A_Ary: - for(tmp=cd->Array(i); tmp != NULL ;tmp=tmp->next) - eval_code(tmp, cur); - break; - default: - break; - } - } -} - -static void propagate_literals() { - struct lit_tbl *ptr; - struct code *cd, *arg; - int ret; - - for(ptr=tbl; ptr != NULL ;ptr=ptr->next) { - if (ptr->modified != NO_TOUCH) { - for(cd=ptr->initial; cd != ptr->end ;cd=cd->next) { - switch (cd->cd_id) { - case C_If: - for(arg=cd->Cond; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - /* - * Again, don't take the 'then' portion. - * It might lead to infinite loops. - * for(arg=cd->ThenStmt; arg != NULL ;arg=arg->next) - * ret = eval_code(arg, ptr); - */ - break; - case C_CdAry: - ret = eval_code(cd, ptr); - break; - case C_CallSig: - for(arg=cd->ArgLst; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - break; - default: - break; - } - } - } - } -} - -/* - * analyze_literals - analyzes the generated code to replace - * complex record dereferences with C - * literals. - */ -static void analyze_literals(struct code *start, struct code *top, int lvl) { - struct code *ptr, *tmp, *not_null; - struct lit_tbl *new_tbl; - struct lbl_tbl *new_lbl; - struct val_loc *prev = NULL; - int i, inc=0, addr=0, assgn=0, equal = 0; - - for (ptr = start; ptr != NULL ; ptr = ptr->next) { - if (!lvl) - not_null = ptr; - else - not_null = top; - switch (ptr->cd_id) { - case C_NamedVar: - break; - case C_CallSig: - analyze_literals(ptr->ArgLst, not_null, lvl+1); - break; - case C_Goto: - break; - case C_Label: - break; - case C_Lit: - new_tbl = alc_tbl(); - new_tbl->initial = ptr; - new_tbl->vloc = ptr->Rslt; - new_tbl->csym = ptr->Literal; - switch (ptr->Rslt->loc_type) { - case V_NamedVar: - new_tbl->index = ptr->Rslt->u.nvar->val.index; - tbl_add(new_tbl); - break; - case V_Temp: - new_tbl->index = ptr->Rslt->u.tmp + cur_proc->tnd_loc; - tbl_add(new_tbl); - break; - default: - new_tbl->index = -1; - free(new_tbl); - break; - } - break; - case C_If: - analyze_literals(ptr->Cond, not_null, lvl+1); - /* - * Don't analyze the 'then' portion such as in: - * analyze_literals(ptr->ThenStmt, not_null, lvl+1); - * Apparently, all the intermediate code does is maintain - * a pointer to where the flow of execution jumps to in - * case the 'then' is taken. These are all goto statments - * and can result in infinite loops of analyzation. - */ - break; - case C_CdAry: - for(i=0; ptr->ElemTyp(i) != A_End ;i++) { - switch(ptr->ElemTyp(i)) { - case A_Str: - if (ptr->Str(i) != NULL) { - if ( (strstr(ptr->Str(i), "-=")) || - (strstr(ptr->Str(i), "+=")) || - (strstr(ptr->Str(i), "*=")) || - (strstr(ptr->Str(i), "/=")) ) - invalidate(prev, not_null, NO_TOUCH); - else if (instr(ptr->Str(i), '=')) { - invalidate(prev, not_null, LIMITED); - assgn = 1; - } - else if ( (strstr(ptr->Str(i), "++")) || - (strstr(ptr->Str(i), "--")) ) - inc = 1; - else if (instr(ptr->Str(i), '&')) - addr = 1; - else if (strstr(ptr->Str(i), "==")) - equal = 1; - } - break; - case A_ValLoc: - if (inc) { - invalidate(ptr->ValLoc(i), not_null, NO_TOUCH); - inc = 0; - } - if (addr) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - addr = 0; - } - if ((assgn) && (ptr->ValLoc(i)->mod_access == M_None)) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - assgn = 0; - } - else if (assgn) - assgn = 0; - if (equal) { - invalidate(ptr->ValLoc(i), not_null, LIMITED_TO_INT); - equal = 0; - } - prev = ptr->ValLoc(i); - break; - case A_Intgr: - break; - case A_SBuf: - break; - case A_Ary: - for(tmp=ptr->Array(i); tmp != NULL ;tmp=tmp->next) - analyze_literals(tmp, not_null, lvl+1); - break; - default: - break; - } - } - break; - default: - break; - } - } -} -#endif /* OptimizeLit */ - -/* - * analyze_poll - analyzes the internal C code representation from - * the position of the last Poll() function call to - * the current position in the code. - * Returns a 0 if the last Poll() function should not - * be removed. - */ -#ifdef OptimizePoll -static int analyze_poll(void) { - struct code *cursor, *ptr; - int cont = 1; - - ptr = lastpoll; - if (ptr == NULL) - return 0; - cursor = cur_fnc->cursor; - while ((cursor != ptr) && (ptr != NULL) && (cont)) { - switch (ptr->cd_id) { - case C_Null : - case C_NamedVar : - case C_Label : - case C_Lit : - case C_Resume : - case C_Continue : - case C_FallThru : - case C_PFail : - case C_Goto : - case C_Create : - case C_If : - case C_SrcLoc : - case C_CdAry : - break; - case C_CallSig : - case C_RetSig : - case C_LBrack : - case C_RBrack : - case C_PRet : - case C_PSusp : - case C_Break : - cont = 0; - break; - } - ptr = ptr->next; - } - return cont; -} - -/* - * remove_poll - removes the ccode structure that represents the last - * call to the "Poll()" function by simply changing the code ID to - * C_Null code. - */ -static void remove_poll(void) { - - if (lastpoll == NULL) - return; - lastpoll->cd_id = C_Null; -} -#endif /* OptimizePoll */ - -/* - * setloc produces code to set the file name and line number to the - * source location of node n. Code is only produced if the corresponding - * value has changed since the last time setloc was called. - */ -static void setloc(n) -nodeptr n; - { - struct code *cd; - static int count=0; - - if (n == NULL || File(n) == NULL || Line(n) == 0) - return; - - if (File(n) != lastfiln || Line(n) != lastline) { -#ifdef OptimizePoll - if (analyze_poll()) - remove_poll(); - cd = alc_ary(1); - lastpoll = cd; -#else /* OptimizePoll */ - cd = alc_ary(1); -#endif /* OptimizePoll */ - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "Poll();"; - cd_add(cd); - - if (line_info) { - cd = NewCode(2); - cd->cd_id = C_SrcLoc; - - if (File(n) == lastfiln) - cd->FileName = NULL; - else { - lastfiln = File(n); - cd->FileName = lastfiln; - } - - if (Line(n) == lastline) - cd->LineNum = 0; - else { - lastline = Line(n); - cd->LineNum = lastline; - } - - cd_add(cd); - } - } - } - -/* - * alc_ary - create an array for a sequence of code fragments. - */ -struct code *alc_ary(n) -int n; - { - struct code *cd; - static cnt=1; - - cd = NewCode(2 * n + 1); - cd->cd_id = C_CdAry; - cd->next = NULL; - cd->prev = NULL; - cd->ElemTyp(n) = A_End; - return cd; - } - - -/* - * alc_lbl - create a label. - */ -struct code *alc_lbl(desc, flag) -char *desc; -int flag; - { - register struct code *cd; - - cd = NewCode(5); - cd->cd_id = C_Label; - cd->next = NULL; - cd->prev = NULL; - cd->Container = cur_fnc; /* function containing label */ - cd->SeqNum = 0; /* sequence number is allocated later */ - cd->Desc = desc; /* identifying comment */ - cd->RefCnt = 0; /* reference count */ - cd->LabFlg = flag; - return cd; - } - -/* - * alc_fnc - allocate a function structure; - */ -static struct c_fnc *alc_fnc() - { - register struct c_fnc *cf; - int i; - - cf = NewStruct(c_fnc); - cf->prefix[0] = '\0'; /* prefix is allocated later */ - cf->prefix[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->flag = 0; - for (i = 0; i < PrfxSz; ++i) - cf->frm_prfx[i] = frm_prfx[i]; /* note procedure frame prefix */ - cf->frm_prfx[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->cd.cd_id = C_Null; /* base of code sequence in function */ - cf->cd.next = NULL; - cf->cursor = &cf->cd; /* current place to insert code */ - cf->call_lst = NULL; /* functions called by this function */ - cf->creatlst = NULL; /* creates within this function */ - cf->sig_lst = NULL; /* signals returned by this function */ - cf->ref_cnt = 0; - cf->next = NULL; - *flst_end = cf; /* link entry onto global list */ - flst_end = &(cf->next); - return cf; - } - -/* - * tmp_loc - allocate a value location structure for nth temporary descriptor - * variable in procedure frame. - */ -static struct val_loc *tmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Temp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * itmp_loc - allocate a value location structure for nth temporary integer - * variable in procedure frame. - */ -struct val_loc *itmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_ITemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * dtmp_loc - allocate a value location structure for nth temporary double - * variable in procedure frame. - */ -struct val_loc *dtmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_DTemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * vararg_sz - allocate a value location structure that refers to the size - * of the variable part of an argument list. - */ -static struct val_loc *vararg_sz(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Const; - r->mod_access = M_None; - r->u.int_const = n; - return r; - } - -/* - * cvar_loc - allocate a value location structure for a C variable. - */ -struct val_loc *cvar_loc(name) -char *name; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_CVar; - r->mod_access = M_None; - r->u.name = name; - return r; - } - -/* - * var_ref - allocate a value location structure for an Icon named variable. - */ -static struct val_loc *var_ref(sym) -struct lentry *sym; - { - struct val_loc *loc; - - loc = NewStruct(val_loc); - loc->loc_type = V_NamedVar; - loc->mod_access = M_None; - loc->u.nvar = sym; - return loc; - } - -/* - * deref_cd - generate code to dereference a descriptor. - */ -static void deref_cd(src, dest) -struct val_loc *src; -struct val_loc *dest; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "deref(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = src; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &"; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = dest; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - } - -/* - * inv_op - directly invoke a run-time operation, in-lining it if possible. - */ -static struct val_loc *inv_op(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct implement *impl; - struct code *scont_strt; - struct code *scont_fail; - struct c_fnc *fnc; - struct val_loc *frst_arg; - struct val_loc *arg_rslt; - struct val_loc *r; - struct val_loc **varg_rslt; - struct op_symentry *symtab; - struct lentry **single; - struct tmplftm *lifetm_ary; - nodeptr rslt_lftm; - char *sbuf; - int *maybe_var; - int may_mod; - int nsyms; - int nargs; - int nparms; - int cont_loc; - int flag; - int refs; - int var_args; - int n_varargs; - int arg_loc; - int dcl_var; - int i; - int j; - int v; - - nargs = Val0(n); - impl = Impl1(n); - if (impl == NULL) { - /* - * We have already printed an error, just make sure we can - * continue. - */ - return &ignore; - } - - /* - * If this operation uses its result location as a work area, it must - * be given a tended result location and the value must be retained - * as long as the operation can be resumed. - */ - rslt_lftm = n->lifetime; - if (impl->use_rslt) { - rslt_lftm = max_lftm(rslt_lftm, n->intrnl_lftm); - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - } - - /* - * Determine if this operation takes a variable number of arguments - * and determine the size of the variable part of the arg list. - */ - nparms = impl->nargs; - if (nparms > 0 && impl->arg_flgs[nparms - 1] & VarPrm) { - var_args = 1; - n_varargs = nargs - nparms + 1; - if (n_varargs < 0) - n_varargs = 0; - } - else { - var_args = 0; - n_varargs = 0; - } - - /* - * Construct a symbol table (implemented as an array) for the operation. - * The symbol table includes parameters, and both the tended and - * ordinary variables from the RTL declare statement. - */ - nsyms = (n->symtyps == NULL ? 0 : n->symtyps->nsyms); - if (var_args) - ++nsyms; - nsyms += impl->ntnds + impl->nvars; - if (nsyms > 0) - symtab = (struct op_symentry *)alloc((unsigned int)(nsyms * - sizeof(struct op_symentry))); - else - symtab = NULL; - for (i = 0; i < nsyms; ++i) { - symtab[i].n_refs = 0; /* number of non-modifying references */ - symtab[i].n_mods = 0; /* number of modifying references */ - symtab[i].n_rets = 0; /* number of times returned directly */ - symtab[i].var_safe = 0; /* Icon variable arg can be passed directly */ - symtab[i].adjust = 0; /* adjustments needed to "dereference" */ - symtab[i].itmp_indx = -1; /* loc after "in-place" convert to C integer */ - symtab[i].dtmp_indx = -1; /* loc after "in-place" convert to C double */ - symtab[i].loc = NULL; /* location as a descriptor */ - } - - /* - * If in-lining has not been disabled or the operation is a keyword, - * check to see if it can reasonably be in-lined and gather information - * needed to in-line it. - */ - if ((allow_inline || impl->oper_typ == 'K') && - do_inlin(impl, n, &cont_loc, symtab, n_varargs)) { - /* - * In-line the operation. - */ - - if (impl->ret_flag & DoesRet || impl->ret_flag & DoesSusp) - rslt = chk_alc(rslt, rslt_lftm); /* operation produces a result */ - - /* - * Allocate arrays to hold information from type inferencing about - * whether arguments are variables. This is used to optimize - * dereferencing. - */ - if (nargs > 0) { - maybe_var = (int *)alloc((unsigned int)(nargs * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nargs * - sizeof(struct lentry *))); - } - - if (var_args) - --nparms; /* don't deal with varargs parameter yet. */ - - /* - * Match arguments with parameters and generate code for the - * arguments. The type of code generated depends on the kinds - * of dereferencing optimizations that are possible, though - * in general, dereferencing must wait until all arguments are - * computed. Because there may be both dereferenced and undereferenced - * parameters for an argument, the symbol table index does not always - * match the argument index. - */ - i = 0; /* symbol table index */ - for (j = 0; j < nparms && j < nargs; ++j) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j] = HasVar(varsubtyp(n->n_field[FrstArg + j].n_ptr->type, - &(single[j]))); - - /* - * Determine how many times the argument is referenced. If we - * optimize away return statements because we don't need the - * result, those references don't count. Take into account - * that there may be both dereferenced and undereferenced - * parameters for this argument. - */ - if (rslt == &ignore) - symtab[i].n_refs -= symtab[i].n_rets; - refs = symtab[i].n_refs + symtab[i].n_mods; - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - if (flag == (RtParm | DrfPrm)) - refs += symtab[i + 1].n_refs + symtab[i + 1].n_mods; - if (refs == 0) { - /* - * Indicate that we don't need the argument value (we must - * still perform the computation in case it has side effects). - */ - arg_rslt = &ignore; - symtab[i].adjust = AdjNone; - } - else { - /* - * Decide whether the result location for the argument can be - * used directly as the parameter. - */ - if (flag == (RtParm | DrfPrm) && symtab[i].n_refs + - symtab[i].n_mods == 0) { - /* - * We have both dereferenced and undereferenced parameters, - * but don't use the undereferenced one so ignore it. - */ - symtab[i].adjust = AdjNone; - ++i; - flag = DrfPrm; - } - if (flag == DrfPrm && single[j] != NULL) { - /* - * We need only a dereferenced value, but know what variable - * it is in. We don't need the computed argument value, we will - * get it directly from the variable. If it is safe to do - * so, we will pass a pointer to the variable as the argument - * to the operation. - */ - arg_rslt = &ignore; - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * Determine if the argument descriptor is modified by the - * operation; dereferencing a variable is a modification. - */ - may_mod = (symtab[i].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j]; - if (n->n_field[FrstArg + j].n_ptr->reuse && may_mod) { - /* - * The parameter may be reused without recomputing - * the argument and the value may be modified. The - * argument result location and the parameter location - * must be separate so the parameter is reloaded upon - * each invocation. - */ - arg_rslt = chk_alc(NULL, - n->n_field[FrstArg + j].n_ptr->lifetime); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjNDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjCpy; /* value only: just copy */ - } - else { - /* - * Argument result location will act as parameter location. - * Its lifetime must be as long as both that of the - * the argument and the parameter (operation internal - * lifetime). - */ - arg_rslt = chk_alc(NULL, max_lftm(n->intrnl_lftm, - n->n_field[FrstArg + j].n_ptr->lifetime)); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjNone; - } - symtab[i].loc = arg_rslt; - } - } - - /* - * Generate the code for the argument. - */ - gencode(n->n_field[FrstArg + j].n_ptr, arg_rslt); - - if (flag == (RtParm | DrfPrm)) { - /* - * We have computed the value for the undereferenced parameter, - * decide how to get the dereferenced value. - */ - ++i; - if (symtab[i].n_refs + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; /* not needed, ignore */ - else { - if (single[j] != NULL) { - /* - * The value is in a specific Icon variable, get it from - * there. If is is safe to pass the variable directly - * to the operation, do so. - */ - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * If there might be a variable reference, note that it - * must be dereferenced. Otherwise decide whether the - * argument location can be used for both the dereferenced - * and undereferenced parameter. - */ - symtab[i].loc = arg_rslt; - if (maybe_var[j]) - symtab[i].adjust = AdjNDrf; - else if (symtab[i - 1].n_mods + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - } - } - ++i; - } - - /* - * Fill out parameter list with null values. - */ - while (j < nparms) { - int k, kn; - kn = 0; - if (impl->arg_flgs[j] & RtParm) - ++kn; - if (impl->arg_flgs[j] & DrfPrm) - ++kn; - for (k = 0; k < kn; ++k) { - if (symtab[i].n_refs + symtab[i].n_mods > 0) { - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(asgn_null(arg_rslt)); - symtab[i].loc = arg_rslt; - } - symtab[i].adjust = AdjNone; - ++i; - } - ++j; - } - - if (var_args) { - /* - * Compute variable part of argument list. - */ - ++nparms; /* add varargs parameter back into parameter list */ - - /* - * The variable part of the parameter list must be in contiguous - * descriptors. Create location and lifetime arrays for use in - * allocating the descriptors. - */ - if (n_varargs > 0) { - varg_rslt = (struct val_loc **)alloc((unsigned int)(n_varargs * - sizeof(struct val_loc *))); - lifetm_ary = alc_lftm(n_varargs, NULL); - } - - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - - /* - * Compute the lifetime of the elements of the varargs parameter array. - */ - for (v = 0; v < n_varargs; ++v) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j + v] = HasVar(varsubtyp( - n->n_field[FrstArg+j+v].n_ptr->type, &(single[j + v]))); - - /* - * Determine if the elements of the vararg parameter array - * might be modified. If it is a variable, dereferencing - * modifies it. - */ - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - - if ((flag == DrfPrm && single[j + v] != NULL) || - (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod)) { - /* - * The argument value is only placed in the vararg parameter - * array during "dereferencing". So the lifetime of the array - * element is the lifetime of the parameter and the element - * is not used until dereferencing. - */ - lifetm_ary[v].lifetime = n->intrnl_lftm; - lifetm_ary[v].cur_status = n->postn; - } - else { - /* - * The argument is computed into the vararg parameter array. - * The lifetime of the array element encompasses both - * the lifetime of the argument and the parameter. The - * element is used as soon as the argument is computed. - */ - lifetm_ary[v].lifetime = max_lftm(n->intrnl_lftm, - n->n_field[FrstArg+j+v].n_ptr->lifetime); - lifetm_ary[v].cur_status = n->n_field[FrstArg+j+v].n_ptr->postn; - } - } - - /* - * Allocate (reserve) the array of temporary variables for the - * vararg list. - */ - if (n_varargs > 0) { - arg_loc = alc_tmp(n_varargs, lifetm_ary); - free((char *)lifetm_ary); - } - - /* - * Generate code to compute arguments. - */ - for (v = 0; v < n_varargs; ++v) { - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * We need a dereferenced value and it is in a known place: a - * named variable; don't bother saving the result of the - * argument computation. - */ - r = &ignore; - } - else if (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod) { - /* - * The argument can be reused without being recomputed and - * the parameter may be modified, so we cannot safely - * compute the argument into the vararg parameter array; we - * must compute it elsewhere and copy (dereference) it at the - * beginning of the operation. Let gencode allocate an argument - * result location. - */ - r = NULL; - } - else { - /* - * We can compute the argument directly into the vararg - * parameter array. - */ - r = tmp_loc(arg_loc + v); - } - varg_rslt[v] = gencode(n->n_field[FrstArg + j + v].n_ptr, r); - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in vararg - * parameter list. Preceding arguments are dereferenced later, but - * it is okay if dereferencing is out-of-order. - */ - for (v = 0; v < n_varargs; ++v) { - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * Copy the value from the known named variable into the - * parameter list. - */ - varg_rslt[v] = var_ref(single[j + v]); - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - else if (flag == DrfPrm && maybe_var[j + v]) { - /* - * Dereference the argument into the parameter list. - */ - deref_cd(varg_rslt[v], tmp_loc(arg_loc + v)); - } - else if (arg_loc + v != varg_rslt[v]->u.tmp) { - /* - * The argument is a dereferenced value, but is not yet - * in the parameter list; copy it there. - */ - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - tmp_status[arg_loc + v] = InUse; /* parameter location in use */ - } - - /* - * The vararg parameter gets the address of the first element - * in the variable part of the argument list and the size - * parameter gets the number of elements in the list. - */ - if (n_varargs > 0) { - free((char *)varg_rslt); - symtab[i].loc = tmp_loc(arg_loc); - } - else - symtab[i].loc = chk_alc(NULL, n); /* dummy arg location */ - symtab[i].loc->mod_access = M_Addr; - ++i; - symtab[i].loc = vararg_sz(n_varargs); - ++i; - } - else { - /* - * Compute extra arguments, but discard the results. - */ - while (j < nargs) { - gencode(n->n_field[FrstArg + j].n_ptr, &ignore); - ++j; - } - } - - if (nargs > 0) { - free((char *)maybe_var); - free((char *)single); - } - - /* - * If execution does not continue through the parameter evaluation, - * don't try to generate in-line code. A lack of parameter types - * will cause problems with some in-line type conversions. - */ - if (!past_prms(n)) - return rslt; - - setloc(n); - - dcl_var = i; - - /* - * Perform any needed copying or dereferencing. - */ - for (i = 0; i < nsyms; ++i) { - switch (symtab[i].adjust) { - case AdjNDrf: - /* - * Dereference into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - deref_cd(symtab[i].loc, arg_rslt); - symtab[i].loc = arg_rslt; - break; - case AdjDrf: - /* - * Dereference in place. - */ - deref_cd(symtab[i].loc, symtab[i].loc); - break; - case AdjCpy: - /* - * Copy into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(mk_cpyval(arg_rslt, symtab[i].loc)); - symtab[i].loc = arg_rslt; - break; - case AdjNone: - break; /* nothing need be done */ - } - } - - switch (cont_loc) { - case SepFnc: - /* - * success continuation must be in a separate function. - */ - fnc = alc_fnc(); - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put oper before label */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, fnc, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - break; - case SContIL: - /* - * one suspend an no return: success continuation is put in-line. - */ - gen_inlin(impl->in_line, rslt, &scont_strt, &scont_fail, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - on_failure = scont_fail; - break; - case EndOper: - /* - * no suspends: success continuation goes at end of operation. - */ - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put operation before lbl */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - break; - } - } - else { - /* - * Do not in-line operation. - */ - implproto(impl); - frst_arg = gen_args(n, 2, nargs); - setloc(n); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, rslt_lftm); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, nargs, rslt, - 0); - } - if (symtab != NULL) - free((char *)symtab); - return rslt; - } - -/* - * max_lftm - given two lifetimes (in the form of nodes) return the - * maximum one. - */ -static nodeptr max_lftm(n1, n2) -nodeptr n1; -nodeptr n2; - { - if (n1 == NULL) - return n2; - else if (n2 == NULL) - return n1; - else if (n1->postn > n2->postn) - return n1; - else - return n2; - } - -/* - * inv_prc - directly invoke a procedure. - */ -static struct val_loc *inv_prc(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct pentry *proc; - struct val_loc *r; - struct val_loc *arg1rslt; - struct val_loc *var_part; - int *must_deref; - struct lentry **single; - struct val_loc **arg_rslt; - struct code *cd; - struct tmplftm *lifetm_ary; - char *sbuf; - int nargs; - int nparms; - int i, j; - int arg_loc; - int var_sz; - int var_loc; - - /* - * This procedure is implemented without argument list adjustment or - * dereferencing, so they must be done before the call. - */ - nargs = Val0(n); /* number of arguments */ - proc = Proc1(n); - nparms = Abs(proc->nargs); - - if (nparms > 0) { - must_deref = (int *)alloc((unsigned int)(nparms * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nparms * - sizeof(struct lentry *))); - arg_rslt = (struct val_loc **)alloc((unsigned int)(nparms * - sizeof(struct val_loc *))); - } - - /* - * Allocate a work area of temporaries to use as argument list. If - * an argument can be reused without being recomputed, it must not - * be computed directly into the work area. It will be copied or - * dereferenced into the work area when execution reaches the - * operation. If an argument is a single named variable, it can - * be dereferenced directly into the argument location. These - * conditions affect when the temporary will receive a value. - */ - if (nparms > 0) - lifetm_ary = alc_lftm(nparms, NULL); - for (i = 0; i < nparms; ++i) - lifetm_ary[i].lifetime = n->intrnl_lftm; - for (i = 0; i < nparms && i < nargs; ++i) { - must_deref[i] = HasVar(varsubtyp(n->n_field[FrstArg + i].n_ptr->type, - &(single[i]))); - if (single[i] != NULL || n->n_field[FrstArg + i].n_ptr->reuse) - lifetm_ary[i].cur_status = n->postn; - else - lifetm_ary[i].cur_status = n->n_field[FrstArg + i].n_ptr->postn; - } - while (i < nparms) { - lifetm_ary[i].cur_status = n->postn; /* arg list extension */ - ++i; - } - if (proc->nargs < 0) - lifetm_ary[nparms - 1].cur_status = n->postn; /* variable part */ - - if (nparms > 0) { - arg_loc = alc_tmp(nparms, lifetm_ary); - free((char *)lifetm_ary); - } - if (proc->nargs < 0) - --nparms; /* treat variable part specially */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (single[i] != NULL) - r = &ignore; /* we know where the dereferenced value is */ - else if (n->n_field[FrstArg + i].n_ptr->reuse) - r = NULL; /* let gencode allocate a new temporary */ - else - r = tmp_loc(arg_loc + i); - arg_rslt[i] = gencode(n->n_field[FrstArg + i].n_ptr, r); - } - - /* - * If necessary, fill out argument list with nulls. - */ - while (i < nparms) { - cd_add(asgn_null(tmp_loc(arg_loc + i))); - tmp_status[arg_loc + i] = InUse; - ++i; - } - - if (proc->nargs < 0) { - /* - * handle variable part of list. - */ - var_sz = nargs - nparms; - - if (var_sz > 0) { - lifetm_ary = alc_lftm(var_sz, &n->n_field[FrstArg + nparms]); - var_loc = alc_tmp(var_sz, lifetm_ary); - free((char *)lifetm_ary); - for (j = 0; j < var_sz; ++j) { - gencode(n->n_field[FrstArg + nparms + j].n_ptr, - tmp_loc(var_loc + j)); - } - } - } - else { - /* - * If there are extra arguments, compute them, but discard the - * results. - */ - while (i < nargs) { - gencode(n->n_field[FrstArg + i].n_ptr, &ignore); - ++i; - } - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in argument - * list as dereferenced values. - */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (must_deref[i]) { - if (single[i] == NULL) { - deref_cd(arg_rslt[i], tmp_loc(arg_loc + i)); - } - else { - arg_rslt[i] = var_ref(single[i]); - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - } - } - else if (n->n_field[FrstArg + i].n_ptr->reuse) - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - tmp_status[arg_loc + i] = InUse; - } - - if (proc->nargs < 0) { - var_part = tmp_loc(arg_loc + nparms); - tmp_status[arg_loc + nparms] = InUse; - if (var_sz <= 0) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(NULL, 0, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = var_part; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - } - else { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = tmp_loc(var_loc); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = var_sz; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", &"; - cd->ElemTyp(5) = A_ValLoc; - cd->ValLoc(5) = var_part; - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ");"; - } - cd_add(cd); - ++nparms; /* include variable part in call */ - } - - if (nparms > 0) { - free((char *)must_deref); - free((char *)single); - free((char *)arg_rslt); - } - - sbuf = (char *)alloc((unsigned int)(strlen(proc->name) + PrfxSz + 3)); - sprintf(sbuf, "P%s_%s", proc->prefix, proc->name); - if (nparms > 0) - arg1rslt = tmp_loc(arg_loc); - else - arg1rslt = NULL; - if (proc->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(sbuf, proc->ret_flag, arg1rslt, nargs, rslt, 1); - return rslt; - } - -/* - * endlife - link a temporary variable onto the list to be freed when - * execution reaches a node. - */ -static void endlife(kind, indx, old, n) -int kind; -int indx; -int old; -nodeptr n; - { - struct freetmp *freetmp; - - if ((freetmp = freetmp_pool) == NULL) - freetmp = NewStruct(freetmp); - else - freetmp_pool = freetmp_pool->next; - freetmp->kind = kind; - freetmp->indx = indx; - freetmp->old = old; - freetmp->next = n->freetmp; - n->freetmp = freetmp; - } - -/* - * alc_tmp - allocate a block of temporary variables with the given lifetimes. - */ -static int alc_tmp(num, lifetm_ary) -int num; -struct tmplftm *lifetm_ary; - { - int i, j, k; - register int status; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > status_sz) { - /* - * The status array is too small, expand it. - */ - new_size = status_sz + Max(num, status_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < status_sz) { - new_status[k] = tmp_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)tmp_status); - tmp_status = new_status; - status_sz = new_size; - } - for (j = 0; j < num; ++j) { - status = tmp_status[i + j]; - if (status != NotAlloc && - (status == InUse || status <= lifetm_ary[j].lifetime->postn)) - break; - } - /* - * Did we find a block of temporaries that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(DescTmp, i + j, tmp_status[i + j], lifetm_ary[j].lifetime); - tmp_status[i + j] = lifetm_ary[j].cur_status; - } - if (i + num > num_tmp) - num_tmp = i + num; - return i; - } - ++i; - } - } - -/* - * alc_lftm - allocate an array of lifetime information for an argument - * list. - */ -static struct tmplftm *alc_lftm(num, args) -int num; -union field *args; - { - struct tmplftm *lifetm_ary; - int i; - - lifetm_ary = (struct tmplftm *)alloc((unsigned int)(num * - sizeof(struct tmplftm))); - if (args != NULL) - for (i = 0; i < num; ++i) { - lifetm_ary[i].cur_status = args[i].n_ptr->postn; /* reserved for arg */ - lifetm_ary[i].lifetime = args[i].n_ptr->lifetime; - } - return lifetm_ary; - } - -/* - * alc_itmp - allocate a temporary C integer variable. - */ -int alc_itmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < istatus_sz && itmp_status[i] == InUse) - ++i; - if (i >= istatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)itmp_status); - new_size = istatus_sz * 2; - itmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < istatus_sz) - itmp_status[j++] = InUse; - while (j < new_size) - itmp_status[j++] = NotAlloc; - istatus_sz = new_size; - } - endlife(CIntTmp, i, NotAlloc, lifetime); - itmp_status[i] = InUse; - if (num_itmp < i + 1) - num_itmp = i + 1; - return i; - } - -/* - * alc_dtmp - allocate a temporary C integer variable. - */ -int alc_dtmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < dstatus_sz && dtmp_status[i] == InUse) - ++i; - if (i >= dstatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)dtmp_status); - new_size = dstatus_sz * 2; - dtmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < dstatus_sz) - dtmp_status[j++] = InUse; - while (j < new_size) - dtmp_status[j++] = NotAlloc; - dstatus_sz = new_size; - } - endlife(CDblTmp, i, NotAlloc, lifetime); - dtmp_status[i] = InUse; - if (num_dtmp < i + 1) - num_dtmp = i + 1; - return i; - } - -/* - * alc_sbufs - allocate a block of string buffers with the given lifetime. - */ -int alc_sbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > sstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = sstatus_sz + Max(num, sstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < sstatus_sz) { - new_status[k] = sbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)sbuf_status); - sbuf_status = new_status; - sstatus_sz = new_size; - } - for (j = 0; j < num && sbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(SBuf, i + j, sbuf_status[i + j], lifetime); - sbuf_status[i + j] = InUse; - } - if (i + num > num_sbuf) - num_sbuf = i + num; - return i; - } - ++i; - } - } - -/* - * alc_cbufs - allocate a block of cset buffers with the given lifetime. - */ -int alc_cbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > cstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = cstatus_sz + Max(num, cstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < cstatus_sz) { - new_status[k] = cbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)cbuf_status); - cbuf_status = new_status; - cstatus_sz = new_size; - } - for (j = 0; j < num && cbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(CBuf, i + j, cbuf_status[i + j], lifetime); - cbuf_status[i + j] = InUse; - } - if (i + num > num_cbuf) - num_cbuf = i + num; - return i; - } - ++i; - } - } diff --git a/src/iconc/ccode.h b/src/iconc/ccode.h deleted file mode 100644 index 2d0cb6f..0000000 --- a/src/iconc/ccode.h +++ /dev/null @@ -1,252 +0,0 @@ -/* - * ccode.h - definitions used in code generation. - */ - -/* - * ChkPrefix - allocate a prefix to x if it has not already been done. - */ -#define ChkPrefix(x) if ((x)[0] == '\0') nxt_pre(x, pre, PrfxSz); - -/* - * sig_act - list of possible signals returned by a call and the action to be - * to be taken when the signal is returned: in effect a switch statement. - */ -struct sig_act { - struct code *sig; /* signal */ - struct code *cd; /* action to be taken: goto, return, break */ - struct sig_act *shar_act; /* signals that share this action */ - struct sig_act *next; - }; - -/* - * val_loc - location of a value. Used for intermediate and final results - * of expressions. - */ -#define V_NamedVar 1 /* Icon named variable indicated by nvar */ -#define V_Temp 2 /* temporary variable indicated by tmp */ -#define V_ITemp 3 /* C integer temporary variable indicated by tmp */ -#define V_DTemp 4 /* C double temporary variable indicated by tmp */ -#define V_PRslt 5 /* procedure result location */ -#define V_Const 6 /* integer constant - used for size of varargs */ -#define V_CVar 7 /* C named variable */ -#define V_Ignore 8 /* "trashcan" - a write-only location */ - -#define M_None 0 /* access simply as descriptor */ -#define M_CharPtr 1 /* access v-word as "char *" */ -#define M_BlkPtr 2 /* access v-word as block pointer using blk_name */ -#define M_CInt 3 /* access v-word as C integer */ -#define M_Addr 4 /* address of descriptor for varargs */ - -struct val_loc { - int loc_type; /* manifest constants V_* */ - int mod_access; /* manifest constants M_* */ - char *blk_name; /* used with M_BlkPtr */ - union { - struct lentry *nvar; /* Icon named variable */ - int tmp; /* index of temporary variable */ - int int_const; /* integer constant value */ - char *name; /* C named variable */ - } u; - }; - -/* - * "code" contains the information needed to print a piece of C code. - * C_... manifest constants are cd_id's. These are followed by - * corresponding field access expressions. - */ -#define Rslt fld[0].vloc /* place to put result of expression */ -#define Cont fld[1].fnc /* continuation function or null */ - -#define C_Null 0 /* no code */ - -#define C_NamedVar 1 /* reference to a named variable */ -/* uses Rslt */ -#define NamedVar fld[1].nvar - -#define C_CallSig 2 /* call and handling of returned signal */ -#define OperName fld[0].oper_nm /* run-time routine name or null */ -/* uses Cont */ -#define Flags fld[2].n /* flag: NeedCont, ForeignSig */ -#define ArgLst fld[3].cd /* argument list */ -#define ContFail fld[4].cd /* label/signal to goto/return on failure */ -#define SigActs fld[5].sa /* actions to take for returned signals */ -#define NextCall fld[6].cd /* for chaining calls within a continuation*/ -#define NeedCont 1 /* pass NULL continuation if Cont == NULL */ -#define ForeignSig 2 /* may get foreign signal from a suspend */ - -#define C_RetSig 3 /* return signal */ -#define SigRef fld[0].sigref /* pointer to func's reference to signal */ - -#define C_Goto 4 /* goto label */ -#define Lbl fld[0].cd /* label */ - -#define C_Label 5 /* statment label "Ln:" and signal "n" */ -#define Container fld[0].fnc /* continuation containing label */ -#define SeqNum fld[1].n /* sequence number, n */ -#define Desc fld[2].s /* description of how label/signal is used */ -#define RefCnt fld[3].n /* reference count for label */ -#define LabFlg fld[4].n /* flag: FncPtrd, BndSig */ -#define FncPrtd 1 /* function sig_n has been printed */ -#define Bounding 2 /* this is a bounding label */ - -#define C_Lit 6 /* literal (integer, real, string, cset) */ -/* uses Rslt */ -#define Literal fld[1].lit - -#define C_Resume 7 /* resume signal */ -#define C_Continue 8 /* continue signal */ -#define C_FallThru 9 /* fall through signal */ -#define C_PFail 10 /* procedure failure */ -#define C_PRet 11 /* procedure return (result already set) */ -#define C_PSusp 12 /* procedure suspend */ -#define C_Break 13 /* break out of signal handling switch */ -#define C_LBrack 14 /* '{' */ -#define C_RBrack 15 /* '}' */ - -#define C_Create 16 /* call of create() for create expression */ -/* uses Rslt */ -/* uses Cont */ -#define NTemps fld[2].n /* number of temporary descriptors needed */ -#define WrkSize fld[3].n /* size of non-descriptor work area */ -#define NextCreat fld[4].cd /* for chaining creates in a continuation */ - - -#define C_If 17 /* conditional (goto or return) */ -#define Cond fld[0].cd /* condition */ -#define ThenStmt fld[1].cd /* what to do if condition is true */ - -#define C_SrcLoc 18 -#define FileName fld[0].s /* name of source file */ -#define LineNum fld[1].n /* line number within source file */ - -#define C_CdAry 19 /* array of code pieces, each with type code*/ -#define A_Str 0 /* code represented as a string */ -#define A_ValLoc 1 /* value location */ -#define A_Intgr 2 /* integer */ -#define A_ProcCont 3 /* procedure continuation */ -#define A_SBuf 4 /* string buffer (integer index) */ -#define A_CBuf 5 /* cset buffer (integer index) */ -#define A_Ary 6 /* pointer to subarray of code pieces */ -#define A_End 7 /* marker for end of array */ -#define ElemTyp(i) fld[2*i].n /* type of element i (A_* codes) */ -#define Str(i) fld[2*i+1].s /* string in element i */ -#define ValLoc(i) fld[2*i+1].vloc /* value location in element i */ -#define Intgr(i) fld[2*i+1].n /* integer in element i */ -#define Array(i) fld[2*i+1].cd /* pointer to subarray in element i */ - -/* - * union cd_fld - fields within a code struct. - */ -union cd_fld { - int n; /* various integer values */ - char *s; /* various string values */ - struct lentry *nvar; /* symbol table entry for a named variable */ - struct code *cd; /* various pointers to other pieces of code */ - struct c_fnc *fnc; /* pointer to function information */ - struct centry *lit; /* symbol table entry for a literal */ - struct sig_act *sa; /* actions to take for a returned signal */ - struct sig_lst *sigref; /* pointer to func's reference to signal */ - struct val_loc *vloc; /* value location */ - char *oper_nm; /* name of run-time operation or NULL */ - }; - -/* - * code - struct used to hold the internal representation of generated code. - */ -struct code { - int cd_id; /* kind of code: C_* */ - struct code *next; /* next code fragment in list */ - struct code *prev; /* previous code fragment in list */ - union cd_fld fld[1]; /* fields of code fragment, actual number varies */ - }; - -/* - * NewCode - allocate a code structure with "size" fields. - */ -#define NewCode(size) (struct code *)alloc((unsigned int)\ - (sizeof(struct code) + (size-1) * sizeof(union cd_fld))) - -/* - * c_fnc contains information about a C function that implements a continuation. - */ -#define CF_SigOnly 1 /* this function only returns a signal */ -#define CF_ForeignSig 2 /* may return foreign signal from a suspend */ -#define CF_Mark 4 /* this function has been visited by fix_fncs() */ -#define CF_Coexpr 8 /* this function implements a co-expression */ -struct c_fnc { - char prefix[PrfxSz+1]; /* function prefix */ - char frm_prfx[PrfxSz+1]; /* procedure frame prefix */ - int flag; /* CF_* flags */ - struct code cd; /* start of code sequence */ - struct code *cursor; /* place to insert more code into sequence */ - struct code *call_lst; /* functions called by this function */ - struct code *creatlst; /* list of creates in this function */ - struct sig_lst *sig_lst; /* signals returned by this function */ - int ref_cnt; /* reference count for this function */ - struct c_fnc *next; - }; - - -/* - * sig_lst - a list of signals returned by a continuation along with a count - * of the number of places each signal is returned. - */ -struct sig_lst { - struct code *sig; /* signal */ - int ref_cnt; /* number of places returned */ - struct sig_lst *next; - }; - -/* - * op_symentry - entry in symbol table for an operation - */ -#define AdjNone 1 /* no adjustment to this argument */ -#define AdjDrf 2 /* deref in place */ -#define AdjNDrf 3 /* deref into a new temporary */ -#define AdjCpy 4 /* copy into a new temporary */ -struct op_symentry { - int n_refs; /* number of non-modifying references */ - int n_mods; /* number of modifying referenced */ - int n_rets; /* number of times directly returned from operation */ - int var_safe; /* if arg is named var, it may be used directly */ - int adjust; /* AdjNone, AdjInplc, or AdjToNew */ - int itmp_indx; /* index of temporary C integer variable */ - int dtmp_indx; /* index of temporary C double variable */ - struct val_loc *loc; - }; - -extern int num_tmp; /* number of temporary descriptor variables */ -extern int num_itmp; /* number of temporary C integer variables */ -extern int num_dtmp; /* number of temporary C double variables */ -extern int num_sbuf; /* number of string buffers */ -extern int num_cbuf; /* number of cset buffers */ - -extern struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -extern struct code resume; -extern struct code contin; -extern struct code fallthru; -extern struct code next_fail; - -extern struct val_loc ignore; /* no values, just something to point at */ -extern struct c_fnc *cur_fnc; /* C function currently being built */ -extern struct code *on_failure; /* place to go on failure */ - -extern int lbl_seq_num; /* next label sequence number */ - -extern char pre[PrfxSz]; /* next unused prefix */ - -extern struct op_symentry *cur_symtab; /* current operation symbol table */ - -#define SepFnc 1 /* success continuation goes in separate function */ -#define SContIL 2 /* in line success continuation */ -#define EndOper 3 /* success continuation goes at end of operation */ - -#define HasVal 1 /* type contains values */ -#define HasLcl 2 /* type contains local variables */ -#define HasPrm 4 /* type contains parameters */ -#define HasGlb 8 /* type contains globals (including statics and elements) */ -#define HasVar(x) ((x) & (HasLcl | HasPrm | HasGlb)) diff --git a/src/iconc/ccomp.c b/src/iconc/ccomp.c deleted file mode 100644 index 5b86189..0000000 --- a/src/iconc/ccomp.c +++ /dev/null @@ -1,130 +0,0 @@ -/* - * ccomp.c - routines for compiling and linking the C program produced - * by the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -extern char *refpath; - -#define ExeFlag "-o" -#define LinkLibs " -lm" - -/* - * Structure to hold the list of Icon run-time libraries that must be - * linked in. - */ -struct lib { - char *libname; - int nm_sz; - struct lib *next; - }; -static struct lib *liblst; -static int lib_sz = 0; - -/* - * addlib - add a new library to the list the must be linked. - */ -void addlib(libname) -char *libname; - { - static struct lib **nxtlib = &liblst; - struct lib *l; - - l = NewStruct(lib); - l->libname = libname; - l->nm_sz = strlen(libname); - l->next = NULL; - *nxtlib = l; - nxtlib = &l->next; - lib_sz += l->nm_sz + 1; - } - -/* - * ccomp - perform C compilation and linking. - */ -int ccomp(srcname, exename) -char *srcname; -char *exename; - { - struct lib *l; - char sbuf[MaxPath]; /* file name construction buffer */ - char *buf; - char *s; - char *dlrgint; - int cmd_sz, opt_sz, flg_sz, exe_sz, src_sz; - - /* - * Compute the sizes of the various parts of the command line - * to do the compilation. - */ - cmd_sz = strlen(c_comp); - opt_sz = strlen(c_opts); - flg_sz = strlen(ExeFlag); - exe_sz = strlen(exename); - src_sz = strlen(srcname); - lib_sz += strlen(LinkLibs); - if (!largeints) { - dlrgint = makename(sbuf, refpath, "dlrgint", ObjSuffix); - lib_sz += strlen(dlrgint) + 1; - } - -#ifdef Graphics - lib_sz += strlen(" -L") + - strlen(refpath) + - strlen(" -lIgpx "); - lib_sz += strlen(ICONC_XLIB); -#endif /* Graphics */ - - buf = alloc((unsigned int)cmd_sz + opt_sz + flg_sz + exe_sz + src_sz + - lib_sz + 5); - strcpy(buf, c_comp); - s = buf + cmd_sz; - *s++ = ' '; - strcpy(s, c_opts); - s += opt_sz; - *s++ = ' '; - strcpy(s, ExeFlag); - s += flg_sz; - *s++ = ' '; - strcpy(s, exename); - s += exe_sz; - *s++ = ' '; - strcpy(s, srcname); - s += src_sz; - if (!largeints) { - *s++ = ' '; - strcpy(s, dlrgint); - s += strlen(dlrgint); - } - for (l = liblst; l != NULL; l = l->next) { - *s++ = ' '; - strcpy(s, l->libname); - s += l->nm_sz; - } - -#ifdef Graphics - strcpy(s," -L"); - strcat(s, refpath); - strcat(s," -lIgpx "); - strcat(s, ICONC_XLIB); - s += strlen(s); -#endif /* Graphics */ - - strcpy(s, LinkLibs); - - if (system(buf) != 0) - return EXIT_FAILURE; - strcpy(buf, "strip "); - s = buf + 6; - strcpy(s, exename); - system(buf); - - - return EXIT_SUCCESS; - } diff --git a/src/iconc/cglobals.h b/src/iconc/cglobals.h deleted file mode 100644 index 301a602..0000000 --- a/src/iconc/cglobals.h +++ /dev/null @@ -1,50 +0,0 @@ -/* - * Global variables. - */ - -extern char *runtime; - -#ifndef Global -#define Global extern -#define Init(v) -#endif /* Global */ - -/* - * Variables related to command processing. - */ -Global char *progname Init("iconc"); /* program name for diagnostics */ - -Global int debug_info Init(0); /* -fd, -t: generate debugging info */ -Global int err_conv Init(0); /* -fe: support error conversion */ - -#ifdef LargeInts - Global int largeints Init(1); /* -fl: support large integers */ -#else /* LargeInts */ - Global int largeints Init(0); /* -fl: support large integers */ -#endif /* LargeInts */ - -Global int line_info Init(0); /* -fn, -fd, -t: generate line info */ -Global int m4pre Init(0); /* -m: use m4 preprocessor? */ -Global int str_inv Init(0); /* -fs: enable full string invocation */ -Global int trace Init(0); /* -t: initial &trace value */ -Global int uwarn Init(0); /* -u: warn about undefined ids? */ -Global int just_type_trace Init(0); /* -T: suppress C code */ -Global int verbose Init(1); /* -s, -v: level of verbosity */ -Global int pponly Init(0); /* -E: preprocess only */ - -Global char *c_comp Init(CComp); /* -C: C compiler */ -Global char *c_opts Init(COpts); /* -p: options for C compiler */ - -/* - * Flags turned off by the -n option. - */ -Global int opt_cntrl Init(1); /* do control flow optimization */ -Global int opt_sgnl Init(1); /* do signal handling optimizations */ -Global int do_typinfer Init(1); /* do type inference */ -Global int allow_inline Init(1); /* allow expanding operations in line */ - -/* - * Files. - */ -Global FILE *codefile Init(0); /* C code output - primary file */ -Global FILE *inclfile Init(0); /* C code output - include file */ diff --git a/src/iconc/cgrammar.c b/src/iconc/cgrammar.c deleted file mode 100644 index a48e621..0000000 --- a/src/iconc/cgrammar.c +++ /dev/null @@ -1,221 +0,0 @@ -/* - * cgrammar.c - includes and macros for building the parse tree. - */ -#include "../h/define.h" -#include "../common/yacctok.h" - -%{ -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -/*#include "../h/gsupport.h"*/ -/*#include "../h/lexdef.h"*/ -/*#include "ctrans.h"*/ -/*#include "csym.h"*/ -/*#include "ctree.h"*/ -/*#include "ccode.h" */ -/*#include "cproto.h"*/ -/*#undef YYSTYPE*/ -/*#define YYSTYPE nodeptr*/ -/*#define YYMAXDEPTH 500*/ - -int idflag; - -#define EmptyNode tree1(N_Empty) - -#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3) -#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3) -#define Arglist1() /* empty */ -#define Arglist2(x) /* empty */ -#define Arglist3(x1,x2,x3) proc_lst->nargs = -proc_lst->nargs -#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Bamper(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Baugamper(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauggt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugneqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Baugseq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsgt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugslt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcaret(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bcareta(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiff(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiffa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Beq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Beqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Binter(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bintera(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Blcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Ble(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x2,x1,x3) -#define Blt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bmod(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bmoda(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bneqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Brace(x1,x2,x3) $$ = x2 -#define Brack(x1,x2,x3) $$ = list_nd(x1,x2) -#define Brassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Break(x1,x2) $$ = tree3(N_Break,x1,x2) -#define Brswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bseq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslash(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslasha(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bsle(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstar(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstara(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bunion(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Buniona(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Case(x1,x2,x3,x4,x5,x6) $$ = case_nd(x1,x2,x5) -#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3) -#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cliter(x) CSym0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x)) -#define Colon(x) $$ = x -#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Create(x1,x2) $$ = tree3(N_Create,x1,x2);\ - proc_lst->has_coexpr = 1; -#define Elst0(x) $$ = x; -#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3); -#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode) -#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3) -#define Global0(x) idflag = F_Global -#define Global1(x1,x2,x3) /* empty */ -#define Globdcl(x) /* empty */ -#define Ident(x) install(Str0(x),idflag) -#define Idlist(x1,x2,x3) install(Str0(x3),idflag) -#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode) -#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6) -#define Iliter(x) CSym0(x) = putlit(Str0(x),F_IntLit,0) -#define Initial1() $$ = EmptyNode -#define Initial2(x1,x2,x3) $$ = x2 -#define Invocdcl(x) /* empty */ -#define Invocable(x1,x2) /* empty */ -#define Invoclist(x1,x2, x3) /* empty */ -#define Invocop1(x) invoc_grp(Str0(x)); -#define Invocop2(x) invocbl(x, -1); -#define Invocop3(x1,x2,x3) invocbl(x1, atoi(Str0(x3))); -#define Invoke(x1,x2,x3,x4) $$ = invk_nd(x2,x1,x3) -#define Keyword(x1,x2) $$ = key_leaf(x1,Str0(x2)) -#define Kfail(x1,x2) $$ = key_leaf(x1,spec_str("fail")) -#define Link(x1,x2) /* empty */ -#define Linkdcl(x) /* empty */ -#define Lnkfile1(x) lnkdcl(Str0(x)); -#define Lnkfile2(x) lnkdcl(Str0(x)); -#define Lnklist(x1,x2,x3) /* empty */ -#define Local(x) idflag = F_Dynamic -#define Locals1() /* empty */ -#define Locals2(x1,x2,x3,x4) /* empty */ -#define Mcolon(x) $$ = x -#define Nexpr() $$ = EmptyNode -#define Next(x) $$ = tree2(N_Next,x) -#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\ - $$ = invk_nd(x1,EmptyNode,x2);\ - else\ - $$ = x2 -#define Pcolon(x) $$ = x -#define Pdco0(x1,x2,x3) $$ = invk_nd(x2,x1,list_nd(x2,EmptyNode)) -#define Pdco1(x1,x2,x3,x4) $$ = invk_nd(x2,x1,list_nd(x2,x3)) -#define Pdcolist0(x) $$ = tree3(N_Create,x,x);\ - proc_lst->has_coexpr = 1; -#define Pdcolist1(x1,x2,x3) $$ =tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3));\ - proc_lst->has_coexpr = 1; -#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6) -#define Procbody1() $$ = EmptyNode -#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Procdcl(x) proc_lst->tree = x -#define Prochead1(x1,x2) init_proc(Str0(x2));\ - idflag = F_Argument -#define Prochead2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Progend(x1,x2) /* empty */ -#define Recdcl(x) /* empty */ -#define Record1(x1, x2) init_rec(Str0(x2));\ - idflag = F_Field -#define Record2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2) -#define Rliter(x) CSym0(x) = putlit(Str0(x),F_RealLit,0) -#define Section(x1,x2,x3,x4,x5,x6) $$ = sect_nd(x4,x1,x3,x5) -#define Sliter(x) CSym0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x)) -#define Static(x) idflag = F_Static -#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3) -#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define To0(x1,x2,x3) $$ = to_nd(x2,x1,x3) -#define To1(x1,x2,x3,x4,x5) $$ = toby_nd(x2,x1,x3,x5) -#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,EmptyNode,x2) -#define Ubackslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ubang(x1,x2) $$ = unary_nd(x1,x2) -#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ucaret(x1,x2) $$ = unary_nd(x1,x2) -#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Udiff(x1,x2) $$ = MultiUnary(x1,x2) -#define Udot(x1,x2) $$ = unary_nd(x1,x2) -#define Uequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Uinter(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ulexeq(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulexne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uminus(x1,x2) $$ = unary_nd(x1,x2) -#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2) -#define Unotequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Unumeq(x1,x2) $$ = unary_nd(x1,x2) -#define Unumne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uplus(x1,x2) $$ = unary_nd(x1,x2) -#define Uqmark(x1,x2) $$ = unary_nd(x1,x2) -#define Uslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ustar(x1,x2) $$ = unary_nd(x1,x2) -#define Utilde(x1,x2) $$ = unary_nd(x1,x2) -#define Uunion(x1,x2) $$ = MultiUnary(x1,x2) -#define Var(x) LSym0(x) = putloc(Str0(x),0) -#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -%} - -%% -#include "../h/grammar.h" -%% - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ -#undef free -static void xfree(p) -char *p; -{ - free(p); -} - -/*#define free(p) xfree((char*)p)*/ diff --git a/src/iconc/chkinv.c b/src/iconc/chkinv.c deleted file mode 100644 index af4298f..0000000 --- a/src/iconc/chkinv.c +++ /dev/null @@ -1,545 +0,0 @@ -/* - * chkinv.c - routines to determine which global names are only - * used as immediate operand to invocation and to directly invoke - * the corresponding operations. In addition, simple assignments to - * names variables are recognized and it is determined whether - * procedures return, suspend, or fail. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static int chg_ret (int flag); -static void chksmpl (struct node *n, int smpl_invk); -static int seq_exec (int exec_flg1, int exec_flg2); -static int spcl_inv (struct node *n, struct node *asgn); - -static ret_flag; - -/* - * chkinv - check for invocation and assignment optimizations. - */ -void chkinv() - { - struct gentry *gp; - struct pentry *proc; - int exec_flg; - int i; - - if (debug_info) - return; /* The following analysis is not valid */ - - /* - * start off assuming that global variables for procedure, etc. are - * only used as immediate operands to invocations then mark any - * which are not. Any variables retaining the property are never - * changed. Go through the code and change invocations to such - * variables to invocations directly to the operation. - */ - for (i = 0; i < GHSize; i++) - for (gp = ghash[i]; gp != NULL; gp = gp->blink) { - if (gp->flag & (F_Proc | F_Builtin | F_Record) && - !(gp->flag & F_StrInv)) - gp->flag |= F_SmplInv; - /* - * However, only optimize normal cases for main. - */ - if (strcmp(gp->name, "main") == 0 && (gp->flag & F_Proc) && - (gp->val.proc->nargs < 0 || gp->val.proc->nargs > 1)) - gp->flag &= ~(uword)F_SmplInv; - /* - * Work-around to problem that a co-expression block needs - * block for enclosing procedure: just keep procedure in - * a variable to force outputting the block. Note, this - * inhibits tailored calling conventions for the procedure. - */ - if ((gp->flag & F_Proc) && gp->val.proc->has_coexpr) - gp->flag &= ~(uword)F_SmplInv; - } - - /* - * Analyze code in each procedure. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - chksmpl(Tree1(proc->tree), 0); /* initial expression */ - chksmpl(Tree2(proc->tree), 0); /* procedure body */ - } - - /* - * Go through each procedure performing "naive" optimizations on - * invocations and assignments. Also determine whether the procedure - * returns, suspends, or fails (possibly by falling through to - * the end). - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - ret_flag = 0; - spcl_inv(Tree1(proc->tree), NULL); - exec_flg = spcl_inv(Tree2(proc->tree), NULL); - if (exec_flg & DoesFThru) - ret_flag |= DoesFail; - proc->ret_flag = ret_flag; - } - } - -/* - * smpl_invk - find any global variable uses that are not a simple - * invocation and mark the variables. - */ -static void chksmpl(n, smpl_invk) -struct node *n; -int smpl_invk; - { - struct node *cases; - struct node *clause; - struct lentry *var; - int i; - int lst_arg; - - switch (n->n_type) { - case N_Alt: - case N_Apply: - case N_Limit: - case N_Slist: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - break; - - case N_Activat: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Augop: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - break; - - case N_Bar: - case N_Break: - case N_Create: - case N_Field: - case N_Not: - chksmpl(Tree0(n), 0); - break; - - case N_Case: - chksmpl(Tree0(n), 0); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - chksmpl(Tree0(clause), 0); /* value of clause */ - chksmpl(Tree1(clause), 0); /* body of clause */ - } - if (Tree2(n) != NULL) - chksmpl(Tree2(n), 0); /* default */ - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - case N_Next: - break; - - case N_Id: - if (!smpl_invk) { - /* - * The variable is being used somewhere other than in a simple - * invocation. - */ - var = LSym0(n); - if (var->flag & F_Global) - var->val.global->flag &= ~F_SmplInv; - } - break; - - case N_If: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Invok: - lst_arg = 1 + Val0(n); - /* - * Check the thing being invoked, noting that it is in fact being - * invoked. - */ - chksmpl(Tree1(n), 1); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i - 1 */ - break; - - case N_InvOp: - lst_arg = 1 + Val0(n); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i */ - break; - - case N_Loop: { - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - case WHILE: - case UNTIL: - chksmpl(Tree1(n), 0); /* control clause */ - chksmpl(Tree2(n), 0); /* do clause */ - break; - - case REPEAT: - chksmpl(Tree1(n), 0); /* clause */ - break; - } - } - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) - chksmpl(Tree1(n), 0); - break; - - case N_Scan: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Sect: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - chksmpl(Tree4(n), 0); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * spcl_inv - look for general invocations that can be replaced by - * special invocations. Simple assignment to a named variable is - * is a particularly special case. Also, determine whether execution - * might "fall through" this code and whether the code might fail. - */ -static int spcl_inv(n, asgn) -struct node *n; -struct node *asgn; /* the result goes into this special-cased assignment */ - { - struct node *cases; - struct node *clause; - struct node *invokee; - struct gentry *gvar; - struct loop { - int exec_flg; - struct node *asgn; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - int exec_flg; - int i; - int lst_arg; - static struct loop *cur_loop = NULL; - - switch (n->n_type) { - case N_Activat: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), spcl_inv(Tree2(n), NULL)); - - case N_Alt: - exec_flg = spcl_inv(Tree0(n), asgn) & DoesFThru; - return exec_flg | spcl_inv(Tree1(n), asgn); - - case N_Apply: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree0(n), NULL), spcl_inv(Tree1(n), NULL)); - - case N_Augop: - exec_flg = chg_ret(Impl1(n)->ret_flag); - if (Tree2(n)->n_type == N_Id) { - /* - * This is an augmented assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAug; - if (Impl1(n)->use_rslt) - Val0(n) = AsgnCopy; - else - Val0(n) = AsgnDirect; - } - else { - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* this operation produces a variable */ - exec_flg = seq_exec(exec_flg, spcl_inv(Tree2(n), NULL)); - exec_flg = seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - } - return seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - - case N_Bar: - return spcl_inv(Tree0(n), asgn); - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return 0; - } - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - loop_sav->exec_flg |= spcl_inv(Tree0(n), loop_sav->asgn); - cur_loop = loop_sav; - return 0; - - case N_Create: - spcl_inv(Tree0(n), NULL); - return DoesFThru; - - case N_Case: - exec_flg = spcl_inv(Tree0(n), NULL) & DoesFail; /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - spcl_inv(Tree0(clause), NULL); - exec_flg |= spcl_inv(Tree1(clause), asgn); - } - if (Tree2(n) != NULL) - exec_flg |= spcl_inv(Tree2(n), asgn); /* default */ - else - exec_flg |= DoesFail; - return exec_flg; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - return DoesFThru; - - case N_Field: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* operation produces variable */ - return spcl_inv(Tree0(n), NULL); - - case N_Id: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* variable */ - return DoesFThru; - - case N_If: - spcl_inv(Tree0(n), NULL); - exec_flg = spcl_inv(Tree1(n), asgn); - if (Tree2(n)->n_type == N_Empty) - exec_flg |= DoesFail; - else - exec_flg |= spcl_inv(Tree2(n), asgn); - return exec_flg; - - case N_Invok: - lst_arg = 1 + Val0(n); - invokee = Tree1(n); - exec_flg = DoesFThru; - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, NULL)); - if (invokee->n_type == N_Id && LSym0(invokee)->flag & F_Global) { - /* - * This is an invocation of a global variable. If we can - * convert this to a direct invocation, determine whether - * it is an invocation of a procedure, built-in function, - * or record constructor; each has a difference kind of - * direct invocation node. - */ - gvar = LSym0(invokee)->val.global; - if (gvar->flag & F_SmplInv) { - switch (gvar->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - n->n_type = N_InvProc; - Proc1(n) = gvar->val.proc; - return DoesFThru | DoesFail; /* assume worst case */ - case F_Builtin: - n->n_type = N_InvOp; - Impl1(n) = gvar->val.builtin; - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return seq_exec(exec_flg, chg_ret( - gvar->val.builtin->ret_flag)); - case F_Record: - n->n_type = N_InvRec; - Rec1(n) = gvar->val.rec; - return seq_exec(exec_flg, DoesFThru | - (err_conv ? DoesFail : 0)); - } - } - } - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - spcl_inv(invokee, NULL); - return DoesFThru | DoesFail; /* assume worst case */ - - case N_InvOp: - if (Impl1(n)->op != NULL && strcmp(Impl1(n)->op, ":=") == 0 && - Tree2(n)->n_type == N_Id) { - /* - * This is a simple assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAsgn; - - /* - * For now, assume rhs of := can compute directly into a - * variable. This may be changed when the rhs is examined - * in the recursive call to spcl_inv(). - */ - Val0(n) = AsgnDirect; - return spcl_inv(Tree3(n), n); - } - else { - /* - * No special cases. - */ - lst_arg = 1 + Val0(n); - exec_flg = chg_ret(Impl1(n)->ret_flag); - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, - NULL)); /* arg i */ - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return exec_flg; - } - - case N_Limit: - return seq_exec(spcl_inv(Tree0(n), asgn), - spcl_inv(Tree1(n), NULL)) | DoesFail; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.exec_flg = 0; - loop_info.asgn = asgn; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - case WHILE: - case UNTIL: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - exec_flg = DoesFail; - break; - - case SUSPEND: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - ret_flag |= DoesSusp; - exec_flg = DoesFail; - break; - - case REPEAT: - spcl_inv(Tree1(n), NULL); /* clause */ - exec_flg = 0; - break; - } - exec_flg |= cur_loop->exec_flg; - cur_loop = cur_loop->prev; - return exec_flg; - } - - case N_Next: - return 0; - - case N_Not: - exec_flg = spcl_inv(Tree0(n), NULL); - return ((exec_flg & DoesFail) ? DoesFThru : 0) | - ((exec_flg & DoesFThru) ? DoesFail: 0); - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - exec_flg = spcl_inv(Tree1(n), NULL); - ret_flag |= DoesRet; - if (exec_flg & DoesFail) - ret_flag |= DoesFail; - } - else - ret_flag |= DoesFail; - return 0; - - case N_Scan: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), - spcl_inv(Tree2(n), NULL)); - - case N_Sect: - if (asgn != NULL && Impl0(n)->use_rslt) - Val0(asgn) = AsgnCopy; - exec_flg = spcl_inv(Tree2(n), NULL); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree4(n), NULL)); - return seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - - case N_Slist: - exec_flg = spcl_inv(Tree0(n), NULL); - if (exec_flg & (DoesFThru | DoesFail)) - exec_flg = DoesFThru; - return seq_exec(exec_flg, spcl_inv(Tree1(n), asgn)); - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * seq_exec - take the execution flags for sequential pieces of code - * and compute the flags for the combined code. - */ -static int seq_exec(exec_flg1, exec_flg2) -int exec_flg1; -int exec_flg2; - { - return (exec_flg1 & exec_flg2 & DoesFThru) | - ((exec_flg1 | exec_flg2) & DoesFail); - } - -/* - * chg_ret - take a return flag and change suspend and return to - * "fall through". If error conversion is supported, change error - * failure to failure. - * - */ -static int chg_ret(flag) -int flag; - { - int flg1; - - flg1 = flag & DoesFail; - if (flag & (DoesRet | DoesSusp)) - flg1 |= DoesFThru; - if (err_conv && (flag & DoesEFail)) - flg1 |= DoesFail; - return flg1; - } - - diff --git a/src/iconc/clex.c b/src/iconc/clex.c deleted file mode 100644 index 8e7d657..0000000 --- a/src/iconc/clex.c +++ /dev/null @@ -1,18 +0,0 @@ -/* - * clex.c -- the lexical analyzer for iconc. - */ -#define Iconc - -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctoken.h" -#include "ctree.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -#include "../h/parserr.h" -#include "../common/lextab.h" -#include "../common/yylex.h" -#include "../common/error.h" diff --git a/src/iconc/cmain.c b/src/iconc/cmain.c deleted file mode 100644 index 6daf5c4..0000000 --- a/src/iconc/cmain.c +++ /dev/null @@ -1,424 +0,0 @@ -/* - * cmain.c - main program icon compiler. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void execute (char *ofile, char **args); -static FILE *open_out (char *fname); -static void rmfile (char *fname); -static void report (char *s); -static void usage (void); - -char *refpath; - -char patchpath[MaxPath+18] = "%PatchStringHere->"; - -/* - * Define global variables. - */ - -#define Global -#define Init(v) = v -#include "cglobals.h" - -/* - * getopt() variables - */ -extern int optind; /* index into parent argv vector */ -extern int optopt; /* character checked for validity */ -extern char *optarg; /* argument associated with option */ - -/* - * main program - */ -int main(argc,argv) -int argc; -char **argv; - { - int no_c_comp = 0; /* suppress C compile and link? */ - int errors = 0; /* compilation errors */ - char *cfile = NULL; /* name of C file - primary */ - char *hfile = NULL; /* name of C file - include */ - char *ofile = NULL; /* name of executable result */ - - char *db_name = "rt.db"; /* data base name */ - char *incl_file = "rt.h"; /* header file name */ - - char *db_path; /* path to data base */ - char *db_lst; /* list of private data bases */ - char *incl_path; /* path to header file */ - char *s, c1; - char buf[MaxPath]; /* file name construction buffer */ - int c; - int ret_code; - struct fileparts *fp; - - if ((int)strlen(patchpath) > 18) - refpath = patchpath+18; - else - refpath = relfile(argv[0], "/../"); - - /* - * Process options. - */ - while ((c = getopt(argc,argv,"+C:ELS:Tcf:mn:o:p:r:stuv:x")) != EOF) - switch (c) { - case 'C': /* -C C-comp: C compiler*/ - c_comp = optarg; - break; - case 'E': /* -E: preprocess only */ - pponly = 1; - no_c_comp = 1; - break; - case 'L': /* Ignore: interpreter only */ - break; - case 'S': /* Ignore: interpreter only */ - break; - case 'T': - just_type_trace = 1; - break; - case 'c': /* -c: produce C file only */ - no_c_comp = 1; - break; - case 'f': /* -f: enable features */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -fa: enable all features */ - line_info = 1; - debug_info = 1; - err_conv = 1; - largeints = 1; - str_inv = 1; - break; - case 'd': /* -fd: enable debugging features */ - line_info = 1; - debug_info = 1; - break; - case 'e': /* -fe: enable error conversion */ - err_conv = 1; - break; - case 'l': /* -fl: support large integers */ - largeints = 1; - break; - case 'n': /* -fn: enable line numbers */ - line_info = 1; - break; - case 's': /* -fs: enable full string invocation */ - str_inv = 1; - break; - default: - quitf("-f option must be a, d, e, l, n, or s. found: %s", - optarg); - } - } - break; - case 'm': /* -m: preprocess using m4(1) */ - m4pre = 1; - break; - case 'n': /* -n: disable optimizations */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -na: disable all optimizations */ - opt_cntrl = 0; - allow_inline = 0; - opt_sgnl = 0; - do_typinfer = 0; - break; - case 'c': /* -nc: disable control flow opts */ - opt_cntrl = 0; - break; - case 'e': /* -ne: disable expanding in-line */ - allow_inline = 0; - break; - case 's': /* -ns: disable switch optimizations */ - opt_sgnl = 0; - break; - case 't': /* -nt: disable type inference */ - do_typinfer = 0; - break; - default: - usage(); - } - } - break; - case 'o': /* -o file: name output file */ - ofile = optarg; - break; - case 'p': /* -p C-opts: options for C comp */ - if (*optarg == '\0') /* if empty string, clear options */ - c_opts = optarg; - else { /* else append to current set */ - s = (char *)alloc(strlen(c_opts) + 1 + strlen(optarg) + 1); - sprintf(s, "%s %s", c_opts, optarg); - c_opts = s; - } - break; - case 'r': /* -r path: primary runtime system */ - refpath = optarg; - break; - case 's': /* -s: suppress informative messages */ - verbose = 0; - break; - case 't': /* -t: &trace = -1 */ - line_info = 1; - debug_info = 1; - trace = 1; - break; - case 'u': /* -u: warn about undeclared ids */ - uwarn = 1; - break; - case 'v': /* -v: set level of verbosity */ - if (sscanf(optarg, "%d%c", &verbose, &c1) != 1) - quitf("bad operand to -v option: %s",optarg); - break; - default: - case 'x': /* -x illegal until after file list */ - usage(); - } - - init(); /* initialize memory for translation */ - - /* - * Load the data bases of information about run-time routines and - * determine what libraries are needed for linking (these libraries - * go before any specified on the command line). - */ - db_lst = getenv("DBLIST"); - if (db_lst != NULL) - db_lst = salloc(db_lst); - s = db_lst; - while (s != NULL) { - db_lst = s; - while (isspace(*db_lst)) - ++db_lst; - if (*db_lst == '\0') - break; - for (s = db_lst; !isspace(*s) && *s != '\0'; ++s) - ; - if (*s == '\0') - s = NULL; - else - *s++ = '\0'; - readdb(db_lst); - addlib(salloc(makename(buf,SourceDir, db_lst, LibSuffix))); - } - db_path = (char *)alloc((unsigned int)strlen(refpath) + strlen(db_name) + 1); - strcpy(db_path, refpath); - strcat(db_path, db_name); - readdb(db_path); - addlib(salloc(makename(buf,SourceDir, db_path, LibSuffix))); - - /* - * Scan the rest of the command line for file name arguments. - */ - while (optind < argc) { - if (strcmp(argv[optind],"-x") == 0) /* stop at -x */ - break; - else if (strcmp(argv[optind],"-") == 0) - src_file("-"); /* "-" means standard input */ - else if (argv[optind][0] == '-') - addlib(argv[optind]); /* assume linker option */ - else { - fp = fparse(argv[optind]); /* parse file name */ - if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) { - makename(buf,SourceDir,argv[optind], SourceSuffix); - src_file(buf); - } - else - /* - * Assume all files that are not Icon source go to linker. - */ - addlib(argv[optind]); - } - optind++; - } - - if (srclst == NULL) - usage(); /* error -- no files named */ - - if (pponly) { - if (trans() == 0) - exit (EXIT_FAILURE); - else - exit (EXIT_SUCCESS); - } - - if (ofile == NULL) { /* if no -o file, synthesize a name */ - if (strcmp(srclst->name,"-") == 0) - ofile = salloc(makename(buf,TargetDir,"stdin",ExecSuffix)); - else - ofile = salloc(makename(buf,TargetDir,srclst->name,ExecSuffix)); - } else { /* add extension if necessary */ - fp = fparse(ofile); - if (*fp->ext == '\0' && *ExecSuffix != '\0') - ofile = salloc(makename(buf,NULL,ofile,ExecSuffix)); - } - - /* - * Make name of intermediate C files. - */ - cfile = salloc(makename(buf,TargetDir,ofile,CSuffix)); - hfile = salloc(makename(buf,TargetDir,ofile,HSuffix)); - - codefile = open_out(cfile); - fprintf(codefile, "#include \"%s\"\n", hfile); - - inclfile = open_out(hfile); - fprintf(inclfile, "#define COMPILER 1\n"); - - incl_path = (char *)alloc((unsigned int)(strlen(refpath) + - strlen(incl_file) + 1)); - strcpy(incl_path, refpath); - strcat(incl_path, incl_file); - fprintf(inclfile,"#include \"%s\"\n", incl_path); - - /* - * Translate .icn files to make C file. - */ - if ((verbose > 0) && !just_type_trace) - report("Translating to C"); - - errors = trans(); - if ((errors > 0) || just_type_trace) { /* exit if errors seen */ - rmfile(cfile); - rmfile(hfile); - if (errors > 0) - exit(EXIT_FAILURE); - else exit(EXIT_SUCCESS); - } - - fclose(codefile); - fclose(inclfile); - - /* - * Compile and link C file. - */ - if (no_c_comp) /* exit if no C compile wanted */ - exit(EXIT_SUCCESS); - - if (verbose > 0) - report("Compiling and linking C code"); - - ret_code = ccomp(cfile, ofile); - if (ret_code == EXIT_FAILURE) { - fprintf(stderr, "*** C compile and link failed ***\n"); - rmfile(ofile); - } - - /* - * Finish by removing C files. - */ - rmfile(cfile); - rmfile(hfile); - rmfile(makename(buf,TargetDir,cfile,ObjSuffix)); - - if (ret_code == EXIT_SUCCESS && optind < argc) { - if (verbose > 0) - report("Executing"); - execute (ofile, argv+optind+1); - } - - return ret_code; - } - -/* - * execute - execute compiled Icon program - */ -static void execute(ofile,args) -char *ofile, **args; - { - - int n; - char **argv, **p; - char buf[MaxPath]; /* file name construction buffer */ - - ofile = salloc(makename(buf,"./",ofile,ExecSuffix)); - - for (n = 0; args[n] != NULL; n++) /* count arguments */ - ; - p = argv = (char **)alloc((unsigned int)((n + 2) * sizeof(char *))); - - *p++ = ofile; /* set executable file */ - - while (*p++ = *args++) /* copy args into argument vector */ - ; - *p = NULL; - - execvp(ofile,argv); - quitf("could not run %s",ofile); - } - -/* - * Report phase. - */ -static void report(s) -char *s; - { - fprintf(stderr,"%s:\n",s); - } - -/* - * rmfile - remove a file - */ - -static void rmfile(fname) -char *fname; - { - remove(fname); - } - -/* - * open_out - open a C output file and write identifying information - * to the front. - */ -static FILE *open_out(fname) -char *fname; - { - FILE *f; - static char *ident = "/*ICONC*/"; - int c; - int i; - - /* - * If the file already exists, make sure it is old output from iconc - * before overwriting it. Note, this test doesn't work if the file - * is writable but not readable. - */ - f = fopen(fname, "r"); - if (f != NULL) { - for (i = 0; i < (int)strlen(ident); ++i) { - c = getc(f); - if (c == EOF) - break; - if ((char)c != ident[i]) - quitf("%s not in iconc format; rename or delete, and rerun", fname); - } - fclose(f); - } - - f = fopen(fname, "w"); - if (f == NULL) - quitf("cannot create %s", fname); - fprintf(f, "%s\n", ident); /* write "belongs to iconc" comment */ - id_comment(f); /* write detailed comment for human readers */ - fflush(f); - return f; - } - -/* - * Print an error message if called incorrectly. The message depends - * on the legal options for this system. - */ -static void usage() - { - fprintf(stderr,"usage: %s %s file ... [-x args]\n", progname, CUsage); - exit(EXIT_FAILURE); - } diff --git a/src/iconc/cmem.c b/src/iconc/cmem.c deleted file mode 100644 index 720a495..0000000 --- a/src/iconc/cmem.c +++ /dev/null @@ -1,114 +0,0 @@ -/* - * cmem.c -- memory initialization and allocation for the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct centry *chash[CHSize]; /* hash area for constant table */ -struct fentry *fhash[FHSize]; /* hash area for field table */ -struct gentry *ghash[GHSize]; /* hash area for global table */ - -struct implement *bhash[IHSize]; /* hash area for built-in functions */ -struct implement *khash[IHSize]; /* hash area for keywords */ -struct implement *ohash[IHSize]; /* hash area for operators */ - -struct implement *spec_op[NumSpecOp]; /* table of ops with special syntax */ - -char pre[PrfxSz] = {'0', '0', '0'}; /* initial function name prefix */ - -extern struct str_buf lex_sbuf; - - -/* - * init - initialize memory for the translator - */ - -void init() -{ - int i; - - init_str(); - init_sbuf(&lex_sbuf); - - /* - * Zero out the hash tables. - */ - for (i = 0; i < CHSize; i++) - chash[i] = NULL; - for (i = 0; i < FHSize; i++) - fhash[i] = NULL; - for (i = 0; i < GHSize; i++) - ghash[i] = NULL; - for (i = 0; i < IHSize; i++) { - bhash[i] = NULL; - khash[i] = NULL; - ohash[i] = NULL; - } - - /* - * Clear table of operators with non-standard operator syntax. - */ - for (i = 0; i < NumSpecOp; ++i) - spec_op[i] = NULL; - } - -/* - * init_proc - add a new entry on front of procedure list. - */ -void init_proc(name) -char *name; - { - register struct pentry *p; - int i; - struct gentry *sym_ent; - - p = NewStruct(pentry); - p->name = name; - nxt_pre(p->prefix, pre, PrfxSz); - p->prefix[PrfxSz] = '\0'; - p->nargs = 0; - p->args = NULL; - p->ndynam = 0; - p->dynams = NULL; - p->nstatic = 0; - p->has_coexpr = 0; - p->statics = NULL; - p->ret_flag = DoesRet | DoesFail | DoesSusp; /* start out pessimistic */ - p->arg_lst = 0; - p->lhash = - (struct lentry **)alloc((unsigned int)((LHSize)*sizeof(struct lentry *))); - for (i = 0; i < LHSize; i++) - p->lhash[i] = NULL; - p->next = proc_lst; - proc_lst = p; - sym_ent = instl_p(name, F_Proc); - sym_ent->val.proc = proc_lst; - } - -/* - * init_rec - add a new entry on the front of the record list. - */ -void init_rec(name) -char *name; - { - register struct rentry *r; - struct gentry *sym_ent; - static int rec_num = 0; - - r = NewStruct(rentry); - r->name = name; - nxt_pre(r->prefix, pre, PrfxSz); - r->prefix[PrfxSz] = '\0'; - r->rec_num = rec_num++; - r->nfields = 0; - r->fields = NULL; - r->next = rec_lst; - rec_lst = r; - sym_ent= instl_p(name, F_Record); - sym_ent->val.rec = r; - } diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c deleted file mode 100644 index 8ca5bd1..0000000 --- a/src/iconc/codegen.c +++ /dev/null @@ -1,1918 +0,0 @@ -/* - * codegen.c - routines to write out C code. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "cproto.h" - -#ifndef LoopThreshold -#define LoopThreshold 7 -#endif /* LoopThreshold */ - -/* - * MinOne - arrays sizes must be at least 1. - */ -#define MinOne(n) ((n) > 0 ? (n) : 1) - -/* - * ChkSeqNum - make sure a label has been given a sequence number. - */ -#define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num - -/* - * ChkBound - for a given procedure, signals that transfer control to a - * bounding label all use the same signal number. - */ -#define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x)) - -/* - * When a switch statement for signal handling is optimized, there - * are three possible forms of default clauses. - */ -#define DfltNone 0 /* no default clause */ -#define DfltBrk 1 /* default is just a break */ -#define DfltRetSig 2 /* default is to return the signal from the call */ - -/* - * Prototypes for static functions. - */ -static int arg_nms (struct lentry *lptr, int prt); -static void bi_proc (char *name, struct implement *ip); -static void chkforgn (int outer); -static int dyn_nms (struct lentry *lptr, int prt); -static void fldnames (struct fldname *fields); -static void fnc_blk (struct gentry *gptr); -static void frame (int outer); -static void good_clsg (struct code *call, int outer); -static void initpblk (FILE *f, int c, char *prefix, char *name, - int nquals, int nparam, int ndynam, int nstatic, - int frststat); -static char *is_builtin (struct gentry *gptr); -static void proc_blk (struct gentry *gptr, int init_glbl); -static void prt_ary (struct code *cd, int outer); -static void prt_cond (struct code *cond); -static void prt_cont (struct c_fnc *cont); -static void prt_var (struct lentry *var, int outer); -static void prtcall (struct code *call, int outer); -static void prtcode (struct code *cd, int outer); -static void prtpccall (int outer); -static void rec_blk (struct gentry *gptr, int init_glbl); -static void smpl_clsg (struct code *call, int outer); -static void stat_nms (struct lentry *lptr, int prt); -static void val_loc (struct val_loc *rslt, int outer); - -static int n_stat = -1; /* number of static variables */ - -/* - * var_dcls - produce declarations necessary to implement variables - * and to initialize globals and statics: procedure blocks, procedure - * frames, record blocks, declarations for globals and statics, the - * C main program. - */ -void var_dcls() - { - register int i; - register struct gentry *gptr; - struct gentry *gbl_main; - struct pentry *prc_main; - int n_glob = 0; - int flag; - int init_glbl; - int first; - char *pfx; - - /* - * Output initialized array of descriptors for globals. - */ - fprintf(codefile, "\nstatic struct {word dword; union block *vword;}"); - fprintf(codefile, " init_globals[NGlobals] = {\n"); - prc_main = NULL; - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag & ~(F_Global | F_StrInv); - if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) { - /* - * Remember main procedure. - */ - gbl_main = gptr; - prc_main = gbl_main->val.proc; - } - if (flag == 0) { - /* - * Ordinary variable. - */ - gptr->index = n_glob++; - fprintf(codefile, " {D_Null},\n"); - } - else { - /* - * Procedure, function, or record constructor. If the variable - * has not been optimized away, initialize the it to reference - * the procedure block. - */ - if (flag & F_SmplInv) { - init_glbl = 0; - flag &= ~(uword)F_SmplInv; - } - else { - init_glbl = 1; - gptr->index = n_glob++; - fprintf(codefile, " {D_Proc, "); - } - switch (flag) { - case F_Proc: - proc_blk(gptr, init_glbl); - break; - case F_Builtin: - if (init_glbl) - fnc_blk(gptr); - break; - case F_Record: - rec_blk(gptr, init_glbl); - } - } - } - if (n_glob == 0) - fprintf(codefile, " {D_Null} /* place holder */\n"); - fprintf(codefile, " };\n"); - - if (prc_main == NULL) { - nfatal(NULL, "main procedure missing", NULL); - return; - } - - /* - * Output array of descriptors initialized to the names of the - * global variables that have not been optimized away. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n"); - else { - fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) - fprintf(codefile, " {%d, \"%s\"},\n", strlen(gptr->name), - gptr->name); - fprintf(codefile, " };\n"); - } - - /* - * Output array of pointers to builtin functions that correspond to - * names of the global variables. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct b_proc *builtins[1];\n"); - else { - fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) { - /* - * Need to output *something* to stay in step with other arrays. - */ - if (pfx = is_builtin(gptr)) { - fprintf(codefile, " (struct b_proc *)&BF%c%c_%s,\n", - pfx[0], pfx[1], gptr->name); - } - else - fprintf(codefile, " 0,\n"); - } - fprintf(codefile, " };\n"); - } - - /* - * Output C main function that initializes the run-time system and - * calls the main procedure. - */ - fprintf(codefile, "\n"); - fprintf(codefile, "int main(argc, argv)\n"); - fprintf(codefile, "int argc;\n"); - fprintf(codefile, "char **argv;\n"); - fprintf(codefile, " {\n"); - - /* - * If the main procedure requires a command-line argument list, we - * need a place to construct the Icon argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " struct {\n"); - fprintf(codefile, " struct tend_desc *previous;\n"); - fprintf(codefile, " int num;\n"); - fprintf(codefile, " struct descrip arg_lst;\n"); - fprintf(codefile, " } t;\n"); - fprintf(codefile, "\n"); - } - - /* - * Produce code to initialize run-time system variables. Some depend - * on compiler options. - */ - fprintf(codefile, " op_tbl = (struct b_proc *)init_op_tbl;\n"); - fprintf(codefile, " globals = (dptr)init_globals;\n"); - fprintf(codefile, " eglobals = &globals[%d];\n", n_glob); - fprintf(codefile, " gnames = (dptr)init_gnames;\n"); - fprintf(codefile, " egnames = &gnames[%d];\n", n_glob); - fprintf(codefile, " estatics = &statics[%d];\n", n_stat + 1); - if (debug_info) - fprintf(codefile, " debug_info = 1;\n"); - else - fprintf(codefile, " debug_info = 0;\n"); - if (line_info) { - fprintf(codefile, " line_info = 1;\n"); - fprintf(codefile, " file_name = \"\";\n"); - fprintf(codefile, " line_num = 0;\n"); - } - else - fprintf(codefile, " line_info = 0;\n"); - if (err_conv) - fprintf(codefile, " err_conv = 1;\n"); - else - fprintf(codefile, " err_conv = 0;\n"); - if (largeints) - fprintf(codefile, " largeints = 1;\n"); - else - fprintf(codefile, " largeints = 0;\n"); - - /* - * Produce code to call the routine to initialize the runtime system. - */ - if (trace) - fprintf(codefile, " init(*argv, &argc, argv, -1);\n"); - else - fprintf(codefile, " init(*argv, &argc, argv, 0);\n"); - fprintf(codefile, "\n"); - - /* - * If the main procedure requires an argument list (perhaps because - * it uses standard, rather than tailored calling conventions), - * set up the argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " t.arg_lst = nulldesc;\n"); - fprintf(codefile, " t.num = 1;\n"); - fprintf(codefile, " t.previous = NULL;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&t;\n"); - if (prc_main->nargs == 0) - fprintf(codefile, - " /* main() takes no arguments: construct no list */\n"); - else - fprintf(codefile, " cmd_line(argc, argv, &t.arg_lst);\n"); - fprintf(codefile, "\n"); - } - else - fprintf(codefile, " tend = NULL;\n"); - - if (gbl_main->flag & F_SmplInv) { - /* - * procedure main only has a simplified implementation if it - * takes either 0 or 1 argument. - */ - first = 1; - if (prc_main->nargs == 0) - fprintf(codefile, " P%s_main(", prc_main->prefix); - else { - fprintf(codefile, " P%s_main(&t.arg_lst", prc_main->prefix); - first = 0; - } - if (prc_main->ret_flag & (DoesRet | DoesSusp)) { - if (!first) - fprintf(codefile, ", "); - fprintf(codefile, "&trashcan"); - first = 0; - } - if (prc_main->ret_flag & DoesSusp) - fprintf(codefile, ", (continuation)NULL"); - fprintf(codefile, ");\n"); - } - else /* the main procedure uses standard calling conventions */ - fprintf(codefile, - " P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n", - prc_main->prefix); - fprintf(codefile, " \n"); - fprintf(codefile, " c_exit(EXIT_SUCCESS);\n"); - fprintf(codefile, " }\n"); - - /* - * Output to header file definitions related to global and static - * variables. - */ - fprintf(inclfile, "\n"); - if (n_glob == 0) { - fprintf(inclfile, "#define NGlobals 1\n"); - fprintf(inclfile, "int n_globals = 0;\n"); - } - else { - fprintf(inclfile, "#define NGlobals %d\n", n_glob); - fprintf(inclfile, "int n_globals = NGlobals;\n"); - } - ++n_stat; - fprintf(inclfile, "\n"); - fprintf(inclfile, "int n_statics = %d;\n", n_stat); - fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat)); - if (n_stat > 0) { - fprintf(inclfile, " = {\n"); - for (i = 0; i < n_stat; ++i) - fprintf(inclfile, " {D_Null},\n"); - fprintf(inclfile, " };\n"); - } - else - fprintf(inclfile, ";\n"); - } - -/* - * proc_blk - create procedure block and initialize global variable, also - * compute offsets for local procedure variables. - */ -static void proc_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct pentry *p; - register char *name; - int nquals; - - name = gptr->name; - p = gptr->val.proc; - - /* - * If we don't initialize a global variable for this procedure, we - * need only compute offsets for variables. - */ - if (init_glbl) { - fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name); - nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic; - fprintf(inclfile, "\n"); - fprintf(inclfile, "static int P%s_%s (int r_nargs, dptr r_args,", - p->prefix, name); - fprintf(inclfile, "dptr r_rslt, continuation r_s_cont);\n"); - initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam, - p->nstatic, n_stat + 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - } - arg_nms(p->args, init_glbl); - p->tnd_loc = dyn_nms(p->dynams, init_glbl); - stat_nms(p->statics, init_glbl); - if (init_glbl) - fprintf(inclfile, " }};\n"); - } - -/* - * arg_nms - compute offsets of arguments and, if needed, output the - * initializer for a descriptor for the argument name. - */ -static int arg_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = arg_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * dyn_nms - compute offsets of dynamic locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static int dyn_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = dyn_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * stat_nams - compute offsets of static locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static void stat_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - if (lptr == NULL) - return; - stat_nms(lptr->next, prt); - lptr->val.index = ++n_stat; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - } - -/* - * is_builtin - check if a global names or hides a builtin, returning prefix. - * If it hides one, we must also generate the prototype and block here. - */ -static char *is_builtin(gptr) -struct gentry *gptr; - { - struct implement *iptr; - - if (!(gptr->flag & F_StrInv)) /* if not eligible for string invoc */ - return 0; - if (gptr->flag & F_Builtin) /* if global *is* a builtin */ - return gptr->val.builtin->prefix; - iptr = db_ilkup(gptr->name, bhash); - if (iptr == NULL) /* if no builtin by this name */ - return NULL; - bi_proc(gptr->name, iptr); /* output prototype and proc block */ - return iptr->prefix; - } - -/* - * fnc_blk - output vword of descriptor for a built-in function and its - * procedure block. - */ -static void fnc_blk(gptr) -struct gentry *gptr; - { - struct implement *iptr; - char *name, *pfx; - - name = gptr->name; - iptr = gptr->val.builtin; - pfx = iptr->prefix; - /* - * output prototype and procedure block to inclfile. - */ - bi_proc(name, iptr); - /* - * vword of descriptor references the procedure block. - */ - fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name); - } - -/* - * bi_proc - output prototype and procedure block for builtin function. - */ -static void bi_proc(name, ip) -char *name; - struct implement *ip; - { - int nargs; - char prefix[3]; - - prefix[0] = ip->prefix[0]; - prefix[1] = ip->prefix[1]; - prefix[2] = '\0'; - nargs = ip->nargs; - if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - fprintf(inclfile, "\n"); - implproto(ip); - initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0); - fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name); - } - -/* - * rec_blk - if needed, output vword of descriptor for a record - * constructor and output its procedure block. - */ -static void rec_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct rentry *r; - register char *name; - int nfields; - - name = gptr->name; - r = gptr->val.rec; - nfields = r->nfields; - - /* - * If the variable is not optimized away, output vword of descriptor. - */ - if (init_glbl) - fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name); - - fprintf(inclfile, "\n"); - /* - * Prototype for C function implementing constructor. If no optimizations - * have been performed on the variable, the standard calling conventions - * are used and we need a continuation parameter. - */ - fprintf(inclfile, - "static int R%s_%s (int r_nargs, dptr r_args, dptr r_rslt", - r->prefix, name); - if (init_glbl) - fprintf(inclfile, ", continuation r_s_cont"); - fprintf(inclfile, ");\n"); - - /* - * Procedure block, including record name and field names. - */ - initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2, - r->rec_num, 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - fldnames(r->fields); - fprintf(inclfile, " }};\n"); - } - - -/* - * fldnames - output the initializer for a descriptor for the field name. - */ -static void fldnames(fields) -struct fldname *fields; - { - register char *name; - - if (fields == NULL) - return; - fldnames(fields->next); - name = fields->name; - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(name), name); - } - -/* - * implproto - print prototype for function implementing a run-time operation. - */ -void implproto(ip) -struct implement *ip; - { - if (ip->iconc_flgs & ProtoPrint) - return; /* only print prototype once */ - fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0], - ip->prefix[1], ip->name); - fprintf(inclfile, "(int r_nargs, dptr r_args, dptr r_rslt, "); - fprintf(inclfile,"continuation r_s_cont);\n"); - ip->iconc_flgs |= ProtoPrint; - } - -/* - * const_blks - output blocks for cset and real constants. - */ -void const_blks() - { - register int i; - register struct centry *cptr; - - fprintf(inclfile, "\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - switch (cptr->flag) { - case F_CsetLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix); - cset_init(inclfile, cptr->u.cset); - break; - case F_RealLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n", - cptr->prefix, cptr->image); - break; - } - } - } - -/* - * reccnstr - output record constructors. - */ -void recconstr(r) -struct rentry *r; - { - register char *name; - int optim; - int nfields; - - if (r == NULL) - return; - recconstr(r->next); - - name = r->name; - nfields = r->nfields; - - /* - * Does this record constructor use optimized calling conventions? - */ - optim = glookup(name)->flag & F_SmplInv; - - fprintf(codefile, "\n"); - fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix, - name); - if (!optim) - fprintf(codefile, ", r_s_cont"); /* continuation is passed */ - fprintf(codefile, ")\n"); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - if (!optim) - fprintf(codefile, "continuation r_s_cont;\n"); - fprintf(codefile, " {\n"); - fprintf(codefile, " register int i;\n"); - fprintf(codefile, " register struct b_record *rp;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " rp = alcrecd(%d, (union block *)&BR%s_%s);\n", - nfields, r->prefix, name); - fprintf(codefile, " if (rp == NULL) {\n"); - fprintf(codefile, " err_msg(307, NULL);\n"); - if (err_conv) - fprintf(codefile, " return A_Resume;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " for (i = %d; i >= 0; i--)\n", nfields - 1); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, " deref(&r_args[i], &rp->fields[i]);\n"); - fprintf(codefile, " else\n"); - fprintf(codefile, " rp->fields[i] = nulldesc;\n"); - fprintf(codefile, " r_rslt->vword.bptr = (union block *)rp;\n"); - fprintf(codefile, " r_rslt->dword = D_Record;\n"); - fprintf(codefile, " return A_Continue;\n"); - fprintf(codefile, " }\n"); - } - -/* - * outerfnc - output code for the outer function implementing a procedure. - */ -void outerfnc(fnc) -struct c_fnc *fnc; - { - char *prefix; - char *name; - char *cnt_var; - char *sep; - int ntend; - int first_arg; - int nparms; - int optim; /* optimized interface: no arg list adjustment */ - int ret_flag; -#ifdef OptimizeLoop - int i; -#endif /* OptimizeLoop */ - - prefix = cur_proc->prefix; - name = cur_proc->name; - ntend = cur_proc->tnd_loc + num_tmp; - ChkPrefix(fnc->prefix); - optim = glookup(name)->flag & F_SmplInv; - nparms = Abs(cur_proc->nargs); - ret_flag = cur_proc->ret_flag; - - fprintf(codefile, "\n"); - if (optim) { - /* - * Arg list adjustment and dereferencing are done at call site. - * Use simplified interface. Output both function header and - * prototype. - */ - sep = ""; - fprintf(inclfile, "static int P%s_%s (", prefix, name); - fprintf(codefile, "static int P%s_%s(", prefix, name); - if (nparms != 0) { - fprintf(inclfile, "dptr r_args"); - fprintf(codefile, "r_args"); - sep = ", "; - } - if (ret_flag & (DoesRet | DoesSusp)) { - fprintf(inclfile, "%sdptr r_rslt", sep); - fprintf(codefile, "%sr_rslt", sep); - sep = ", "; - } - if (ret_flag & DoesSusp) { - fprintf(inclfile, "%scontinuation r_s_cont", sep); - fprintf(codefile, "%sr_s_cont", sep); - sep = ", "; - } - if (*sep == '\0') - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - fprintf(codefile, ")\n"); - if (nparms != 0) - fprintf(codefile, "dptr r_args;\n"); - if (ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, "dptr r_rslt;\n"); - if (ret_flag & DoesSusp) - fprintf(codefile, "continuation r_s_cont;\n"); - } - else { - /* - * General invocation interface. Output function header; prototype has - * already been produced. - */ - fprintf(codefile, - "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix, - name); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - fprintf(codefile, "continuation r_s_cont;\n"); - } - - fprintf(codefile, "{\n"); - fprintf(codefile, " struct PF%s_%s r_frame;\n", prefix, name); - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " int i;\n"); - if (Type(Tree1(cur_proc->tree)) != N_Empty) - fprintf(codefile, " static int first_time = 1;"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_frame.old_pfp = pfp;\n"); - fprintf(codefile, " pfp = (struct p_frame *)&r_frame;\n"); - fprintf(codefile, " r_frame.old_argp = glbl_argp;\n"); - if (!optim || ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, " r_frame.rslt = r_rslt;\n"); - else - fprintf(codefile, " r_frame.rslt = NULL;\n"); - if (!optim || ret_flag & DoesSusp) - fprintf(codefile, " r_frame.succ_cont = r_s_cont;\n"); - else - fprintf(codefile, " r_frame.succ_cont = NULL;\n"); - fprintf(codefile, "\n"); -#ifdef OptimizeLoop - if (ntend > 0) { - if (ntend < LoopThreshold) - for (i=0; i < ntend ;i++) - fprintf(codefile, " r_frame.tend.d[%d] = nulldesc;\n", i); - else { - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); - } - } -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); -#endif /* OptimizeLoop */ - if (optim) { - /* - * Dereferencing and argument list adjustment is done at the call - * site. There is not much to do here. - */ - if (nparms == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else - fprintf(codefile, " glbl_argp = r_args;\n"); - } - else { - /* - * Dereferencing and argument list adjustment must be done by - * the procedure itself. - */ - first_arg = ntend; - ntend += nparms; - if (cur_proc->nargs < 0) { - /* - * varargs - construct a list into the last argument. - */ - nparms -= 1; - if (nparms == 0) - cnt_var = "r_nargs"; - else { - fprintf(codefile, " i = r_nargs - %d;\n", nparms); - cnt_var = "i"; - } - fprintf(codefile," if (%s <= 0)\n", cnt_var); - fprintf(codefile," varargs(NULL, 0, &r_frame.tend.d[%d]);\n", - first_arg + nparms); - fprintf(codefile," else\n"); - fprintf(codefile, - " varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms, - cnt_var, first_arg + nparms); - } - if (nparms > 0) { - /* - * Output code to dereference argument or supply default null - * value. - */ -#ifdef OptimizeLoop - fprintf(codefile, " for (i = 0; i < r_nargs ; ++i)\n"); - fprintf(codefile, " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", first_arg); - fprintf(codefile, " for(i = r_nargs; i < %d ; ++i)\n", nparms); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", nparms); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, - " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", - first_arg); - fprintf(codefile, " else\n"); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#endif /* OptimizeLoop */ - } - fprintf(codefile, " glbl_argp = &r_frame.tend.d[%d];\n", first_arg); - } - fprintf(codefile, " r_frame.tend.num = %d;\n", ntend); - fprintf(codefile, " r_frame.tend.previous = tend;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&r_frame.tend;\n"); - if (line_info) { - fprintf(codefile, " r_frame.debug.old_line = line_num;\n"); - fprintf(codefile, " r_frame.debug.old_fname = file_name;\n"); - } - if (debug_info) { - fprintf(codefile, " r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n", - prefix, name); - fprintf(codefile, " if (k_trace) ctrace();\n"); - fprintf(codefile, " ++k_level;\n\n"); - } - fprintf(codefile, "\n"); - - /* - * Output definition for procedure frame. - */ - prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Output code to implement procedure body. - */ - prtcode(&(fnc->cd), 1); - fprintf(codefile, " }\n"); - } - -/* - * prt_fnc - output C function that implements a continuation. - */ -void prt_fnc(fnc) -struct c_fnc *fnc; - { - struct code *sig; - char *name; - char *prefix; - - if (fnc->flag & CF_SigOnly) { - /* - * This function only returns a signal. A shared function is used in - * its place. Make sure that function has been printed. - */ - sig = fnc->cd.next->SigRef->sig; - if (sig->cd_id != C_Resume) { - sig = ChkBound(sig); - if (!(sig->LabFlg & FncPrtd)) { - ChkSeqNum(sig); - fprintf(inclfile, "static int sig_%d (void);\n", - sig->SeqNum); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int sig_%d()\n", sig->SeqNum); - fprintf(codefile, " {\n"); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - fprintf(codefile, " }\n"); - sig->LabFlg |= FncPrtd; - } - } - } - else { - ChkPrefix(fnc->prefix); - prefix = fnc->prefix; - name = cur_proc->name; - - fprintf(inclfile, "static int P%s_%s (void);\n", prefix, name); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int P%s_%s()\n", prefix, name); - fprintf(codefile, " {\n"); - if (fnc->flag & CF_Coexpr) - fprintf(codefile, "#ifdef Coexpr\n"); - - prefix = fnc->frm_prfx; - - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " register struct PF%s_%s *r_pfp;\n", prefix, name); - fprintf(codefile, "\n"); - fprintf(codefile, " r_pfp = (struct PF%s_%s *)pfp;\n", prefix, name); - prtcode(&(fnc->cd), 0); - if (fnc->flag & CF_Coexpr) { - fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n"); - fprintf(codefile, " fatalerr(401, NULL);\n"); - fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n"); - } - fprintf(codefile, " }\n"); - } - } - -/* - * prt_frame - output the definition for a procedure frame. - */ -void prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf) -char *prefix; -int ntend; -int n_itmp; -int n_dtmp; -int n_sbuf; -int n_cbuf; - { - int i; - - /* - * Output standard part of procedure frame including tended - * descriptors. - */ - fprintf(inclfile, "\n"); - fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name); - fprintf(inclfile, " struct p_frame *old_pfp;\n"); - fprintf(inclfile, " dptr old_argp;\n"); - fprintf(inclfile, " dptr rslt;\n"); - fprintf(inclfile, " continuation succ_cont;\n"); - fprintf(inclfile, " struct {\n"); - fprintf(inclfile, " struct tend_desc *previous;\n"); - fprintf(inclfile, " int num;\n"); - fprintf(inclfile, " struct descrip d[%d];\n", MinOne(ntend)); - fprintf(inclfile, " } tend;\n"); - - if (line_info) { /* must be true if debug_info is true */ - fprintf(inclfile, " struct debug debug;\n"); - } - - /* - * Output declarations for the integer, double, string buffer, - * and cset buffer work areas of the frame. - */ - for (i = 0; i < n_itmp; ++i) - fprintf(inclfile, " word i%d;\n", i); - for (i = 0; i < n_dtmp; ++i) - fprintf(inclfile, " double d%d;\n", i); - if (n_sbuf > 0) - fprintf(inclfile, " char sbuf[%d][MaxCvtLen];", n_sbuf); - if (n_cbuf > 0) - fprintf(inclfile, " struct b_cset cbuf[%d];", n_cbuf); - fprintf(inclfile, " };\n"); - } - -/* - * prtcode - print a list of C code. - */ -static void prtcode(cd, outer) -struct code *cd; -int outer; - { - struct lentry *var; - struct centry *lit; - struct code *sig; - int n; - - for ( ; cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_Null: - break; - - case C_NamedVar: - /* - * Construct a reference to a named variable in a result - * location. - */ - var = cd->NamedVar; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Var;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.descptr = &"); - prt_var(var, outer); - fprintf(codefile, ";\n"); - break; - - case C_CallSig: - /* - * Call to C function that returns a signal along with signal - * handling code. - */ - if (opt_sgnl) - good_clsg(cd, outer); - else - smpl_clsg(cd, outer); - break; - - case C_RetSig: - /* - * Return a signal. - */ - sig = cd->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, " return A_Resume;\n"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - } - break; - - case C_Goto: - /* - * goto label. - */ - ChkSeqNum(cd->Lbl); - fprintf(codefile, " goto L%d /* %s */;\n", cd->Lbl->SeqNum, - cd->Lbl->Desc); - break; - - case C_Label: - /* - * numbered label. - */ - if (cd->RefCnt > 0) { - ChkSeqNum(cd); - fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc); - } - break; - - case C_Lit: - /* - * Assign literal value to a result location. - */ - lit = cd->Literal; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - switch (lit->flag) { - case F_CsetLit: - fprintf(codefile, ".dword = D_Cset;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n", - lit->prefix); - break; - case F_IntLit: - if (lit->u.intgr == -1) { - /* - * Large integer literal - output string and convert - * to integer. - */ - fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", strlen(lit->image)); - fprintf(codefile, " cnv_int(&"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ", &"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ");\n"); - } - else { - /* - * Ordinary integer literal. - */ - fprintf(codefile, ".dword = D_Integer;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr); - } - break; - case F_RealLit: - fprintf(codefile, ".dword = D_Real;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n", - lit->prefix); - break; - case F_StrLit: - fprintf(codefile, ".vword.sptr = "); - if (lit->length == 0) { - /* - * Placing an empty string at the end of the string region - * allows some concatenation optimizations at run time. - */ - fprintf(codefile, "strfree;\n"); - n = 0; - } - else { - fprintf(codefile, "\""); - n = prt_i_str(codefile, lit->image, lit->length); - fprintf(codefile, "\";\n"); - } - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", n); - break; - } - break; - - case C_PFail: - /* - * Procedure failure - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) failtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Resume;\n"); - break; - - case C_PRet: - /* - * Procedure return - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) rtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Continue;\n"); - break; - - case C_PSusp: - /* - * Procedure suspend - call success continuation. - */ - prtpccall(outer); - break; - - case C_Break: - fprintf(codefile, " break;\n"); - break; - - case C_If: - /* - * C if statement. - */ - fprintf(codefile, " if ("); - prt_ary(cd->Cond, outer); - fprintf(codefile, ")\n "); - prtcode(cd->ThenStmt, outer); - break; - - case C_CdAry: - /* - * Array of code fragments. - */ - fprintf(codefile, " "); - prt_ary(cd, outer); - fprintf(codefile, "\n"); - break; - - case C_LBrack: - fprintf(codefile, " {\n"); - break; - - case C_RBrack: - fprintf(codefile, " }\n"); - break; - - case C_Create: - /* - * Code to create a co-expression and assign it to a result - * location. - */ - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile , ".vword.bptr = (union block *)create("); - prt_cont(cd->Cont); - fprintf(codefile, - ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n", - cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Coexpr;\n"); - break; - - case C_SrcLoc: - /* - * Update file name and line number information. - */ - if (cd->FileName != NULL) { - fprintf(codefile, " file_name = \""); - prt_i_str(codefile, cd->FileName, strlen(cd->FileName)); - fprintf(codefile, "\";\n"); - } - if (cd->LineNum != 0) - fprintf(codefile, " line_num = %d;\n", cd->LineNum); - break; - } - } - } - -/* - * prt_var - output C code to reference an Icon named variable. - */ -static void prt_var(var, outer) -struct lentry *var; -int outer; - { - switch (var->flag) { - case F_Global: - fprintf(codefile, "globals[%d]", var->val.global->index); - break; - case F_Static: - fprintf(codefile, "statics[%d]", var->val.index); - break; - case F_Dynamic: - frame(outer); - fprintf(codefile, ".tend.d[%d]", var->val.index); - break; - case F_Argument: - fprintf(codefile, "glbl_argp[%d]", var->val.index); - } - - /* - * Include an identifying comment. - */ - fprintf(codefile, " /* %s */", var->name); - } - -/* - * prt_ary - print an array of code fragments. - */ -static void prt_ary(cd, outer) -struct code *cd; -int outer; - { - int i; - - for (i = 0; cd->ElemTyp(i) != A_End; ++i) - switch (cd->ElemTyp(i)) { - case A_Str: - /* - * Simple C code in a string. - */ - fprintf(codefile, "%s", cd->Str(i)); - break; - case A_ValLoc: - /* - * Value location (usually variable of some sort). - */ - val_loc(cd->ValLoc(i), outer); - break; - case A_Intgr: - /* - * Integer. - */ - fprintf(codefile, "%d", cd->Intgr(i)); - break; - case A_ProcCont: - /* - * Current procedure call's success continuation. - */ - if (outer) - fprintf(codefile, "r_s_cont"); - else - fprintf(codefile, "r_pfp->succ_cont"); - break; - case A_SBuf: - /* - * One of the string buffers. - */ - frame(outer); - fprintf(codefile, ".sbuf[%d]", cd->Intgr(i)); - break; - case A_CBuf: - /* - * One of the cset buffers. - */ - fprintf(codefile, "&("); - frame(outer); - fprintf(codefile, ".cbuf[%d])", cd->Intgr(i)); - break; - case A_Ary: - /* - * A subarray of code fragments. - */ - prt_ary(cd->Array(i), outer); - break; - } - } - -/* - * frame - access to the procedure frame. Access directly from outer function, - * but access through r_pfp from a continuation. - */ -static void frame(outer) -int outer; - { - if (outer) - fprintf(codefile, "r_frame"); - else - fprintf(codefile, "(*r_pfp)"); - } - -/* - * prtpccall - print procedure continuation call. - */ -static void prtpccall(outer) -int outer; - { - int first_arg; - int optim; /* optimized interface: no arg list adjustment */ - - first_arg = cur_proc->tnd_loc + num_tmp; - optim = glookup(cur_proc->name)->flag & F_SmplInv; - - /* - * The only signal to be handled in this procedure is - * resumption, the rest must be passed on. - */ - if (cur_proc->nargs != 0 && optim && !outer) { - fprintf(codefile, " {\n"); - fprintf(codefile, " dptr r_argp_sav;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_argp_sav = glbl_argp;\n"); - } - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) strace();\n"); - } - fprintf(codefile, " pfp = "); - frame(outer); - fprintf(codefile, ".old_pfp;\n"); - fprintf(codefile, " glbl_argp = "); - frame(outer); - fprintf(codefile, ".old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = "); - frame(outer); - fprintf(codefile, ".debug.old_line;\n"); - fprintf(codefile, " file_name = "); - frame(outer); - fprintf(codefile , ".debug.old_fname;\n"); - } - fprintf(codefile, " r_signal = (*"); - if (outer) - fprintf(codefile, "r_s_cont)();\n"); - else - fprintf(codefile, "r_pfp->succ_cont)();\n"); - fprintf(codefile, " if (r_signal != A_Resume) {\n"); - if (outer) - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " pfp = (struct p_frame *)&"); - frame(outer); - fprintf(codefile, ";\n"); - if (cur_proc->nargs == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else { - if (optim) { - if (outer) - fprintf(codefile, " glbl_argp = r_args;\n"); - else - fprintf(codefile, " glbl_argp = r_argp_sav;\n"); - } - else { - fprintf(codefile, " glbl_argp = &"); - if (outer) - fprintf(codefile, "r_frame."); - else - fprintf(codefile, "r_pfp->"); - fprintf(codefile, "tend.d[%d];\n", first_arg); - } - } - if (debug_info) { - fprintf(codefile, " if (k_trace) atrace();\n"); - fprintf(codefile, " ++k_level;\n"); - } - if (cur_proc->nargs != 0 && optim && !outer) - fprintf(codefile, " }\n"); - } - -/* - * smpl_clsg - print call and signal handling code, but nothing fancy. - */ -static void smpl_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa; - - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - if (call->Flags & ForeignSig) - chkforgn(outer); - fprintf(codefile, " switch (r_signal) {\n"); - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - fprintf(codefile, " case "); - prt_cond(sa->sig); - fprintf(codefile, ":\n "); - prtcode(sa->cd, outer); - } - fprintf(codefile, " }\n"); - } - -/* - * chkforgn - produce code to see if the current signal belongs to a - * procedure higher up the call chain and pass it along if it does. - */ -static void chkforgn(outer) -int outer; - { - fprintf(codefile, " if (pfp != (struct p_frame *)"); - if (outer) { - fprintf(codefile, "&r_frame) {\n"); - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - } - else - fprintf(codefile, "r_pfp) {\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - } - -/* - * good_clsg - print call and signal handling code and do a good job. - */ -static void good_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa, *sa1, *nxt_sa; - int ncases; /* the number of cases - each may have multiple case labels */ - int ncaselbl; /* the number of case labels */ - int nbreak; /* the number of cases that just break out of the switch */ - int nretsig; /* the number of cases that just pass along signal */ - int sig_var; - int dflt; - struct code *cond; - struct code *then_cd; - - /* - * Decide whether to use "break;", "return r_signal;", or nothing as - * the default case. - */ - nretsig = 0; - nbreak = 0; - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) { - /* - * The action returns the same signal detected by this case. - */ - ++nretsig; - } - else if (sa->cd->cd_id == C_Break) { - cond = sa->sig; /* if there is only one break, we may want this */ - ++nbreak; - } - } - dflt = DfltNone; - ncases = 0; - if (nbreak > 0 && nbreak >= nretsig) { - /* - * There are at least as many "break;"s as "return r_signal;"s, so - * use "break;" for default clause. - */ - dflt = DfltBrk; - ncases = 1; - } - else if (nretsig > 1) { - /* - * There is more than one case that returns the same signal it - * detects and there are more of them than "break;"s, to make - * "return r_signal;" the default clause. - */ - dflt = DfltRetSig; - ncases = 1; - } - - /* - * Gather case labels together for each case, ignoring cases that - * fall under the default. This involves constructing a new - * improved call->SigActs list. - */ - ncaselbl = ncases; - sa = call->SigActs; - call->SigActs = NULL; - for ( ; sa != NULL; sa = nxt_sa) { - nxt_sa = sa->next; - /* - * See if we have already found a case with the same action. - */ - sa1 = call->SigActs; - switch (sa->cd->cd_id) { - case C_Break: - if (dflt == DfltBrk) - continue; - while (sa1 != NULL && sa1->cd->cd_id != C_Break) - sa1 = sa1->next; - break; - case C_RetSig: - if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig) - continue; - while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig || - sa1->cd->SigRef->sig != sa->cd->SigRef->sig)) - sa1 = sa1->next; - break; - default: /* C_Goto */ - while (sa1 != NULL && (sa1->cd->cd_id != C_Goto || - sa1->cd->Lbl != sa->cd->Lbl)) - sa1 = sa1->next; - break; - } - ++ncaselbl; - if (sa1 == NULL) { - /* - * First time we have seen this action, create a new case. - */ - ++ncases; - sa->next = call->SigActs; - call->SigActs = sa; - } - else { - /* - * We can share the action of another case label. - */ - sa->shar_act = sa1->shar_act; - sa1->shar_act = sa; - } - } - - /* - * If we might receive a "foreign" signal that belongs to a procedure - * further down the call chain, put the signal in "r_signal" then - * check for this condition. - */ - sig_var = 0; - if (call->Flags & ForeignSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - chkforgn(outer); - sig_var = 1; - } - - /* - * Determine the best way to handle the signal returned from the call. - */ - if (ncases == 0) { - /* - * Any further signal checking has been optimized away. Execution - * just falls through to subsequent code. If the call has not - * been done, do it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else if (ncases == 1) { - if (dflt == DfltRetSig || ncaselbl == nretsig) { - /* - * All this call does is pass the signal on. See if we have - * done the call yet. - */ - if (sig_var) - fprintf(codefile, " return r_signal;"); - else { - fprintf(codefile, " return "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else { - /* - * We know what to do without looking at the signal. Make sure - * we have done the call. If the action is not simply "break" - * out signal checking, execute it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - if (dflt != DfltBrk) - prtcode(call->SigActs->cd, outer); - } - } - else { - /* - * We have at least two cases. If we have a default action of returning - * the signal without looking at it, make sure it is in "r_signal". - */ - if (!sig_var && dflt == DfltRetSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - sig_var = 1; - } - - if (ncaselbl == 2) { - /* - * We can use an if statement. If we need the signal in "r_signal", - * it is already there. - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - - cond = call->SigActs->sig; - then_cd = call->SigActs->cd; - - /* - * If the "then" clause is a no-op ("break;" from a switch), - * prepare to eliminate it by reversing the test in the - * condition. - */ - if (then_cd->cd_id == C_Break) - fprintf(codefile, " != "); - else - fprintf(codefile, " == "); - - prt_cond(cond); - fprintf(codefile, ")\n "); - - if (then_cd->cd_id == C_Break) { - /* - * We have reversed the test, so we need to use the default - * code. However, because a "break;" exists and it is not - * default, "return r_signal;" must be the default. - */ - fprintf(codefile, " return r_signal;\n"); - } - else { - /* - * Print the "then" clause and determine what the "else" clause - * is. - */ - prtcode(then_cd, outer); - if (call->SigActs->next != NULL) { - fprintf(codefile, " else\n "); - prtcode(call->SigActs->next->cd, outer); - } - else if (dflt == DfltRetSig) { - fprintf(codefile, " else\n"); - fprintf(codefile, " return r_signal;\n"); - } - } - } - else if (ncases == 2 && nbreak == 1) { - /* - * We can use an if-then statement with a negated test. Note, - * the non-break case is not "return r_signal" or we would have - * ncaselbl = 2, making the last test true. This also means that - * break is the default (the break condition was saved). - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, " != "); - prt_cond(cond); - fprintf(codefile, ") {\n "); - prtcode(call->SigActs->cd, outer); - fprintf(codefile, " }\n"); - } - else { - /* - * We must use a full case statement. If we need the signal in - * "r_signal", it is already there. - */ - fprintf(codefile, " switch ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, ") {\n"); - - /* - * Print the cases - */ - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) { - fprintf(codefile, " case "); - prt_cond(sa1->sig); - fprintf(codefile, ":\n"); - } - fprintf(codefile, " "); - prtcode(sa->cd, outer); - } - - /* - * If we have a default action and it is not break, print it. - */ - if (dflt == DfltRetSig) { - fprintf(codefile, " default:\n"); - fprintf(codefile, " return r_signal;\n"); - } - - fprintf(codefile, " }\n"); - } - } - } - -/* - * prtcall - print call. - */ -static void prtcall(call, outer) -struct code *call; -int outer; - { - /* - * Either the operation or the continuation may be missing, but not - * both. - */ - if (call->OperName == NULL) { - prt_cont(call->Cont); - fprintf(codefile, "()"); - } - else { - fprintf(codefile, "%s(", call->OperName); - if (call->ArgLst != NULL) - prt_ary(call->ArgLst, outer); - if (call->Cont == NULL) { - if (call->Flags & NeedCont) { - /* - * The operation requires a continuation argument even though - * this call does not include one, pass the NULL pointer. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - fprintf(codefile, "(continuation)NULL"); - } - } - else { - /* - * Pass the success continuation. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - prt_cont(call->Cont); - } - fprintf(codefile, ")"); - } - } - -/* - * prt_cont - print the name of a continuation. - */ -static void prt_cont(cont) -struct c_fnc *cont; - { - struct code *sig; - - if (cont->flag & CF_SigOnly) { - /* - * This continuation only returns a signal. All continuations - * returning the same signal are implemented by the same C function. - */ - sig = cont->cd.next->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, "sig_rsm"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, "sig_%d", sig->SeqNum); - } - } - else { - /* - * Regular continuation. - */ - ChkPrefix(cont->prefix); - fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name); - } - } - -/* - * val_loc - output code referencing a value location (usually variable of - * some sort). - */ -static void val_loc(loc, outer) -struct val_loc *loc; -int outer; - { - /* - * See if we need to cast a block pointer to a specific block type - * or if we need to take the address of a location. - */ - if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL) - fprintf(codefile, "(*(struct %s **)&", loc->blk_name); - if (loc->mod_access == M_Addr) - fprintf(codefile, "(&"); - - switch (loc->loc_type) { - case V_Ignore: - fprintf(codefile, "trashcan"); - break; - case V_Temp: - /* - * Temporary descriptor variable. - */ - frame(outer); - fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp); - break; - case V_ITemp: - /* - * Temporary C integer variable. - */ - frame(outer); - fprintf(codefile, ".i%d", loc->u.tmp); - break; - case V_DTemp: - /* - * Temporary C double variable. - */ - frame(outer); - fprintf(codefile, ".d%d", loc->u.tmp); - break; - case V_Const: - /* - * Integer constant (used for size of variable part of arg list). - */ - fprintf(codefile, "%d", loc->u.int_const); - break; - case V_NamedVar: - /* - * Icon named variable. - */ - prt_var(loc->u.nvar, outer); - break; - case V_CVar: - /* - * C variable from in-line code. - */ - fprintf(codefile, "%s", loc->u.name); - break; - case V_PRslt: - /* - * Procedure result location. - */ - if (!outer) - fprintf(codefile, "(*r_pfp->rslt)"); - else - fprintf(codefile, "(*r_rslt)"); - break; - } - - /* - * See if we are accessing the vword of a descriptor. - */ - switch (loc->mod_access) { - case M_CharPtr: - fprintf(codefile, ".vword.sptr"); - break; - case M_BlkPtr: - fprintf(codefile, ".vword.bptr"); - if (loc->blk_name != NULL) - fprintf(codefile, ")"); - break; - case M_CInt: - fprintf(codefile, ".vword.integr"); - break; - case M_Addr: - fprintf(codefile, ")"); - break; - } - } - -/* - * prt_cond - print a condition (signal number). - */ -static void prt_cond(cond) -struct code *cond; - { - if (cond == &resume) - fprintf(codefile, "A_Resume"); - else if (cond == &contin) - fprintf(codefile, "A_Continue"); - else if (cond == &fallthru) - fprintf(codefile, "A_FallThru"); - else { - cond = ChkBound(cond); - ChkSeqNum(cond); - fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc); - } - } - -/* - * initpblk - write a procedure block along with initialization up to the - * the array of qualifiers. - */ -static void initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic, - frststat) -FILE *f; /* output file */ -int c; /* distinguishes procedures, functions, record constructors */ -char* prefix; /* prefix for name */ -char *name; /* name of routine */ -int nquals; /* number of qualifiers at end of block */ -int nparam; /* number of parameters */ -int ndynam; /* number of dynamic locals or function/record indicator */ -int nstatic; /* number of static locals or record number */ -int frststat; /* index into static array of first static local */ - { - fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name); - fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c, - prefix, name, nparam, ndynam, nstatic, frststat); - } - diff --git a/src/iconc/cparse.c b/src/iconc/cparse.c deleted file mode 100644 index b29986d..0000000 --- a/src/iconc/cparse.c +++ /dev/null @@ -1,1940 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 - -# line 145 "cgram.g" -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#undef YYSTYPE -#define YYSTYPE nodeptr -#define YYMAXDEPTH 500 - -int idflag; - - - -#define yyclearin yychar = -1 -#define yyerrok yyerrflag = 0 -extern int yychar; -extern int yyerrflag; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -#ifndef YYSTYPE -#define YYSTYPE int -#endif -YYSTYPE yylval, yyval; -# define YYERRCODE 256 - -# line 441 "cgram.g" - - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ - -static void xfree(p) -char *p; -{ - free(p); -} - -#define free(p) xfree((char*)p) -int yyexca[] ={ --1, 0, - 262, 2, - 273, 2, - 276, 2, - 277, 2, - 282, 2, - 283, 2, - -2, 0, --1, 1, - 0, -1, - -2, 0, --1, 20, - 270, 40, - 363, 42, - -2, 0, --1, 86, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 87, - 358, 42, - 360, 42, - -2, 0, --1, 88, - 363, 42, - 367, 42, - -2, 0, --1, 89, - 360, 42, - 365, 42, - -2, 0, --1, 96, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 97, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 111, - 270, 40, - 363, 42, - -2, 0, --1, 117, - 270, 40, - 363, 42, - -2, 0, --1, 182, - 360, 42, - 365, 42, - -2, 0, --1, 183, - 360, 42, - -2, 0, --1, 184, - 358, 42, - 360, 42, - -2, 0, --1, 311, - 358, 42, - 360, 42, - 365, 42, - -2, 0, --1, 313, - 363, 42, - 367, 42, - -2, 0, --1, 335, - 360, 42, - 367, 42, - -2, 0, - }; -# define YYNPROD 203 -# define YYLAST 728 -int yyact[]={ - - 38, 84, 91, 92, 93, 94, 312, 86, 185, 99, - 83, 118, 335, 359, 341, 102, 95, 358, 98, 334, - 311, 311, 355, 85, 51, 329, 314, 20, 103, 96, - 118, 97, 313, 228, 101, 100, 56, 346, 118, 90, - 118, 59, 117, 62, 360, 58, 108, 70, 336, 64, - 311, 57, 228, 55, 60, 326, 184, 228, 310, 119, - 311, 107, 106, 182, 345, 183, 324, 232, 65, 110, - 67, 168, 69, 169, 352, 214, 118, 350, 328, 177, - 41, 356, 71, 174, 50, 175, 73, 61, 325, 52, - 53, 320, 54, 316, 63, 66, 176, 68, 327, 72, - 118, 87, 332, 118, 333, 331, 319, 361, 89, 116, - 88, 305, 38, 84, 91, 92, 93, 94, 118, 86, - 181, 99, 83, 353, 317, 231, 3, 102, 95, 218, - 98, 318, 105, 118, 19, 85, 51, 315, 118, 28, - 103, 96, 29, 97, 217, 321, 101, 100, 56, 309, - 170, 90, 172, 59, 173, 62, 171, 58, 118, 70, - 30, 64, 18, 57, 118, 55, 60, 44, 180, 37, - 179, 178, 113, 24, 104, 114, 25, 330, 351, 306, - 65, 212, 67, 115, 69, 82, 2, 81, 80, 27, - 17, 36, 23, 79, 71, 78, 50, 77, 73, 61, - 76, 52, 53, 75, 54, 74, 63, 66, 49, 68, - 47, 72, 42, 87, 38, 84, 91, 92, 93, 94, - 89, 86, 88, 99, 83, 40, 112, 322, 109, 102, - 95, 34, 98, 273, 274, 111, 33, 85, 51, 12, - 233, 32, 103, 96, 21, 97, 22, 26, 101, 100, - 56, 10, 9, 90, 8, 59, 7, 62, 31, 58, - 6, 70, 5, 64, 1, 57, 0, 55, 60, 13, - 0, 216, 15, 14, 0, 210, 0, 0, 16, 11, - 0, 0, 65, 0, 67, 234, 69, 236, 239, 221, - 222, 223, 224, 225, 226, 227, 71, 230, 50, 229, - 73, 61, 0, 52, 53, 237, 54, 0, 63, 66, - 0, 68, 0, 72, 0, 87, 46, 84, 91, 92, - 93, 94, 89, 86, 88, 99, 83, 45, 0, 0, - 0, 102, 95, 0, 98, 0, 289, 290, 0, 85, - 51, 0, 0, 235, 103, 96, 0, 97, 0, 238, - 101, 100, 56, 0, 0, 90, 0, 59, 0, 62, - 0, 58, 4, 70, 303, 64, 308, 57, 0, 55, - 60, 0, 0, 13, 304, 0, 15, 14, 0, 0, - 0, 0, 16, 11, 65, 0, 67, 0, 69, 338, - 0, 213, 0, 0, 0, 0, 0, 0, 71, 43, - 50, 0, 73, 61, 0, 52, 53, 323, 54, 347, - 63, 66, 35, 68, 152, 72, 0, 87, 0, 133, - 0, 150, 0, 130, 89, 131, 88, 128, 0, 127, - 0, 129, 0, 126, 362, 0, 132, 121, 120, 0, - 140, 123, 122, 0, 147, 164, 146, 0, 139, 158, - 135, 157, 143, 163, 136, 160, 138, 154, 137, 166, - 145, 162, 144, 161, 149, 156, 151, 155, 0, 134, - 0, 0, 124, 0, 125, 0, 153, 141, 211, 148, - 215, 142, 165, 39, 159, 0, 167, 0, 219, 220, - 0, 295, 296, 297, 298, 299, 0, 0, 291, 292, - 293, 294, 0, 35, 0, 0, 0, 339, 340, 35, - 342, 343, 344, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 348, 0, 0, 0, 48, 0, 0, 0, - 0, 0, 0, 354, 0, 0, 0, 0, 0, 0, - 0, 0, 357, 0, 0, 0, 0, 0, 0, 0, - 0, 354, 363, 364, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, 285, 286, 287, 288, 0, 0, - 0, 0, 0, 0, 0, 307, 0, 186, 187, 188, - 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, - 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, - 209, 0, 0, 240, 241, 242, 243, 244, 245, 246, - 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, - 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, - 267, 268, 269, 270, 271, 272, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 337, 0, 215, 300, 301, 302, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 349 }; -int yypact[]={ - - -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000, - -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316, - -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000, - 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42, - -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42, - -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290, - -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000, - -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000, - -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275, - -275, -275, -275, -275, -275, -275, -275, -275, -275, -151, - -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000, - -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42, - -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000, - -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219, - -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000, - -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144, - -42, -42, -1000, -219, -219 }; -int yypgo[]={ - - 0, 264, 186, 262, 260, 256, 254, 252, 251, 247, - 189, 246, 192, 244, 174, 241, 240, 239, 236, 235, - 231, 228, 227, 226, 191, 391, 169, 483, 225, 80, - 212, 399, 167, 327, 316, 210, 526, 208, 205, 203, - 200, 197, 195, 193, 188, 187, 185, 181, 75, 179, - 178, 74, 177 }; -int yyr1[]={ - - 0, 1, 2, 2, 3, 3, 3, 3, 3, 8, - 9, 9, 10, 10, 10, 7, 11, 11, 12, 12, - 13, 6, 15, 4, 16, 16, 5, 21, 17, 22, - 22, 22, 14, 14, 18, 18, 23, 23, 19, 19, - 20, 20, 25, 25, 24, 24, 26, 26, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 28, 28, 28, 29, 29, 30, 30, 30, 30, - 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, - 30, 31, 31, 31, 32, 32, 32, 32, 32, 33, - 33, 33, 33, 33, 34, 34, 35, 35, 35, 35, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 43, 43, - 44, 44, 45, 45, 46, 40, 40, 40, 40, 41, - 41, 42, 50, 50, 51, 51, 47, 47, 49, 49, - 38, 38, 38, 38, 39, 52, 52, 52, 48, 48, - 1, 5, 24 }; -int yyr2[]={ - - 0, 5, 0, 4, 3, 3, 3, 3, 3, 5, - 2, 7, 3, 3, 7, 5, 2, 7, 3, 3, - 1, 7, 1, 13, 1, 3, 13, 1, 13, 1, - 3, 7, 3, 7, 1, 9, 3, 3, 1, 7, - 1, 7, 1, 2, 2, 7, 2, 7, 2, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 11, 2, 7, 2, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 7, 2, 7, 7, 7, 7, 2, - 7, 7, 7, 7, 2, 7, 2, 7, 7, 7, - 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 5, 3, 3, 5, 7, 7, - 7, 9, 7, 9, 9, 7, 5, 5, 5, 9, - 5, 9, 5, 9, 5, 3, 5, 5, 9, 9, - 13, 13, 2, 7, 7, 7, 3, 7, 3, 7, - 3, 3, 3, 3, 13, 3, 3, 3, 2, 7, - 6, 8, 2 }; -int yychk[]={ - - -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7, - -8, 283, -17, 273, 277, 276, 282, -2, 257, 363, - 256, -13, -11, -12, 257, 260, -9, -10, 257, 260, - 257, 262, -15, -18, -20, -25, -24, -26, 256, -27, - -28, -29, -30, -31, -32, -33, -34, -35, -36, -37, - 340, 280, 345, 346, 348, 309, 292, 307, 301, 297, - 310, 343, 299, 350, 305, 324, 351, 326, 353, 328, - 303, 338, 355, 342, -38, -39, -40, -41, -42, -43, - -44, -45, -46, 266, 257, 279, 263, 357, 366, 364, - 295, 258, 259, 260, 261, 272, 285, 287, 274, 265, - 291, 290, 271, 284, -14, 257, 360, 360, 362, -21, - 357, -19, -23, 275, 278, 286, 270, 363, 295, 338, - 313, 312, 317, 316, 347, 349, 308, 304, 302, 306, - 298, 300, 311, 294, 344, 325, 329, 333, 331, 323, - 315, 352, 356, 327, 337, 335, 321, 319, 354, 339, - 296, 341, 289, 345, 326, 336, 334, 320, 318, 353, - 324, 332, 330, 322, 314, 351, 328, 355, 346, 348, - 301, 307, 303, 305, 297, 299, 310, 293, 343, 342, - 340, 292, 364, 366, 357, 309, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -24, -25, -47, -25, -48, -25, -47, 272, 257, -25, - -25, -24, -24, -24, -24, -24, -24, -24, 360, -12, - -10, 258, 357, -16, -14, -20, -14, -24, -20, -26, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -29, -29, -31, -31, -31, -31, -31, - -31, -31, -31, -31, -31, -31, -31, -31, -31, -32, - -32, -33, -33, -33, -33, -34, -34, -34, -34, -34, - -36, -36, -36, -47, -24, 367, -49, -25, -47, 257, - 358, 360, 367, 363, 365, 268, 288, 281, 268, 268, - 268, 257, -22, -14, 358, 270, 363, 363, 264, 365, - -52, 362, 359, 361, 367, 360, 358, -25, -48, -24, - -24, 366, -24, -24, -24, 358, 364, -29, -24, -25, - 269, -50, -51, 267, -24, 365, 365, -24, 367, 363, - 362, 362, -51, -24, -24 }; -int yydef[]={ - - -2, -2, 0, 2, 1, 3, 4, 5, 6, 7, - 8, 0, 0, 20, 0, 0, 0, 0, 22, 34, - -2, 0, 15, 16, 18, 19, 9, 10, 12, 13, - 27, 200, 0, 38, 0, 0, 43, 44, 202, 46, - 48, 81, 84, 86, 101, 104, 109, 114, 116, 120, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 145, 146, 147, 148, 149, 150, - 151, 152, 153, 0, 155, 156, -2, -2, -2, -2, - 0, 190, 191, 192, 193, 175, -2, -2, 0, 0, - 0, 0, 0, 0, 21, 32, 0, 0, 0, 0, - 24, -2, 0, 0, 36, 37, 201, -2, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, -2, -2, -2, 0, 121, 122, 123, 124, - 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, - 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, - 154, 157, 0, 186, 0, 198, 0, 166, 167, 176, - 177, 43, 0, 0, 168, 170, 172, 174, 0, 17, - 11, 14, 29, 0, 25, 0, 0, 0, 41, 45, - 47, 49, 50, 51, 52, 53, 54, 55, 56, 57, - 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, - 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, - 78, 79, 80, 82, 85, 87, 88, 89, 90, 91, - 92, 93, 94, 95, 96, 97, 98, 99, 100, 102, - 103, 105, 106, 107, 108, 110, 111, 112, 113, 115, - 117, 118, 119, 0, 43, 162, 0, 188, 0, 165, - 158, -2, 159, -2, 160, 0, 0, 0, 0, 0, - 0, 33, 0, 30, 23, 26, 35, 39, 0, 161, - 0, 195, 196, 197, 163, -2, 164, 187, 199, 178, - 179, 0, 169, 171, 173, 28, 0, 83, 0, 189, - 0, 0, 182, 0, 0, 31, 194, 180, 181, 0, - 0, 0, 183, 184, 185 }; -typedef struct { char *t_name; int t_val; } yytoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -yytoktype yytoks[] = -{ - "IDENT", 257, - "INTLIT", 258, - "REALLIT", 259, - "STRINGLIT", 260, - "CSETLIT", 261, - "EOFX", 262, - "BREAK", 263, - "BY", 264, - "CASE", 265, - "CREATE", 266, - "DEFAULT", 267, - "DO", 268, - "ELSE", 269, - "END", 270, - "EVERY", 271, - "FAIL", 272, - "GLOBAL", 273, - "IF", 274, - "INITIAL", 275, - "INVOCABLE", 276, - "LINK", 277, - "LOCAL", 278, - "NEXT", 279, - "NOT", 280, - "OF", 281, - "PROCEDURE", 282, - "RECORD", 283, - "REPEAT", 284, - "RETURN", 285, - "STATIC", 286, - "SUSPEND", 287, - "THEN", 288, - "TO", 289, - "UNTIL", 290, - "WHILE", 291, - "BANG", 292, - "MOD", 293, - "AUGMOD", 294, - "AND", 295, - "AUGAND", 296, - "STAR", 297, - "AUGSTAR", 298, - "INTER", 299, - "AUGINTER", 300, - "PLUS", 301, - "AUGPLUS", 302, - "UNION", 303, - "AUGUNION", 304, - "MINUS", 305, - "AUGMINUS", 306, - "DIFF", 307, - "AUGDIFF", 308, - "DOT", 309, - "SLASH", 310, - "AUGSLASH", 311, - "ASSIGN", 312, - "SWAP", 313, - "NMLT", 314, - "AUGNMLT", 315, - "REVASSIGN", 316, - "REVSWAP", 317, - "SLT", 318, - "AUGSLT", 319, - "SLE", 320, - "AUGSLE", 321, - "NMLE", 322, - "AUGNMLE", 323, - "NMEQ", 324, - "AUGNMEQ", 325, - "SEQ", 326, - "AUGSEQ", 327, - "EQUIV", 328, - "AUGEQUIV", 329, - "NMGT", 330, - "AUGNMGT", 331, - "NMGE", 332, - "AUGNMGE", 333, - "SGT", 334, - "AUGSGT", 335, - "SGE", 336, - "AUGSGE", 337, - "QMARK", 338, - "AUGQMARK", 339, - "AT", 340, - "AUGAT", 341, - "BACKSLASH", 342, - "CARET", 343, - "AUGCARET", 344, - "BAR", 345, - "CONCAT", 346, - "AUGCONCAT", 347, - "LCONCAT", 348, - "AUGLCONCAT", 349, - "TILDE", 350, - "NMNE", 351, - "AUGNMNE", 352, - "SNE", 353, - "AUGSNE", 354, - "NEQUIV", 355, - "AUGNEQUIV", 356, - "LPAREN", 357, - "RPAREN", 358, - "PCOLON", 359, - "COMMA", 360, - "MCOLON", 361, - "COLON", 362, - "SEMICOL", 363, - "LBRACK", 364, - "RBRACK", 365, - "LBRACE", 366, - "RBRACE", 367, - "-unknown-", -1 /* ends search */ -}; - -char * yyreds[] = -{ - "-no such reduction-", - "program : decls EOFX", - "decls : /* empty */", - "decls : decls decl", - "decl : record", - "decl : proc", - "decl : global", - "decl : link", - "decl : invocable", - "invocable : INVOCABLE invoclist", - "invoclist : invocop", - "invoclist : invoclist COMMA invocop", - "invocop : IDENT", - "invocop : STRINGLIT", - "invocop : STRINGLIT COLON INTLIT", - "link : LINK lnklist", - "lnklist : lnkfile", - "lnklist : lnklist COMMA lnkfile", - "lnkfile : IDENT", - "lnkfile : STRINGLIT", - "global : GLOBAL", - "global : GLOBAL idlist", - "record : RECORD IDENT", - "record : RECORD IDENT LPAREN fldlist RPAREN", - "fldlist : /* empty */", - "fldlist : idlist", - "proc : prochead SEMICOL locals initial procbody END", - "prochead : PROCEDURE IDENT", - "prochead : PROCEDURE IDENT LPAREN arglist RPAREN", - "arglist : /* empty */", - "arglist : idlist", - "arglist : idlist LBRACK RBRACK", - "idlist : IDENT", - "idlist : idlist COMMA IDENT", - "locals : /* empty */", - "locals : locals retention idlist SEMICOL", - "retention : LOCAL", - "retention : STATIC", - "initial : /* empty */", - "initial : INITIAL expr SEMICOL", - "procbody : /* empty */", - "procbody : nexpr SEMICOL procbody", - "nexpr : /* empty */", - "nexpr : expr", - "expr : expr1a", - "expr : expr AND expr1a", - "expr1a : expr1", - "expr1a : expr1a QMARK expr1", - "expr1 : expr2", - "expr1 : expr2 SWAP expr1", - "expr1 : expr2 ASSIGN expr1", - "expr1 : expr2 REVSWAP expr1", - "expr1 : expr2 REVASSIGN expr1", - "expr1 : expr2 AUGCONCAT expr1", - "expr1 : expr2 AUGLCONCAT expr1", - "expr1 : expr2 AUGDIFF expr1", - "expr1 : expr2 AUGUNION expr1", - "expr1 : expr2 AUGPLUS expr1", - "expr1 : expr2 AUGMINUS expr1", - "expr1 : expr2 AUGSTAR expr1", - "expr1 : expr2 AUGINTER expr1", - "expr1 : expr2 AUGSLASH expr1", - "expr1 : expr2 AUGMOD expr1", - "expr1 : expr2 AUGCARET expr1", - "expr1 : expr2 AUGNMEQ expr1", - "expr1 : expr2 AUGEQUIV expr1", - "expr1 : expr2 AUGNMGE expr1", - "expr1 : expr2 AUGNMGT expr1", - "expr1 : expr2 AUGNMLE expr1", - "expr1 : expr2 AUGNMLT expr1", - "expr1 : expr2 AUGNMNE expr1", - "expr1 : expr2 AUGNEQUIV expr1", - "expr1 : expr2 AUGSEQ expr1", - "expr1 : expr2 AUGSGE expr1", - "expr1 : expr2 AUGSGT expr1", - "expr1 : expr2 AUGSLE expr1", - "expr1 : expr2 AUGSLT expr1", - "expr1 : expr2 AUGSNE expr1", - "expr1 : expr2 AUGQMARK expr1", - "expr1 : expr2 AUGAND expr1", - "expr1 : expr2 AUGAT expr1", - "expr2 : expr3", - "expr2 : expr2 TO expr3", - "expr2 : expr2 TO expr3 BY expr3", - "expr3 : expr4", - "expr3 : expr4 BAR expr3", - "expr4 : expr5", - "expr4 : expr4 SEQ expr5", - "expr4 : expr4 SGE expr5", - "expr4 : expr4 SGT expr5", - "expr4 : expr4 SLE expr5", - "expr4 : expr4 SLT expr5", - "expr4 : expr4 SNE expr5", - "expr4 : expr4 NMEQ expr5", - "expr4 : expr4 NMGE expr5", - "expr4 : expr4 NMGT expr5", - "expr4 : expr4 NMLE expr5", - "expr4 : expr4 NMLT expr5", - "expr4 : expr4 NMNE expr5", - "expr4 : expr4 EQUIV expr5", - "expr4 : expr4 NEQUIV expr5", - "expr5 : expr6", - "expr5 : expr5 CONCAT expr6", - "expr5 : expr5 LCONCAT expr6", - "expr6 : expr7", - "expr6 : expr6 PLUS expr7", - "expr6 : expr6 DIFF expr7", - "expr6 : expr6 UNION expr7", - "expr6 : expr6 MINUS expr7", - "expr7 : expr8", - "expr7 : expr7 STAR expr8", - "expr7 : expr7 INTER expr8", - "expr7 : expr7 SLASH expr8", - "expr7 : expr7 MOD expr8", - "expr8 : expr9", - "expr8 : expr9 CARET expr8", - "expr9 : expr10", - "expr9 : expr9 BACKSLASH expr10", - "expr9 : expr9 AT expr10", - "expr9 : expr9 BANG expr10", - "expr10 : expr11", - "expr10 : AT expr10", - "expr10 : NOT expr10", - "expr10 : BAR expr10", - "expr10 : CONCAT expr10", - "expr10 : LCONCAT expr10", - "expr10 : DOT expr10", - "expr10 : BANG expr10", - "expr10 : DIFF expr10", - "expr10 : PLUS expr10", - "expr10 : STAR expr10", - "expr10 : SLASH expr10", - "expr10 : CARET expr10", - "expr10 : INTER expr10", - "expr10 : TILDE expr10", - "expr10 : MINUS expr10", - "expr10 : NMEQ expr10", - "expr10 : NMNE expr10", - "expr10 : SEQ expr10", - "expr10 : SNE expr10", - "expr10 : EQUIV expr10", - "expr10 : UNION expr10", - "expr10 : QMARK expr10", - "expr10 : NEQUIV expr10", - "expr10 : BACKSLASH expr10", - "expr11 : literal", - "expr11 : section", - "expr11 : return", - "expr11 : if", - "expr11 : case", - "expr11 : while", - "expr11 : until", - "expr11 : every", - "expr11 : repeat", - "expr11 : CREATE expr", - "expr11 : IDENT", - "expr11 : NEXT", - "expr11 : BREAK nexpr", - "expr11 : LPAREN exprlist RPAREN", - "expr11 : LBRACE compound RBRACE", - "expr11 : LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACE RBRACE", - "expr11 : expr11 LBRACE pdcolist RBRACE", - "expr11 : expr11 LPAREN exprlist RPAREN", - "expr11 : expr11 DOT IDENT", - "expr11 : AND FAIL", - "expr11 : AND IDENT", - "while : WHILE expr", - "while : WHILE expr DO expr", - "until : UNTIL expr", - "until : UNTIL expr DO expr", - "every : EVERY expr", - "every : EVERY expr DO expr", - "repeat : REPEAT expr", - "return : FAIL", - "return : RETURN nexpr", - "return : SUSPEND nexpr", - "return : SUSPEND expr DO expr", - "if : IF expr THEN expr", - "if : IF expr THEN expr ELSE expr", - "case : CASE expr OF LBRACE caselist RBRACE", - "caselist : cclause", - "caselist : caselist SEMICOL cclause", - "cclause : DEFAULT COLON expr", - "cclause : expr COLON expr", - "exprlist : nexpr", - "exprlist : exprlist COMMA nexpr", - "pdcolist : nexpr", - "pdcolist : pdcolist COMMA nexpr", - "literal : INTLIT", - "literal : REALLIT", - "literal : STRINGLIT", - "literal : CSETLIT", - "section : expr11 LBRACK expr sectop expr RBRACK", - "sectop : COLON", - "sectop : PCOLON", - "sectop : MCOLON", - "compound : nexpr", - "compound : nexpr SEMICOL compound", - "program : error decls EOFX", - "proc : prochead error procbody END", - "expr : error", -}; -#endif -#line 1 "/usr/lib/yaccpar" -/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto yyerrlab -#define YYACCEPT { free(yys); free(yyv); return(0); } -#define YYABORT { free(yys); free(yyv); return(1); } -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ - {\ - tsyserr("parser: syntax error - cannot backup" );\ - goto yyerrlab;\ - }\ - yychar = newtoken;\ - yystate = *yyps;\ - yylval = newvalue;\ - goto yynewstate;\ -} -#define YYRECOVERING() (!!yyerrflag) -#ifndef YYDEBUG -# define YYDEBUG 1 /* make debugging available */ -#endif - -/* -** user known globals -*/ -int yydebug; /* set to 1 to get debugging */ - -/* -** driver internal defines -*/ -#define YYFLAG (-1000) - -/* -** static variables used by the parser -*/ -static YYSTYPE *yyv; /* value stack */ -static int *yys; /* state stack */ - -static YYSTYPE *yypv; /* top of value stack */ -static int *yyps; /* top of state stack */ - -static int yystate; /* current state */ -static int yytmp; /* extra var (lasts between blocks) */ - -int yynerrs; /* number of errors */ - -int yyerrflag; /* error recovery flag */ -int yychar; /* current input token number */ - - -/* -** yyparse - return 0 if worked, 1 if syntax error not recovered from -*/ -int -yyparse() -{ - register YYSTYPE *yypvt; /* top of value stack for $vars */ - unsigned yymaxdepth = YYMAXDEPTH; - - /* - ** Initialize externals - yyparse may be called more than once - */ - yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); - yys = (int*)malloc(yymaxdepth*sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parser: out of memory" ); - return(1); - } - yypv = &yyv[-1]; - yyps = &yys[-1]; - yystate = 0; - yytmp = 0; - yynerrs = 0; - yyerrflag = 0; - yychar = -1; - - goto yystack; - { - register YYSTYPE *yy_pv; /* top of value stack */ - register int *yy_ps; /* top of state stack */ - register int yy_state; /* current state */ - register int yy_n; /* internal state number info */ - - /* - ** get globals into registers. - ** branch to here only if YYBACKUP was called. - */ - yynewstate: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - goto yy_newstate; - - /* - ** get globals into registers. - ** either we just started, or we just finished a reduction - */ - yystack: - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - - /* - ** top of for (;;) loop while no reductions done - */ - yy_stack: - /* - ** put a state and value onto the stacks - */ -#if YYDEBUG - /* - ** if debugging, look up token value in list of value vs. - ** name pairs. 0 and negative (-1) are special values. - ** Note: linear search is used since time is not a real - ** consideration while debugging. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "State %d, token ", yy_state ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int yyps_index = (yy_ps - yys); - int yypv_index = (yy_pv - yyv); - int yypvt_index = (yypvt - yyv); - yymaxdepth += YYMAXDEPTH; - yyv = (YYSTYPE*)realloc((char*)yyv, - yymaxdepth * sizeof(YYSTYPE)); - yys = (int*)realloc((char*)yys, - yymaxdepth * sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parse stack overflow" ); - return(1); - } - yy_ps = yys + yyps_index; - yy_pv = yyv + yypv_index; - yypvt = yyv + yypvt_index; - } - *yy_ps = yy_state; - *++yy_pv = yyval; - - /* - ** we have a new state - find out what to do - */ - yy_newstate: - if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) - goto yydefault; /* simple state */ -#if YYDEBUG - /* - ** if debugging, need to mark whether new token grabbed - */ - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) - goto yydefault; - if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ - { - yychar = -1; - yyval = yylval; - yy_state = yy_n; - if ( yyerrflag > 0 ) - yyerrflag--; - goto yy_stack; - } - - yydefault: - if ( ( yy_n = yydef[ yy_state ] ) == -2 ) - { -#if YYDEBUG - yytmp = yychar < 0; -#endif - if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) - yychar = 0; /* reached EOF */ -#if YYDEBUG - if ( yydebug && yytmp ) - { - register int yy_i; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - /* - ** look through exception table - */ - { - register int *yyxi = yyexca; - - while ( ( *yyxi != -1 ) || - ( yyxi[1] != yy_state ) ) - { - yyxi += 2; - } - while ( ( *(yyxi += 2) >= 0 ) && - ( *yyxi != yychar ) ) - ; - if ( ( yy_n = yyxi[1] ) < 0 ) - YYACCEPT; - } - } - - /* - ** check for syntax error - */ - if ( yy_n == 0 ) /* have an error */ - { - /* no worry about speed here! */ - switch ( yyerrflag ) - { - case 0: /* new error */ - yyerror(yychar, yylval, yy_state ); - goto skip_init; - yyerrlab: - /* - ** get globals into registers. - ** we have a user generated syntax type error - */ - yy_pv = yypv; - yy_ps = yyps; - yy_state = yystate; - yynerrs++; - skip_init: - case 1: - case 2: /* incompletely recovered error */ - /* try again... */ - yyerrflag = 3; - /* - ** find state where "error" is a legal - ** shift action - */ - while ( yy_ps >= yys ) - { - yy_n = yypact[ *yy_ps ] + YYERRCODE; - if ( yy_n >= 0 && yy_n < YYLAST && - yychk[yyact[yy_n]] == YYERRCODE) { - /* - ** simulate shift of "error" - */ - yy_state = yyact[ yy_n ]; - goto yy_stack; - } - /* - ** current state has no shift on - ** "error", pop stack - */ -#if YYDEBUG -# define _POP_ "Error recovery pops state %d, uncovers state %d\n" - if ( yydebug ) - (void)printf( _POP_, *yy_ps, - yy_ps[-1] ); -# undef _POP_ -#endif - yy_ps--; - yy_pv--; - } - /* - ** there is no state on stack with "error" as - ** a valid shift. give up. - */ - YYABORT; - case 3: /* no shift yet; eat a token */ -#if YYDEBUG - /* - ** if debugging, look up token in list of - ** pairs. 0 and negative shouldn't occur, - ** but since timing doesn't matter when - ** debugging, it doesn't hurt to leave the - ** tests here. - */ - if ( yydebug ) - { - register int yy_i; - - (void)printf( "Error recovery discards " ); - if ( yychar == 0 ) - (void)printf( "token end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "token -none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "token %s\n", - yytoks[yy_i].t_name ); - } - } -#endif - if ( yychar == 0 ) /* reached EOF. quit */ - YYABORT; - yychar = -1; - goto yy_newstate; - } - }/* end if ( yy_n == 0 ) */ - /* - ** reduction by production yy_n - ** put stack tops, etc. so things right after switch - */ -#if YYDEBUG - /* - ** if debugging, print the string that is the user's - ** specification of the reduction which is just about - ** to be done. - */ - if ( yydebug ) - (void)printf( "Reduce by (%d) \"%s\"\n", - yy_n, yyreds[ yy_n ] ); -#endif - yytmp = yy_n; /* value to switch over */ - yypvt = yy_pv; /* $vars top of value stack */ - /* - ** Look in goto table for next state - ** Sorry about using yy_state here as temporary - ** register variable, but why not, if it works... - ** If yyr2[ yy_n ] doesn't have the low order bit - ** set, then there is no action to be done for - ** this reduction. So, no saving & unsaving of - ** registers done. The only difference between the - ** code just after the if and the body of the if is - ** the goto yy_stack in the body. This way the test - ** can be made before the choice of what to do is needed. - */ - { - /* length of production doubled with extra bit */ - register int yy_len = yyr2[ yy_n ]; - - if ( !( yy_len & 01 ) ) - { - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = - yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - goto yy_stack; - } - yy_len >>= 1; - yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ - yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + - *( yy_ps -= yy_len ) + 1; - if ( yy_state >= YYLAST || - yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) - { - yy_state = yyact[ yypgo[ yy_n ] ]; - } - } - /* save until reenter driver code */ - yystate = yy_state; - yyps = yy_ps; - yypv = yy_pv; - } - /* - ** code supplied by user is placed in this switch - */ - switch( yytmp ) - { - -case 1: -# line 177 "cgram.g" -{;} break; -case 4: -# line 182 "cgram.g" -{;} break; -case 5: -# line 183 "cgram.g" -{proc_lst->tree = yypvt[-0] ;} break; -case 6: -# line 184 "cgram.g" -{;} break; -case 7: -# line 185 "cgram.g" -{;} break; -case 8: -# line 186 "cgram.g" -{;} break; -case 9: -# line 188 "cgram.g" -{;} break; -case 11: -# line 191 "cgram.g" -{;} break; -case 12: -# line 193 "cgram.g" -{invoc_grp(Str0(yypvt[-0])); ;} break; -case 13: -# line 194 "cgram.g" -{invocbl(yypvt[-0], -1); ;} break; -case 14: -# line 195 "cgram.g" -{invocbl(yypvt[-2], atoi(Str0(yypvt[-0]))); ;} break; -case 15: -# line 197 "cgram.g" -{;} break; -case 17: -# line 200 "cgram.g" -{;} break; -case 18: -# line 202 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 19: -# line 203 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 20: -# line 205 "cgram.g" -{idflag = F_Global ;} break; -case 21: -# line 205 "cgram.g" -{;} break; -case 22: -# line 207 "cgram.g" -{init_rec(Str0(yypvt[-0])); idflag = F_Field ;} break; -case 23: -# line 207 "cgram.g" -{ - ; - } break; -case 24: -# line 211 "cgram.g" -{;} break; -case 25: -# line 212 "cgram.g" -{;} break; -case 26: -# line 214 "cgram.g" -{ - yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]) ; - } break; -case 27: -# line 218 "cgram.g" -{init_proc(Str0(yypvt[-0])); idflag = F_Argument ;} break; -case 28: -# line 218 "cgram.g" -{ - ; - } break; -case 29: -# line 222 "cgram.g" -{;} break; -case 30: -# line 223 "cgram.g" -{;} break; -case 31: -# line 224 "cgram.g" -{proc_lst->nargs = -proc_lst->nargs ;} break; -case 32: -# line 227 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 33: -# line 230 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 34: -# line 234 "cgram.g" -{;} break; -case 35: -# line 235 "cgram.g" -{;} break; -case 36: -# line 237 "cgram.g" -{idflag = F_Dynamic ;} break; -case 37: -# line 238 "cgram.g" -{idflag = F_Static ;} break; -case 38: -# line 240 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 39: -# line 241 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 40: -# line 243 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 41: -# line 244 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 42: -# line 246 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 45: -# line 250 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 47: -# line 253 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 49: -# line 256 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 50: -# line 257 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 51: -# line 258 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 52: -# line 259 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 53: -# line 260 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 54: -# line 261 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 55: -# line 262 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 56: -# line 263 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 57: -# line 264 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 58: -# line 265 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 59: -# line 266 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 60: -# line 267 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 61: -# line 268 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 62: -# line 269 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 63: -# line 270 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 64: -# line 271 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 65: -# line 272 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 66: -# line 273 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 67: -# line 274 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 68: -# line 275 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 69: -# line 276 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 70: -# line 277 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 71: -# line 278 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 72: -# line 279 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 73: -# line 280 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 74: -# line 281 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 75: -# line 282 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 76: -# line 283 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 77: -# line 284 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 78: -# line 285 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 79: -# line 286 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 80: -# line 287 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 82: -# line 290 "cgram.g" -{yyval = to_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 83: -# line 291 "cgram.g" -{yyval = toby_nd(yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 85: -# line 294 "cgram.g" -{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 87: -# line 297 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 88: -# line 298 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 89: -# line 299 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 90: -# line 300 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 91: -# line 301 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 92: -# line 302 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 93: -# line 303 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 94: -# line 304 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 95: -# line 305 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 96: -# line 306 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 97: -# line 307 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 98: -# line 308 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 99: -# line 309 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 100: -# line 310 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 102: -# line 313 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 103: -# line 314 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 105: -# line 317 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 106: -# line 318 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 107: -# line 319 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 108: -# line 320 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 110: -# line 323 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 111: -# line 324 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 112: -# line 325 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 113: -# line 326 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 115: -# line 329 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 117: -# line 332 "cgram.g" -{yyval = tree4(N_Limit,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 118: -# line 333 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 119: -# line 334 "cgram.g" -{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 121: -# line 337 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],tree1(N_Empty) ,yypvt[-0]) ;} break; -case 122: -# line 338 "cgram.g" -{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]) ;} break; -case 123: -# line 339 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 124: -# line 340 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 125: -# line 341 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 126: -# line 342 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 127: -# line 343 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 128: -# line 344 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 129: -# line 345 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 130: -# line 346 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 131: -# line 347 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 132: -# line 348 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 133: -# line 349 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 134: -# line 350 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 135: -# line 351 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 136: -# line 352 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 137: -# line 353 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 138: -# line 354 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 139: -# line 355 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 140: -# line 356 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 141: -# line 357 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 142: -# line 358 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 143: -# line 359 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 144: -# line 360 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 154: -# line 371 "cgram.g" -{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]); proc_lst->has_coexpr = 1; ;} break; -case 155: -# line 372 "cgram.g" -{LSym0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0) ;} break; -case 156: -# line 373 "cgram.g" -{yyval = tree2(N_Next,yypvt[-0]) ;} break; -case 157: -# line 374 "cgram.g" -{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]) ;} break; -case 158: -# line 375 "cgram.g" -{if ((yypvt[-1])->n_type == N_Elist) yyval = invk_nd(yypvt[-2],tree1(N_Empty) ,yypvt[-1]); else yyval = yypvt[-1] ;} break; -case 159: -# line 376 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 160: -# line 377 "cgram.g" -{yyval = list_nd(yypvt[-2],yypvt[-1]) ;} break; -case 161: -# line 378 "cgram.g" -{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1]) ;} break; -case 162: -# line 379 "cgram.g" -{yyval = invk_nd(yypvt[-1],yypvt[-2],list_nd(yypvt[-1],tree1(N_Empty) )) ;} break; -case 163: -# line 380 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],list_nd(yypvt[-2],yypvt[-1])) ;} break; -case 164: -# line 381 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],yypvt[-1]) ;} break; -case 165: -# line 382 "cgram.g" -{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 166: -# line 383 "cgram.g" -{yyval = key_leaf(yypvt[-1],spec_str("fail")) ;} break; -case 167: -# line 384 "cgram.g" -{yyval = key_leaf(yypvt[-1],Str0(yypvt[-0])) ;} break; -case 168: -# line 386 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 169: -# line 387 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 170: -# line 389 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 171: -# line 390 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 172: -# line 392 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 173: -# line 393 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 174: -# line 395 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 175: -# line 397 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty) ) ;} break; -case 176: -# line 398 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]) ;} break; -case 177: -# line 399 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 178: -# line 400 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 179: -# line 402 "cgram.g" -{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty) ) ;} break; -case 180: -# line 403 "cgram.g" -{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 181: -# line 405 "cgram.g" -{yyval = case_nd(yypvt[-5],yypvt[-4],yypvt[-1]) ;} break; -case 183: -# line 408 "cgram.g" -{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 184: -# line 410 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 185: -# line 411 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 186: -# line 413 "cgram.g" -{yyval = yypvt[-0]; ;} break; -case 187: -# line 414 "cgram.g" -{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]); ;} break; -case 188: -# line 416 "cgram.g" -{ - yyval = tree3(N_Create,yypvt[-0],yypvt[-0]); proc_lst->has_coexpr = 1; ; - } break; -case 189: -# line 419 "cgram.g" -{ - yyval =tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); proc_lst->has_coexpr = 1; ; - } break; -case 190: -# line 423 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0) ;} break; -case 191: -# line 424 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0) ;} break; -case 192: -# line 425 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0])) ;} break; -case 193: -# line 426 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0])) ;} break; -case 194: -# line 428 "cgram.g" -{yyval = sect_nd(yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]) ;} break; -case 195: -# line 430 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 196: -# line 431 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 197: -# line 432 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 199: -# line 435 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; - } - goto yystack; /* reset registers in driver code */ -} diff --git a/src/iconc/cproto.h b/src/iconc/cproto.h deleted file mode 100644 index a32b982..0000000 --- a/src/iconc/cproto.h +++ /dev/null @@ -1,165 +0,0 @@ -/* - * Prototypes for functions in iconc. - */ -struct sig_lst *add_sig (struct code *sig, struct c_fnc *fnc); -void addlib (char *libname); -struct code *alc_ary (int n); -int alc_cbufs (int num, nodeptr lifetime); -int alc_dtmp (nodeptr lifetime); -int alc_itmp (nodeptr lifetime); -struct code *alc_lbl (char *desc, int flag); -int alc_sbufs (int num, nodeptr lifetime); -#ifdef OptimizeType -unsigned int *alloc_mem_typ (unsigned int n_types); -#endif /* OptimizeType */ -void arth_anlz (struct il_code *var1, struct il_code *var2, - int *maybe_int, int *maybe_dbl, int *chk1, - struct code **conv1p, int *chk2, - struct code **conv2p); -struct node *aug_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -struct node *binary_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -void bitrange (int typcd, int *frst_bit, int *last_bit); -nodeptr buildarray (nodeptr a, nodeptr lb, nodeptr e); -void callc_add (struct c_fnc *cont); -void callo_add (char *oper_nm, int ret_flag, - struct c_fnc *cont, int need_cont, - struct code *arglist, struct code *on_ret); -struct node *case_nd (nodeptr loc_model, nodeptr expr, nodeptr cases); -int ccomp (char *srcname, char *exename); -void cd_add (struct code *cd); -struct val_loc *chk_alc (struct val_loc *rslt, nodeptr lifetime); -void chkinv (void); -void chkstrinv (void); -struct node *c_str_leaf (int type,struct node *loc_model, char *c); -void codegen (struct node *t); -int cond_anlz (struct il_code *il, struct code **cdp); -void const_blks (void); -struct val_loc *cvar_loc (char *name); -int do_inlin (struct implement *impl, nodeptr n, int *sep_cont, - struct op_symentry *symtab, int n_va); -void doiconx (char *s); -struct val_loc *dtmp_loc (int n); -void eval_arith (int indx1, int indx2, int *maybe_int, int *maybe_dbl); -int eval_cnv (int typcd, int indx, int def, int *cnv_flags); -int eval_is (int typcd,int indx); -void findcases (struct il_code *il, int has_dflt, - struct case_anlz *case_anlz); -void fix_fncs (struct c_fnc *fnc); -struct fentry *flookup (char *id); -void gen_inlin (struct il_code *il, struct val_loc *rslt, - struct code **scont_strt, - struct code **scont_fail, struct c_fnc *cont, - struct implement *impl, int nsyms, - struct op_symentry *symtab, nodeptr n, - int dcl_var, int n_va); -int getopr (int ac, int *cc); -#ifdef OptimizeType -unsigned int get_bit_vector (struct typinfo *src, int pos); -#endif /* OptimizeType */ -struct gentry *glookup (char *id); -void hsyserr (char **av, char *file); -struct node *i_str_leaf (int type,struct node *loc_model,char *c, int d); -long iconint (char *image); -struct code *il_copy (struct il_c *dest, struct val_loc *src); -struct code *il_cnv (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -struct code *il_dflt (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -void implproto (struct implement *ip); -void init (void); -void init_proc (char *name); -void init_rec (char *name); -void init_src (void); -void install (char *name,int flag); -struct gentry *instl_p (char *name, int flag); -struct node *int_leaf (int type,struct node *loc_model,int c); -struct val_loc *itmp_loc (int n); -struct node *invk_main (struct pentry *main_proc); -struct node *invk_nd (struct node *loc_model, struct node *proc, - struct node *args); -void invoc_grp (char *grp); -void invocbl (nodeptr op, int arity); -struct node *key_leaf (nodeptr loc_model, char *keyname); -void liveness (nodeptr n, nodeptr resumer, nodeptr *failer, int *gen); -struct node *list_nd (nodeptr loc_model, nodeptr args); -void lnkdcl (char *name); -void readdb (char *db_name); -struct val_loc *loc_cpy (struct val_loc *loc, int mod_access); -#ifdef OptimizeType -void mark_recs (struct fentry *fp, struct typinfo *typ, - int *num_offsets, int *offset, int *bad_recs); -#else /* OptimizeType */ -void mark_recs (struct fentry *fp, unsigned int *typ, - int *num_offsets, int *offset, int *bad_recs); -#endif /* OptimizeType */ -struct code *mk_goto (struct code *label); -struct node *multiunary (char *op, nodeptr loc_model, nodeptr oprnd); -struct sig_act *new_sgact (struct code *sig, struct code *cd, - struct sig_act *next); -int nextchar (void); -void nfatal (struct node *n, char *s1, char *s2); -int n_arg_sym (struct implement *ip); -void outerfnc (struct c_fnc *fnc); -int past_prms (struct node *n); -void proccode (struct pentry *proc); -void prt_fnc (struct c_fnc *fnc); -void prt_frame (char *prefix, int ntend, int n_itmp, - int i, int j, int k); -struct centry *putlit (char *image,int littype,int len); -struct lentry *putloc (char *id,int id_type); -void quit (char *msg); -void quitf (char *msg,char *arg); -void recconstr (struct rentry *r); -void resolve (struct pentry *proc); -unsigned int round2 (unsigned int n); -struct code *sig_cd (struct code *fail, struct c_fnc *fnc); -void src_file (char *name); -struct node *sect_nd (nodeptr op, nodeptr arg1, nodeptr arg2, - nodeptr arg3); -void tfatal (char *s1,char *s2); -struct node *to_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2); -struct node *toby_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2, nodeptr arg3); -int trans (void); -struct node *tree1 (int type); -struct node *tree2 (int type,struct node *loc_model); -struct node *tree3 (int type,struct node *loc_model, - struct node *c); -struct node *tree4 (int type, struct node *loc_model, - struct node *c, struct node *d); -struct node *tree5 (int type, struct node *loc_model, - struct node *c, struct node *d, - struct node *e); -struct node *tree6 (int type,struct node *loc_model, - struct node *c, struct node *d, - struct node *e, struct node *f); -void tsyserr (char *s); -void twarn (char *s1,char *s2); -struct code *typ_chk (struct il_code *var, int typcd); -int type_case (struct il_code *il, int (*fnc)(), - struct case_anlz *case_anlz); -void typeinfer (void); -struct node *unary_nd (nodeptr op, nodeptr arg); -void var_dcls (void); -#ifdef OptimizeType -int varsubtyp (struct typinfo *typ, struct lentry **single); -#else /* OptimizeType */ -int varsubtyp (unsigned int *typ, struct lentry **single); -#endif /* OptimizeType */ -void writecheck (int rc); -void yyerror (int tok,struct node *lval,int state); -int yylex (void); -int yyparse (void); -#ifdef OptimizeType -void xfer_packed_types (struct typinfo *type); -#endif /* OptimizeType */ - -#ifdef DeBug -void symdump (void); -void ldump (struct lentry **lhash); -void gdump (void); -void cdump (void); -void fdump (void); -void rdump (void); -#endif /* DeBug */ diff --git a/src/iconc/csym.c b/src/iconc/csym.c deleted file mode 100644 index 8e764e3..0000000 --- a/src/iconc/csym.c +++ /dev/null @@ -1,853 +0,0 @@ -/* - * csym.c -- functions for symbol table management. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ - -static struct gentry *alcglob (struct gentry *blink, - char *name,int flag); -static struct fentry *alcfld (struct fentry *blink, char *name, - struct par_rec *rp); -static struct centry *alclit (struct centry *blink, - char *image, int len,int flag); -static struct lentry *alcloc (struct lentry *blink, - char *name,int flag); -static struct par_rec *alcprec (struct rentry *rec, int offset, - struct par_rec *next); -static struct centry *clookup (char *image,int flag); -static struct lentry *dcl_loc (char *id, int id_type, - struct lentry *next); -static struct lentry *llookup (char *id); -static void opstrinv (struct implement *ip); -static struct gentry *putglob (char *id,int id_type); -static struct gentry *try_gbl (char *id); - -int max_sym = 0; /* max number of parameter symbols in run-time routines */ -int max_prm = 0; /* max number of parameters for any invocable routine */ - -/* - * The operands of the invocable declaration are stored in a list for - * later processing. - */ -struct strinv { - nodeptr op; - int arity; - struct strinv *next; - }; -struct strinv *strinvlst = NULL; -int op_tbl_sz; - -struct pentry *proc_lst = NULL; /* procedure list */ -struct rentry *rec_lst = NULL; /* record list */ - - -/* - *instl_p - install procedure or record in global symbol table, returning - * the symbol table entry. - */ -struct gentry *instl_p(name, flag) -char *name; -int flag; - { - struct gentry *gp; - - flag |= F_Global; - if ((gp = glookup(name)) == NULL) - gp = putglob(name, flag); - else if ((gp->flag & (~F_Global)) == 0) { - /* - * superfluous global declaration for record or proc - */ - gp->flag |= flag; - } - else /* the user can't make up his mind */ - tfatal("inconsistent redeclaration", name); - return gp; - } - -/* - * install - put an identifier into the global or local symbol table. - * The basic idea here is to look in the right table and install - * the identifier if it isn't already there. Some semantic checks - * are performed. - */ -void install(name, flag) -char *name; -int flag; - { - struct fentry *fp; - struct gentry *gp; - struct lentry *lp; - struct par_rec **rpp; - struct fldname *fnp; - int foffset; - - switch (flag) { - case F_Global: /* a variable in a global declaration */ - if ((gp = glookup(name)) == NULL) - putglob(name, flag); - else - gp->flag |= flag; - break; - - case F_Static: /* static declaration */ - ++proc_lst->nstatic; - lp = dcl_loc(name, flag, proc_lst->statics); - proc_lst->statics = lp; - break; - - case F_Dynamic: /* local declaration */ - ++proc_lst->ndynam; - lp = dcl_loc(name, flag, proc_lst->dynams); - proc_lst->dynams = lp; - break; - - case F_Argument: /* formal parameter */ - ++proc_lst->nargs; - if (proc_lst->nargs > max_prm) - max_prm = proc_lst->nargs; - lp = dcl_loc(name, flag, proc_lst->args); - proc_lst->args = lp; - break; - - case F_Field: /* field declaration */ - fnp = NewStruct(fldname); - fnp->name = name; - fnp->next = rec_lst->fields; - rec_lst->fields = fnp; - foffset = rec_lst->nfields++; - if (foffset > max_prm) - max_prm = foffset; - if ((fp = flookup(name)) == NULL) { - /* - * first occurrence of this field name. - */ - fhash[FHasher(name)] = alcfld(fhash[FHasher(name)], name, - alcprec(rec_lst, foffset, NULL)); - } - else { - rpp = &(fp->rlist); - while (*rpp != NULL && (*rpp)->offset <= foffset && - (*rpp)->rec != rec_lst) - rpp = &((*rpp)->next); - if (*rpp == NULL || (*rpp)->offset > foffset) - *rpp = alcprec(rec_lst, foffset, *rpp); - else - tfatal("duplicate field name", name); - } - break; - - default: - tsyserr("install: unrecognized symbol table flag."); - } - } - -/* - * dcl_loc - handle declaration of a local identifier. - */ -static struct lentry *dcl_loc(name, flag, next) -char *name; -int flag; -struct lentry *next; - { - register struct lentry *lp; - - if ((lp = llookup(name)) == NULL) { - lp = putloc(name,flag); - lp->next = next; - } - else if (lp->flag == flag) /* previously declared as same type */ - twarn("redeclared identifier", name); - else /* previously declared as different type */ - tfatal("inconsistent redeclaration", name); - return lp; - } - -/* - * putloc - make a local symbol table entry and return pointer to it. - */ -struct lentry *putloc(id,id_type) -char *id; -int id_type; - { - register struct lentry *ptr; - register struct lentry **lhash; - unsigned hashval; - - if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ - lhash = proc_lst->lhash; - hashval = LHasher(id); - ptr = alcloc(lhash[hashval], id, id_type); - lhash[hashval] = ptr; - ptr->next = NULL; - } - return ptr; - } - -/* - * putglob makes a global symbol table entry and returns a pointer to it. - */ -static struct gentry *putglob(id, id_type) -char *id; -int id_type; - { - register struct gentry *ptr; - register unsigned hashval; - - if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ - hashval = GHasher(id); - ptr = alcglob(ghash[hashval], id, id_type); - ghash[hashval] = ptr; - } - return ptr; - } - -/* - * putlit makes a constant symbol table entry and returns a pointer to it. - */ -struct centry *putlit(image, littype, len) -char *image; -int len, littype; - { - register struct centry *ptr; - register unsigned hashval; - - if ((ptr = clookup(image,littype)) == NULL) { /* add to head of hash chain */ - hashval = CHasher(image); - ptr = alclit(chash[hashval], image, len, littype); - chash[hashval] = ptr; - } - return ptr; - } - -/* - * llookup looks up id in local symbol table and returns pointer to - * to it if found or NULL if not present. - */ - -static struct lentry *llookup(id) -char *id; - { - register struct lentry *ptr; - - ptr = proc_lst->lhash[LHasher(id)]; - while (ptr != NULL && ptr->name != id) - ptr = ptr->blink; - return ptr; - } - -/* - * flookup looks up id in flobal symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct fentry *flookup(id) -char *id; - { - register struct fentry *ptr; - - ptr = fhash[FHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * glookup looks up id in global symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct gentry *glookup(id) -char *id; - { - register struct gentry *ptr; - - ptr = ghash[GHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * clookup looks up id in constant symbol table and returns pointer to - * to it if found or NULL if not present. - */ -static struct centry *clookup(image,flag) -char *image; -int flag; - { - register struct centry *ptr; - - ptr = chash[CHasher(image)]; - while (ptr != NULL && (ptr->image != image || ptr->flag != flag)) - ptr = ptr->blink; - - return ptr; - } - -#ifdef DeBug -/* - * symdump - dump symbol tables. - */ -void symdump() - { - struct pentry *proc; - - gdump(); - cdump(); - rdump(); - fdump(); - for (proc = proc_lst; proc != NULL; proc = proc->next) { - fprintf(stderr,"\n"); - fprintf(stderr,"Procedure %s\n", proc->sym_entry->name); - ldump(proc->lhash); - } - } - -/* - * prt_flgs - print flags from a symbol table entry. - */ -static void prt_flgs(flags) -int flags; - { - if (flags & F_Global) - fprintf(stderr, " F_Global"); - if (flags & F_Proc) - fprintf(stderr, " F_Proc"); - if (flags & F_Record) - fprintf(stderr, " F_Record"); - if (flags & F_Dynamic) - fprintf(stderr, " F_Dynamic"); - if (flags & F_Static) - fprintf(stderr, " F_Static"); - if (flags & F_Builtin) - fprintf(stderr, " F_Builtin"); - if (flags & F_StrInv) - fprintf(stderr, " F_StrInv"); - if (flags & F_ImpError) - fprintf(stderr, " F_ImpError"); - if (flags & F_Argument) - fprintf(stderr, " F_Argument"); - if (flags & F_IntLit) - fprintf(stderr, " F_IntLit"); - if (flags & F_RealLit) - fprintf(stderr, " F_RealLit"); - if (flags & F_StrLit) - fprintf(stderr, " F_StrLit"); - if (flags & F_CsetLit) - fprintf(stderr, " F_CsetLit"); - if (flags & F_Field) - fprintf(stderr, " F_Field"); - fprintf(stderr, "\n"); - } -/* - * ldump displays local symbol table to stderr. - */ - -void ldump(lhash) -struct lentry **lhash; - { - register int i; - register struct lentry *lptr; - - fprintf(stderr," Dump of local symbol table\n"); - fprintf(stderr," address name globol-ref flags\n"); - for (i = 0; i < LHSize; i++) - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { - fprintf(stderr," %8x %20s ", lptr, lptr->name); - if (lptr->flag & F_Global) - fprintf(stderr, "%8x ", lptr->val.global); - else - fprintf(stderr, " - "); - prt_flgs(lptr->flag); - } - fflush(stderr); - } - -/* - * gdump displays global symbol table to stderr. - */ - -void gdump() - { - register int i; - register struct gentry *gptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of global symbol table\n"); - fprintf(stderr," address name nargs flags\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - fprintf(stderr," %8x %20s %4d ", gptr, - gptr->name, gptr->nargs); - prt_flgs(gptr->flag); - } - fflush(stderr); - } - -/* - * cdump displays constant symbol table to stderr. - */ - -void cdump() - { - register int i; - register struct centry *cptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of constant symbol table\n"); - fprintf(stderr, - " address value flags\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - fprintf(stderr," %8x %-40.40s ", cptr, cptr->image); - prt_flgs(cptr->flag); - } - fflush(stderr); - } - -/* - * fdump displays field symbol table to stderr. - */ -void fdump() - { - int i; - struct par_rec *prptr; - struct fentry *fp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of field symbol table\n"); - fprintf(stderr, - " address field global-ref offset\n"); - for (i = 0; i < FHSize; i++) - for (fp = fhash[i]; fp != NULL; fp = fp->blink) { - fprintf(stderr," %8x %20s\n", fp, fp->name); - for (prptr = fp->rlist; prptr != NULL; prptr = prptr->next) - fprintf(stderr," %8x %4d\n", - prptr->sym_entry, prptr->offset); - } - fflush(stderr); - } - -/* - * prt_flds - print a list of fields stored in reverse order. - */ -static void prt_flds(f) -struct fldname *f; - { - if (f == NULL) - return; - prt_flds(f->next); - fprintf(stderr, " %s", f->name); - } - -/* - * rdump displays list of records and their fields. - */ -void rdump() - { - struct rentry *rp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of record list\n"); - fprintf(stderr, " global-ref fields\n"); - for (rp = rec_lst; rp != NULL; rp = rp->next) { - fprintf(stderr, " %8x ", rp->sym_entry); - prt_flds(rp->fields); - fprintf(stderr, "\n"); - } - } -#endif /* DeBug */ - -/* - * alcloc allocates a local symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct lentry *alcloc(blink, name, flag) -struct lentry *blink; -char *name; -int flag; - { - register struct lentry *lp; - - lp = NewStruct(lentry); - lp->blink = blink; - lp->name = name; - lp->flag = flag; - return lp; - } - -/* - * alcfld allocates a field symbol table entry, fills in the entry with - * specified values and returns pointer to new entry. - */ -static struct fentry *alcfld(blink, name, rp) -struct fentry *blink; -char *name; -struct par_rec *rp; - { - register struct fentry *fp; - - fp = NewStruct(fentry); - fp->blink = blink; - fp->name = name; - fp->rlist = rp; - return fp; - } - -/* - * alcglob allocates a global symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct gentry *alcglob(blink, name, flag) -struct gentry *blink; -char *name; -int flag; - { - register struct gentry *gp; - - gp = NewStruct(gentry); - gp->blink = blink; - gp->name = name; - gp->flag = flag; - return gp; - } - -/* - * alclit allocates a constant symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct centry *alclit(blink, image, len, flag) -struct centry *blink; -char *image; -int len, flag; - { - register struct centry *cp; - - cp = NewStruct(centry); - cp->blink = blink; - cp->image = image; - cp->length = len; - cp->flag = flag; - switch (flag) { - case F_IntLit: - cp->u.intgr = iconint(image); - break; - case F_CsetLit: - cp->u.cset = bitvect(image, len); - break; - } - return cp; - } - -/* - * alcprec allocates an entry for the parent record list for a field. - */ -static struct par_rec *alcprec(rec, offset, next) -struct rentry *rec; -int offset; -struct par_rec *next; - { - register struct par_rec *rp; - - rp = NewStruct(par_rec); - rp->rec= rec; - rp->offset = offset; - rp->next = next; - return rp; - } - -/* - * resolve - resolve the scope of undeclared identifiers. - */ -void resolve(proc) -struct pentry *proc; - { - struct lentry **lhash; - register struct lentry *lp; - struct gentry *gp; - int i; - char *id; - - lhash = proc->lhash; - - for (i = 0; i < LHSize; ++i) { - lp = lhash[i]; - while (lp != NULL) { - id = lp->name; - if (lp->flag == 0) { /* undeclared */ - if ((gp = try_gbl(id)) != NULL) { /* check global */ - lp->flag = F_Global; - lp->val.global = gp; - } - else { /* implicit local */ - if (uwarn) { - fprintf(stderr, "%s undeclared identifier, procedure %s\n", - id, proc->name); - ++twarns; - } - lp->flag = F_Dynamic; - lp->next = proc->dynams; - proc->dynams = lp; - ++proc->ndynam; - } - } - lp = lp->blink; - } - } - } - -/* - * try_glb - see if the identifier is or should be a global variable. - */ -static struct gentry *try_gbl(id) -char *id; - { - struct gentry *gp; - register struct implement *iptr; - int nargs; - int n; - - gp = glookup(id); - if (gp == NULL) { - /* - * See if it is a built-in function. - */ - iptr = db_ilkup(id, bhash); - if (iptr == NULL) - return NULL; - else { - if (iptr->in_line == NULL) - nfatal(NULL, "built-in function not installed", id); - nargs = iptr->nargs; - if (nargs > 0 && iptr->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - gp = putglob(id, F_Global | F_Builtin); - gp->val.builtin = iptr; - - n = n_arg_sym(iptr); - if (n > max_sym) - max_sym = n; - } - } - return gp; - } - -/* - * invoc_grp - called when "invocable all" is encountered. - */ -void invoc_grp(grp) -char *grp; - { - if (grp == spec_str("all")) - str_inv = 1; /* enable full string invocation */ - else - tfatal("invalid operand to invocable", grp); - } - -/* - * invocbl - indicate that the operator is needed for for string invocation. - */ -void invocbl(op, arity) -nodeptr op; -int arity; - { - struct strinv *si; - - si = NewStruct(strinv); - si->op = op; - si->arity = arity; - si->next = strinvlst; - strinvlst = si; - } - -/* - * chkstrinv - check to see what is needed for string invocation. - */ -void chkstrinv() - { - struct strinv *si; - struct gentry *gp; - struct implement *ip; - char *op_name; - int arity; - int i; - - /* - * A table of procedure blocks for operators is set up for use by - * string invocation. - */ - op_tbl_sz = 0; - fprintf(codefile, "\nstatic B_IProc(2) init_op_tbl[OpTblSz]"); - - if (str_inv) { - /* - * All operations must be available for string invocation. Make sure all - * built-in functions have either been hidden by global declarations - * or are in global variables, make sure no global variables are - * optimized away, and make sure all operations are in the table of - * operations. - */ - for (i = 0; i < IHSize; ++i) /* built-in function table */ - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - try_gbl(ip->name); - for (i = 0; i < GHSize; i++) /* global symbol table */ - for (gp = ghash[i]; gp != NULL; gp = gp->blink) - gp->flag |= F_StrInv; - for (i = 0; i < IHSize; ++i) /* operator table */ - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - opstrinv(ip); - } - else { - /* - * selected operations must be available for string invocation. - */ - for (si = strinvlst; si != NULL; si = si->next) { - op_name = Str0(si->op); - if (isalpha(*op_name) || (*op_name == '_')) { - /* - * This needs to be something in a global variable: function, - * procedure, or constructor. - */ - gp = try_gbl(op_name); - if (gp == NULL) - nfatal(si->op, "not available for string invocation", op_name); - else - gp->flag |= F_StrInv; - } - else { - /* - * must be an operator. - */ - arity = si->arity; - i = IHasher(op_name); - for (ip = ohash[i]; ip != NULL && ip->op != op_name; - ip = ip->blink) - ; - if (arity < 0) { - /* - * Operators of all arities with this symbol. - */ - while (ip != NULL && ip->op == op_name) { - opstrinv(ip); - ip = ip->blink; - } - } - else { - /* - * Operator of a specific arity. - */ - while (ip != NULL && ip->nargs != arity) - ip = ip->blink; - if (ip == NULL || ip->op != op_name) - nfatal(si->op, "not available for string invocation", - op_name); - else - opstrinv(ip); - } - } - } - } - - /* - * Add definitions to the header file indicating the size of the operator - * table and finish the declaration in the code file. - */ - if (op_tbl_sz == 0) { - fprintf(inclfile, "#define OpTblSz 1\n"); - fprintf(inclfile, "int op_tbl_sz = 0;\n"); - fprintf(codefile, ";\n"); - } - else { - fprintf(inclfile, "#define OpTblSz %d\n", op_tbl_sz); - fprintf(inclfile, "int op_tbl_sz = OpTblSz;\n"); - fprintf(codefile, "\n };\n"); - } - } - -/* - * opstrinv - set up string invocation for an operator. - */ -static void opstrinv(ip) -struct implement *ip; - { - char c1, c2; - char *name; - char *op; - register char *s; - int nargs; - int n; - - if (ip == NULL || ip->iconc_flgs & InStrTbl) - return; - - /* - * Keep track of the maximum number of argument symbols in any operation - * so type inference can allocate enough storage for the worst case of - * general invocation. - */ - n = n_arg_sym(ip); - if (n > max_sym) - max_sym = n; - - name = ip->name; - c1 = ip->prefix[0]; - c2 = ip->prefix[1]; - op = ip->op; - nargs = ip->nargs; - if (ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; /* indicate varargs with negative number of params */ - - if (op_tbl_sz++ == 0) { - fprintf(inclfile, "\n"); - fprintf(codefile, " = {\n"); - } - else - fprintf(codefile, ",\n"); - implproto(ip); /* output prototype */ - - /* - * Output procedure block for this operator into table used by string - * invocation. - */ - fprintf(codefile, " {T_Proc, 11, O%c%c_%s, %d, -1, 0, 0, {{%d, \"", c1, c2, - name, nargs, strlen(op)); - for (s = op; *s != '\0'; ++s) { - if (*s == '\\') - fprintf(codefile, "\\"); - fprintf(codefile, "%c", *s); - } - fprintf(codefile, "\"}}}"); - ip->iconc_flgs |= InStrTbl; - } - -/* - * n_arg_sym - determine the number of argument symbols (dereferenced - * and undereferenced arguments are separate symbols) for an operation - * in the data base. - */ -int n_arg_sym(ip) -struct implement *ip; - { - int i; - int num; - - num = 0; - for (i = 0; i < ip->nargs; ++i) { - if (ip->arg_flgs[i] & RtParm) - ++num; - if (ip->arg_flgs[i] & DrfPrm) - ++num; - } - return num; - } diff --git a/src/iconc/csym.h b/src/iconc/csym.h deleted file mode 100644 index cf104af..0000000 --- a/src/iconc/csym.h +++ /dev/null @@ -1,380 +0,0 @@ -/* - * Structures for symbol table entries. - */ - -#define MaybeTrue 1 /* condition might be true at run time */ -#define MaybeFalse 2 /* condition might be false at run time */ - -#define MayConvert 1 /* type conversion may convert the value */ -#define MayDefault 2 /* defaulting type conversion may use default */ -#define MayKeep 4 /* conversion may succeed without any actual conversion */ - -#ifdef OptimizeType -#define NULL_T 0x1000000 -#define REAL_T 0x2000000 -#define INT_T 0x4000000 -#define CSET_T 0x8000000 -#define STR_T 0x10000000 - -#define TYPINFO_BLOCK 400000 - -/* - * Optimized type structure for bit vectors - * All previous occurencess of unsigned int * (at least - * when refering to bit vectors) have been replaced by - * struct typinfo. - */ -struct typinfo { - unsigned int packed; /* packed representation of types */ - unsigned int *bits; /* full length bit vector */ -}; -#endif /* OptimizeType */ - -/* - * Data base type codes are mapped to type inferencing information using - * an array. - */ -struct typ_info { - int frst_bit; /* first bit in bit vector allocated to this type */ - int num_bits; /* number of bits in bit vector allocated to this type */ - int new_indx; /* index into arrays of allocated types for operation */ -#ifdef OptimizeType - struct typinfo *typ; /* for variables: initial type */ -#else /* OptimizeType */ - unsigned int *typ; /* for variabled: initial type */ -#endif /* OptimizeType */ - }; - -/* - * A type is a bit vector representing a union of basic types. There - * are 3 sizes of types: first class types (Icon language types), - * intermediate value types (first class types plus variable references), - * run-time routine types (intermediate value types plus internal - * references to descriptors such as set elements). When the size of - * the type is known from context, a simple bit vector can be used. - * In other contexts, the size must be included. - */ -struct type { - int size; -#ifdef OptimizeType - struct typinfo *bits; -#else /* OptimizeType */ - unsigned int *bits; -#endif /* OptimizeType */ - struct type *next; - }; - - -#define DecodeSize(x) (x & 0xFFFFFF) -#define DecodePacked(x) (x >> 24) -/* - * NumInts - convert from the number of bits in a bit vector to the - * number of integers implementing it. - */ -#define NumInts(n_bits) (n_bits - 1) / IntBits + 1 - -/* - * ClrTyp - zero out the bit vector for a type. - */ -#ifdef OptimizeType -#define ClrTyp(size,typ) {\ - int typ_indx;\ - if ((typ)->bits == NULL)\ - clr_packed((typ),(size));\ - else\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)->bits[typ_indx] = 0;} -#else /* OptimizeType */ -#define ClrTyp(size,typ) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)[typ_indx] = 0;} -#endif /* OptimizeType */ - -/* - * CpyTyp - copy a type of the given size from one bit vector to another. - */ -#ifdef OptimizeType -#define CpyTyp(nsize,src,dest) {\ - int typ_indx, num;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ClrTyp((nsize),(dest));\ - cpy_packed_to_packed((src),(dest),(nsize));\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ClrTyp((nsize),(dest));\ - xfer_packed_to_bits((src),(dest),(nsize));\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define CpyTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] = (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * MrgTyp - merge a type of the given size from one bit vector into another. - */ -#ifdef OptimizeType -#define MrgTyp(nsize,src,dest) {\ - int typ_indx;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL))\ - mrg_packed_to_packed((src),(dest),(nsize));\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL))\ - xfer_packed_to_bits((src),(dest),(nsize));\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define MrgTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] |= (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * ChkMrgTyp - merge a type of the given size from one bit vector into another, - * updating the changed flag if the destination is changed by the merger. - */ -#ifdef OptimizeType -#define ChkMrgTyp(nsize,src,dest) {\ - int typ_indx, ret; unsigned int old;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ret = mrg_packed_to_packed((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ret = xfer_packed_to_bits((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}} -#else /* OptimizeType */ -#define ChkMrgTyp(size,src,dest) {\ - int typ_indx; unsigned int old;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx) {\ - old = (dest)[typ_indx];\ - (dest)[typ_indx] |= (src)[typ_indx];\ - if (old != (dest)[typ_indx]) ++changed;}} -#endif /* OptimizeType */ - - -struct centry { /* constant table entry */ - struct centry *blink; /* link for bucket chain */ - char *image; /* pointer to string image of literal */ - int length; /* length of string */ - union { - unsigned short *cset; /* pointer to bit string for cset literal */ - long intgr; /* value of integer literal */ - } u; - uword flag; /* type of literal flag */ - char prefix[PrfxSz+1]; /* unique prefix used in data block name */ - }; - -struct fentry { /* field table entry */ - struct fentry *blink; /* link for bucket chain */ - char *name; /* name of field */ - struct par_rec *rlist; /* head of list of records */ - }; - -struct lentry { /* local table entry */ - struct lentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct gentry *global; /* for globals: global symbol table entry */ - int index; /* type index; run-time descriptor index */ - } val; - struct lentry *next; /* used for linking a class of variables */ - }; - -struct gentry { /* global table entry */ - struct gentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct implement *builtin; /* pointer to built-in function */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ - } val; - int index; /* index into global array */ - int init_type; /* initial type if procedure */ - }; - -/* - * Structure for list of parent records for a field name. - */ -struct par_rec { - struct rentry *rec; /* parent record */ - int offset; /* field's offset within this record */ - int mark; /* used during code generation */ - struct par_rec *next; - }; - -/* - * Structure for a procedure. - */ -struct pentry { - char *name; /* name of procedure */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - struct lentry **lhash; /* hash area for procedure's local table */ - int nargs; /* number of args */ - struct lentry *args; /* list of arguments in reverse order */ - int ndynam; /* number of dynamic locals */ - struct lentry *dynams; /* list of dynamics in reverse order */ - int nstatic; /* number of statics */ - struct lentry *statics; /* list of statics in reverse order */ - struct node *tree; /* syntax tree for procedure */ - int has_coexpr; /* this procedure contains co-expressions */ - int tnd_loc; /* number of tended dynamic locals */ - int ret_flag; /* proc returns, suspends, and/or fails */ - int reachable; /* this procedure may be executed */ - int iteration; /* last iteration of type inference performed */ - int arg_lst; /* for varargs - the type number of the list */ -#ifdef OptimizeType - struct typinfo *ret_typ; /* type returned from procedure */ -#else /* OptimizeType */ - unsigned int *ret_typ; /* type returned from procedure */ -#endif /* OptimizeType */ - struct store *in_store; /* store at start of procedure */ - struct store *susp_store; /* store for resumption points of procedure */ - struct store *out_store; /* store on exiting procedure */ - struct lentry **vartypmap; /* mapping from var types to symtab entries */ -#ifdef OptimizeType - struct typinfo *coexprs; /* co-expressions in which proc may be called */ -#else /* OptimizeType */ - unsigned int *coexprs; /* co-expressions in which proc may be called */ -#endif /* OptimizeType */ - struct pentry *next; - }; - -/* - * Structure for a record. - */ -struct rentry { - char *name; /* name of record */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - int frst_fld; /* offset of variable type of 1st field */ - int nfields; /* number of fields */ - struct fldname *fields; /* list of field names in reverse order */ - int rec_num; /* id number for record */ - struct rentry *next; - }; - -struct fldname { /* record field */ - char *name; /* field name */ - struct fldname *next; - }; - -/* - * Structure used to analyze whether a type_case statement can be in-lined. - * Only one type check is supported: the type_case will be implemented - * as an "if" statement. - */ -struct case_anlz { - int n_cases; /* number of cases actually needed for this use */ - int typcd; /* for "if" optimization, the type code to check */ - struct il_code *il_then; /* for "if" optimization, the then clause */ - struct il_code *il_else; /* for "if" optimization, the else clause */ - }; - -/* - * spec_op contains the implementations for operations with do not have - * standard unary/binary syntax. - */ -#define ToOp 0 /* index into spec_op of i to j */ -#define ToByOp 1 /* index into spec_op of i to j by k */ -#define SectOp 2 /* index into spec_op of x[i:j] */ -#define SubscOp 3 /* index into spec_op of x[i] */ -#define ListOp 4 /* index into spec_op of [e1, e2, ... ] */ -#define NumSpecOp 5 -extern struct implement *spec_op[NumSpecOp]; - -/* - * Flag values. - */ - -#define F_Global 01 /* variable declared global externally */ -#define F_Proc 04 /* procedure */ -#define F_Record 010 /* record */ -#define F_Dynamic 020 /* variable declared local dynamic */ -#define F_Static 040 /* variable declared local static */ -#define F_Builtin 0100 /* identifier refers to built-in procedure */ -#define F_StrInv 0200 /* variable needed for string invocation */ -#define F_ImpError 0400 /* procedure has default error */ -#define F_Argument 01000 /* variable is a formal parameter */ -#define F_IntLit 02000 /* literal is an integer */ -#define F_RealLit 04000 /* literal is a real */ -#define F_StrLit 010000 /* literal is a string */ -#define F_CsetLit 020000 /* literal is a cset */ -#define F_Field 040000 /* identifier refers to a record field */ -#define F_SmplInv 0100000 /* identifier only used in simple invocation */ - -/* - * Symbol table region pointers. - */ - -extern struct implement *bhash[]; /* hash area for built-in func table */ -extern struct centry *chash[]; /* hash area for constant table */ -extern struct fentry *fhash[]; /* hash area for field table */ -extern struct gentry *ghash[]; /* hash area for global table */ -extern struct implement *khash[]; /* hash area for keyword table */ -extern struct implement *ohash[]; /* hash area for operator table */ - -extern struct pentry *proc_lst; /* procedure list */ -extern struct rentry *rec_lst; /* record list */ - -extern int max_sym; /* max number of parameter symbols in run-time routines */ -extern int max_prm; /* max number of parameters for any invocable routine */ - -extern struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ -extern struct pentry *cur_proc; /* procedure currently being translated */ - -/* - * Hash functions for symbol tables. Note, hash table sizes (xHSize) - * are all a power of 2. - */ - -#define CHasher(x) (((word)x)&(CHSize-1)) /* constant symbol table */ -#define FHasher(x) (((word)x)&(FHSize-1)) /* field symbol table */ -#define GHasher(x) (((word)x)&(GHSize-1)) /* global symbol table */ -#define LHasher(x) (((word)x)&(LHSize-1)) /* local symbol table */ - -/* - * flags for implementation entries. - */ -#define ProtoPrint 1 /* a prototype has already been printed */ -#define InStrTbl 2 /* operator is in string table */ - -/* - * Whether an operation can fail may depend on whether error conversion - * is allowed. The following macro checks this. - */ -#define MightFail(ret_flag) ((ret_flag & DoesFail) ||\ - (err_conv && (ret_flag & DoesEFail))) diff --git a/src/iconc/ctoken.h b/src/iconc/ctoken.h deleted file mode 100644 index 1e95e98..0000000 --- a/src/iconc/ctoken.h +++ /dev/null @@ -1,111 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 diff --git a/src/iconc/ctrans.c b/src/iconc/ctrans.c deleted file mode 100644 index 7d33ac5..0000000 --- a/src/iconc/ctrans.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * ctrans.c - main control of the translation process. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void trans1 (char *filename); - -/* - * Variables. - */ -int tfatals = 0; /* total number of fatal errors */ -int twarns = 0; /* total number of warnings */ -int nocode; /* set by lexer; unused in compiler */ -int in_line; /* current input line number */ -int incol; /* current input column number */ -int peekc; /* one-character look ahead */ -struct srcfile *srclst = NULL; /* list of source files to translate */ - -static char *lpath; /* LPATH value */ - -/* - * translate a number of files, returning an error count - */ -int trans() - { - register struct pentry *proc; - struct srcfile *sf; - - lpath = getenv("LPATH"); /* remains null if unspecified */ - - for (sf = srclst; sf != NULL; sf = sf->next) - trans1(sf->name); /* translate each file in turn */ - - if (!pponly) { - /* - * Resolve undeclared references. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - resolve(proc); - -#ifdef DeBug - symdump(); -#endif /* DeBug */ - - if (tfatals == 0) { - chkstrinv(); /* see what needs be available for string invocation */ - chkinv(); /* perform "naive" optimizations */ - } - - if (tfatals == 0) - typeinfer(); /* perform type inference */ - - if (just_type_trace) - return tfatals; /* stop without generating code */ - - if (tfatals == 0) { - var_dcls(); /* output declarations for globals and statics */ - const_blks(); /* output blocks for cset and real literals */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - proccode(proc); /* output code for a procedure */ - recconstr(rec_lst); /* output code for record constructors */ -/* ANTHONY */ -/* - print_ghash(); -*/ - } - } - - /* - * Report information about errors and warnings and be correct about it. - */ - if (tfatals == 1) - fprintf(stderr, "1 error; "); - else if (tfatals > 1) - fprintf(stderr, "%d errors; ", tfatals); - else if (verbose > 0) - fprintf(stderr, "No errors; "); - - if (twarns == 1) - fprintf(stderr, "1 warning\n"); - else if (twarns > 1) - fprintf(stderr, "%d warnings\n", twarns); - else if (verbose > 0) - fprintf(stderr, "no warnings\n"); - else if (tfatals > 0) - fprintf(stderr, "\n"); - -#ifdef TranStats - tokdump(); -#endif /* TranStats */ - - return tfatals; - } - -/* - * translate one file. - */ -static void trans1(filename) -char *filename; - { - in_line = 1; /* start with line 1, column 0 */ - incol = 0; - peekc = 0; /* clear character lookahead */ - - if (!ppinit(filename,lpath?lpath:".",m4pre)) { - tfatal(filename, "cannot open source file"); - return; - } - if (!largeints) /* undefine predef symbol if no -l option */ - ppdef("_LARGE_INTEGERS", (char *)NULL); - ppdef("_MULTITASKING", (char *)NULL); /* never defined in compiler */ - ppdef("_EVENT_MONITOR", (char *)NULL); - ppdef("_MEMORY_MONITOR", (char *)NULL); - ppdef("_VISUALIZATION", (char *)NULL); - - if (strcmp(filename,"-") == 0) - filename = "stdin"; - if (verbose > 0) - fprintf(stderr, "%s:\n",filename); - - tok_loc.n_file = filename; - in_line = 1; - - if (pponly) - ppecho(); /* preprocess only */ - else - yyparse(); /* Parse the input */ - } - -/* - * writecheck - check the return code from a stdio output operation - */ -void writecheck(rc) - int rc; - - { - if (rc < 0) - quit("unable to write to icode file"); - } - -/* - * lnkdcl - find file locally or on LPATH and add to source list. - */ -void lnkdcl(name) -char *name; -{ - struct srcfile **pp; - struct srcfile *p; - char buf[MaxPath]; - - if (pathfind(buf, lpath, name, SourceSuffix)) - src_file(buf); - else - tfatal("cannot resolve reference to file name", name); - } - -/* - * src_file - add the file name to the list of source files to be translated, - * if it is not already on the list. - */ -void src_file(name) -char *name; - { - struct srcfile **pp; - struct srcfile *p; - - for (pp = &srclst; *pp != NULL; pp = &(*pp)->next) - if (strcmp((*pp)->name, name) == 0) - return; - p = NewStruct(srcfile); - p->name = salloc(name); - p->next = NULL; - *pp = p; -} diff --git a/src/iconc/ctrans.h b/src/iconc/ctrans.h deleted file mode 100644 index 3e03d06..0000000 --- a/src/iconc/ctrans.h +++ /dev/null @@ -1,47 +0,0 @@ -/* - * Miscellaneous compiler-specific definitions. - */ - -#define Iconc - -#ifndef CUsage - #define CUsage "[-C C-comp] [-E] [-T] [-c] [-f{adelns}] [-n{acest}]\n\ - [-o ofile] [-p C-opts] [-r runtime] [-s] [-t] [-u] [-v i]" -#endif /* CUsage */ - -#define Abs(n) ((n) >= 0 ? (n) : -(n)) -#define Max(x,y) ((x)>(y)?(x):(y)) - -#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) - -/* - * Hash tables must be a power of 2. - */ -#define CHSize 128 /* size of constant hash table */ -#define FHSize 32 /* size of field hash table */ -#define GHSize 128 /* size of global hash table */ -#define LHSize 128 /* size of local hash table */ - -#define PrfxSz 3 /* size of prefix */ - -/* - * srcfile is used construct the queue of source files to be translated. - */ -struct srcfile { - char *name; - struct srcfile *next; - }; - -extern struct srcfile *srclst; - -/* - * External definitions needed throughout translator. - */ -extern int twarns; - -#ifdef TranStats -#include "tstats.h" -#else /* TranStats */ -#define TokInc(x) -#define TokDec(x) -#endif /* TranStats */ diff --git a/src/iconc/ctree.c b/src/iconc/ctree.c deleted file mode 100644 index 170a631..0000000 --- a/src/iconc/ctree.c +++ /dev/null @@ -1,777 +0,0 @@ -/* - * ctree.c -- functions for constructing parse trees. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctree.h" -#include "csym.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static nodeptr chk_empty (nodeptr n); -static void put_elms (nodeptr t, nodeptr args, int slot); -static nodeptr subsc_nd (nodeptr op, nodeptr arg1, nodeptr arg2); - -/* - * tree[1-6] construct parse tree nodes with specified values. - * loc_model is a node containing the same line and column information - * as is needed in this node, while parameters a through d are values to - * be assigned to n_field[0-3]. Note that this could be done with a - * single routine; a separate routine for each node size is used for - * speed and simplicity. - */ - -nodeptr tree1(type) -int type; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - return t; - } - -nodeptr tree2(type, loc_model) -int type; -nodeptr loc_model; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - return t; - } - -nodeptr tree3(type, loc_model, a) -int type; -nodeptr loc_model; -nodeptr a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - return t; - } - -nodeptr tree4(type, loc_model, a, b) -int type; -nodeptr loc_model; -nodeptr a, b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - return t; - } - -nodeptr tree5(type, loc_model, a, b, c) -int type; -nodeptr loc_model; -nodeptr a, b, c; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - return t; - } - -nodeptr tree6(type, loc_model, a, b, c, d) -int type; -nodeptr loc_model; -nodeptr a, b, c, d; - { - register nodeptr t; - - t = NewNode(4); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - t->n_field[3].n_ptr = d; - return t; - } - -nodeptr int_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -int a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = a; - return t; - } - -nodeptr c_str_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -char *a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - return t; - } - -/* - * i_str_leaf - create a leaf node containing a string and length. - */ -nodeptr i_str_leaf(type, loc_model, a, b) -int type; -nodeptr loc_model; -char *a; -int b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - t->n_field[1].n_val = b; - return t; - } - -/* - * key_leaf - create a leaf node for a keyword. - */ -nodeptr key_leaf(loc_model, keyname) -nodeptr loc_model; -char *keyname; - { - register nodeptr t; - struct implement *ip; - struct il_code *il; - char *s; - int typcd; - - /* - * Find the data base entry for the keyword, if it exists. - */ - ip = db_ilkup(keyname, khash); - - if (ip == NULL) - tfatal("invalid keyword", keyname); - else if (ip->in_line == NULL) - tfatal("keyword not installed", keyname); - else { - il = ip->in_line; - s = il->u[1].s; - if (il->il_type == IL_Const) { - /* - * This is a constant keyword, treat it as a literal. - */ - t = NewNode(1); - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - typcd = il->u[0].n; - if (typcd == cset_typ) { - t->n_type = N_Cset; - CSym0(t) = putlit(&s[1], F_CsetLit, strlen(s) - 2); - } - else if (typcd == int_typ) { - t->n_type = N_Int; - CSym0(t) = putlit(s, F_IntLit, 0); - } - else if (typcd == real_typ) { - t->n_type = N_Real; - CSym0(t) = putlit(s, F_RealLit, 0); - } - else if (typcd == str_typ) { - t->n_type = N_Str; - CSym0(t) = putlit(&s[1], F_StrLit, strlen(s) - 2); - } - return t; - } - } - - t = NewNode(2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 0; /* number of arguments */ - t->n_field[1].ip = ip; - return t; - } - -/* - * list_nd - create a list creation node. - */ -nodeptr list_nd(loc_model, args) -nodeptr loc_model; -nodeptr args; - { - register nodeptr t; - struct implement *impl; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - impl = spec_op[ListOp]; - if (impl == NULL) - nfatal(loc_model, "list creation not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(loc_model, "list creation not installed", NULL); - - t = NewNode(nargs + 2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].ip = impl; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * invk_nd - create a node for invocation. - */ -nodeptr invk_nd(loc_model, proc, args) -nodeptr loc_model; -nodeptr proc; -nodeptr args; - { - register nodeptr t; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - t = NewNode(nargs + 2); - t->n_type = N_Invok; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].n_ptr = proc; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * put_elms - convert a linked list of arguments into an array of arguments - * in a node. - */ -static void put_elms(t, args, slot) -nodeptr t; -nodeptr args; -int slot; - { - if (args->n_type == N_Elist) { - /* - * The linked list is in reverse argument order. - */ - t->n_field[slot].n_ptr = chk_empty(args->n_field[1].n_ptr); - put_elms(t, args->n_field[0].n_ptr, slot - 1); - free(args); - } - else - t->n_field[slot].n_ptr = chk_empty(args); - } - -/* - * chk_empty - if an argument is empty, replace it with &null. - */ -static nodeptr chk_empty(n) -nodeptr n; - { - if (n->n_type == N_Empty) - n = key_leaf(n, spec_str("null")); - return n; - } - -/* - * case_nd - create a node for a case statement. - */ -nodeptr case_nd(loc_model, expr, cases) -nodeptr loc_model; -nodeptr expr; -nodeptr cases; - { - register nodeptr t; - nodeptr reverse; - nodeptr nxt_cases; - nodeptr ccls; - - t = NewNode(3); - t->n_type = N_Case; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = expr; - t->n_field[2].n_ptr = NULL; - - /* - * The list of cases is in reverse order. Walk the list reversing it, - * and extract the default clause if one exists. - */ - reverse = NULL; - while (cases->n_type != N_Ccls) { - nxt_cases = cases->n_field[0].n_ptr; - ccls = cases->n_field[1].n_ptr; - if (ccls->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = ccls->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - } - else { - if (reverse == NULL) { - reverse = cases; - reverse->n_field[0].n_ptr = ccls; - } - else { - reverse->n_field[1].n_ptr = ccls; - cases->n_field[0].n_ptr = reverse; - reverse = cases; - } - } - cases = nxt_cases; - } - - /* - * Last element in list. - */ - if (cases->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = cases->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - if (reverse != NULL) - reverse = reverse->n_field[0].n_ptr; - } - else { - if (reverse == NULL) - reverse = cases; - else - reverse->n_field[1].n_ptr = cases; - } - t->n_field[1].n_ptr = reverse; - return t; - } - -/* - * multiunary - construct nodes to implement a sequence of unary operators - * that have been lexically analyzed as one operator. - */ -nodeptr multiunary(op, loc_model, oprnd) -nodeptr loc_model; -char *op; -nodeptr oprnd; - { - int n; - nodeptr nd; - - if (*op == '\0') - return oprnd; - for (n = 0; optab[n].tok.t_word != NULL; ++n) - if ((optab[n].expected & Unary) & (*(optab[n].tok.t_word) == *op)) { - nd = OpNode(n); - nd->n_file = loc_model->n_file; - nd->n_line = loc_model->n_line; - nd->n_col = loc_model->n_col; - return unary_nd(nd,multiunary(++op,loc_model,oprnd)); - } - fprintf(stderr, "compiler error: inconsistent parsing of unary operators"); - exit(EXIT_FAILURE); - } - -/* - * binary_nd - construct a node for a binary operator. - */ -nodeptr binary_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "binary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * unary_nd - construct a node for a unary operator. - */ -nodeptr unary_nd(op, arg) -nodeptr op; -nodeptr arg; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].unary; - if (impl == NULL) - nfatal(op, "unary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "unary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(3); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg; - return t; - } - -/* - * buildarray - convert "multi-dimensional" subscripting into a sequence - * of subsripting operations. - */ -nodeptr buildarray(a,lb,e) -nodeptr a, lb, e; - { - register nodeptr t, t2; - if (e->n_type == N_Elist) { - t2 = int_leaf(lb->n_type, lb, lb->n_field[0].n_val); - t = subsc_nd(t2, buildarray(a,lb,e->n_field[0].n_ptr), - e->n_field[1].n_ptr); - free(e); - } - else - t = subsc_nd(lb, a, e); - return t; - } - -/* - * subsc_nd - construct a node for subscripting. - */ -static nodeptr subsc_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for subscripting. - */ - impl = spec_op[SubscOp]; - if (impl == NULL) - nfatal(op, "subscripting not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "subscripting not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * to_nd - construct a node for binary to. - */ -nodeptr to_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to. - */ - impl = spec_op[ToOp]; - if (impl == NULL) - nfatal(op, "'i to j' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j' not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * toby_nd - construct a node for binary to-by. - */ -nodeptr toby_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to-by. - */ - impl = spec_op[ToByOp]; - if (impl == NULL) - nfatal(op, "'i to j by k' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j by k' not installed", NULL); - - t = NewNode(5); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * aug_nd - create a node for an augmented assignment. - */ -nodeptr aug_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - t = NewNode(5); - t->n_type = N_Augop; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) - nfatal(op, "assignment not implemented", NULL); - t->n_field[0].ip = impl; - - /* - * The operator table entry for the augmented assignment is - * immediately after the entry for the operation. - */ - impl = optab[Val0(op) - 1].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", - optab[Val0(op) - 1].tok.t_word); - t->n_field[1].ip = impl; - - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - /* t->n_field[4].typ - type of intermediate result */ - return t; - } - -/* - * sect_nd - create a node for sectioning. - */ -nodeptr sect_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - int tok; - struct implement *impl; - struct implement *impl1; - - t = NewNode(5); - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for sectioning. - */ - impl = spec_op[SectOp]; - if (impl == NULL) - nfatal(op, "sectioning not implemented", NULL); - - tok = optab[Val0(op)].tok.t_type; - if (tok == COLON) { - /* - * Simple sectioning, treat as a ternary operator. - */ - t->n_type = N_InvOp; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - } - else { - /* - * Find the data base entry for addition or subtraction. - */ - if (tok == PCOLON) { - impl1 = optab[plus_loc].binary; - if (impl1 == NULL) - nfatal(op, "addition not implemented", NULL); - } - else { /* MCOLON */ - impl1 = optab[minus_loc].binary; - if (impl1 == NULL) - nfatal(op, "subtraction not implemented", NULL); - } - t->n_type = N_Sect; - t->n_field[0].ip = impl; - t->n_field[1].ip = impl1; - } - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * invk_main - produce an procedure invocation node with one argument for - * use in the initial invocation to main() during type inference. - */ -nodeptr invk_main(main_proc) -struct pentry *main_proc; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = N_InvProc; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* 1 argument */ - t->n_field[1].proc = main_proc; - t->n_field[2].n_ptr = tree1(N_Empty); - - if (max_prm < 1) - max_prm = 1; - return t; - } diff --git a/src/iconc/ctree.h b/src/iconc/ctree.h deleted file mode 100644 index d38d3c4..0000000 --- a/src/iconc/ctree.h +++ /dev/null @@ -1,200 +0,0 @@ -/* - * Structure of a tree node. - */ - -typedef struct node *nodeptr; - -/* - * Kinds of fields in syntax tree node. - */ -union field { - long n_val; /* integer-valued fields */ - char *n_str; /* string-valued fields */ - struct lentry *lsym; /* fields referencing local symbol table entries */ - struct centry *csym; /* fields referencing constant symbol table entries */ - struct implement *ip; /* fields referencing an operation */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ -#ifdef OptimizeType - struct typinfo *typ; /* extra type field */ -#else /* OptimizeType */ - unsigned int *typ; /* extra type field */ -#endif /* OptimizeType */ - nodeptr n_ptr; /* subtree pointers */ - }; - -/* - * A store is an array that maps variables types (which are given indexes) - * to the types stored within the variables. - */ -struct store { - struct store *next; - int perm; /* flag: whether store stays across iterations */ -#ifdef OptimizeType - struct typinfo *types[1]; /* actual size is number of variables */ -#else /* OptimizeType */ - unsigned int *types[1]; /* actual size is number of variables */ -#endif /* OptimizeType */ - }; - -/* - * Array of parameter types for an operation call. - */ -struct symtyps { - int nsyms; /* number of parameter symbols */ - struct symtyps *next; -#ifdef OptimizeType - struct typinfo *types[1]; /* really one for every symbol */ -#else /* OptimizeType */ - unsigned int *types[1]; /* really one for every symbol */ -#endif /* OptimizeType */ - }; - -/* - * definitions for maintaining allocation status. - */ -#define NotAlloc 0 /* temp var neither in use nor reserved */ -#define InUnse 1 /* temp var currently contains live variable */ -/* n < 0 reserved: must be free by node with postn field = n */ - -#define DescTmp 1 /* allocation of descriptor temporary */ -#define CIntTmp 2 /* allocation of C integer temporary */ -#define CDblTmp 3 /* allocation of C double temporary */ -#define SBuf 4 /* allocation of string buffer */ -#define CBuf 5 /* allocation of cset buffer */ - -struct freetmp { /* list of things to free at a node */ - int kind; /* DescTmp, CIntTmp, CDblTmp, SBuf, or CBuf */ - int indx; /* index into status array */ - int old; /* old status */ - struct freetmp *next; - }; - -struct node { - int n_type; /* node type */ - char *n_file; /* name of file containing source program */ - int n_line; /* line number in source program */ - int n_col; /* column number in source program */ - int flag; - int *new_types; /* pntr to array of struct types created here */ -#ifdef OptimizeType - struct typinfo *type; /* type of this expression */ -#else /* OptimizeType */ - unsigned int *type; /* type of this expression */ -#endif /* OptimizeType */ - struct store *store; /* if needed, store saved between iterations */ - struct symtyps *symtyps; /* for operation in data base: types of arg syms */ - nodeptr lifetime; /* lifetime of intermediate result */ - int reuse; /* result may be reused without being recomputed */ - nodeptr intrnl_lftm; /* lifetime of variables internal to operation */ - int postn; /* relative position of node in execution order */ - struct freetmp *freetmp; /* temporary variables to free at this point */ - union field n_field[1]; /* node fields */ - }; - -/* - * NewNode - allocate a parse tree node with "size" fields. - */ -#define NewNode(size) (struct node *)alloc((unsigned int)\ - (sizeof(struct node) + (size-1) * sizeof(union field))) - -/* - * Macros to access fields of parse tree nodes. - */ - -#define Type(t) t->n_type -#define File(t) t->n_file -#define Line(t) t->n_line -#define Col(t) t->n_col -#define Tree0(t) t->n_field[0].n_ptr -#define Tree1(t) t->n_field[1].n_ptr -#define Tree2(t) t->n_field[2].n_ptr -#define Tree3(t) t->n_field[3].n_ptr -#define Tree4(t) t->n_field[4].n_ptr -#define Val0(t) t->n_field[0].n_val -#define Val1(t) t->n_field[1].n_val -#define Val2(t) t->n_field[2].n_val -#define Val3(t) t->n_field[3].n_val -#define Val4(t) t->n_field[4].n_val -#define Str0(t) t->n_field[0].n_str -#define Str1(t) t->n_field[1].n_str -#define Str2(t) t->n_field[2].n_str -#define Str3(t) t->n_field[3].n_str -#define LSym0(t) t->n_field[0].lsym -#define CSym0(t) t->n_field[0].csym -#define Impl0(t) t->n_field[0].ip -#define Impl1(t) t->n_field[1].ip -#define Rec1(t) t->n_field[1].rec -#define Proc1(t) t->n_field[1].proc -#define Typ4(t) t->n_field[4].typ - -/* - * External declarations. - */ - -extern nodeptr yylval; /* parser's current token value */ -extern struct node tok_loc; /* "model" token holding current location */ - -/* - * Node types. - */ - -#define N_Activat 1 /* activation control structure */ -#define N_Alt 2 /* alternation operator */ -#define N_Apply 3 /* procedure application */ -#define N_Augop 4 /* augmented operator */ -#define N_Bar 5 /* generator control structure */ -#define N_Break 6 /* break statement */ -#define N_Case 7 /* case statement */ -#define N_Ccls 8 /* case clause */ -#define N_Clist 9 /* list of case clauses */ -#define N_Create 10 /* create control structure */ -#define N_Cset 11 /* cset literal */ -#define N_Elist 12 /* list of expressions */ -#define N_Empty 13 /* empty expression or statement */ -#define N_Field 14 /* record field reference */ -#define N_Id 15 /* identifier token */ -#define N_If 16 /* if-then-else statement */ -#define N_Int 17 /* integer literal */ -#define N_Invok 18 /* invocation */ -#define N_InvOp 19 /* invoke operation */ -#define N_InvProc 20 /* invoke operation */ -#define N_InvRec 21 /* invoke operation */ -#define N_Limit 22 /* LIMIT control structure */ -#define N_Loop 23 /* while, until, every, or repeat */ -#define N_Next 24 /* next statement */ -#define N_Not 25 /* not prefix control structure */ -#define N_Op 26 /* operator token */ -#define N_Proc 27 /* procedure */ -#define N_Real 28 /* real literal */ -#define N_Res 29 /* reserved word token */ -#define N_Ret 30 /* fail, return, or succeed */ -#define N_Scan 31 /* scan-using statement */ -#define N_Sect 32 /* s[i:j] (section) */ -#define N_Slist 33 /* list of statements */ -#define N_Str 34 /* string literal */ -#define N_SmplAsgn 35 /* simple assignment to named var */ -#define N_SmplAug 36 /* simple assignment to named var */ - -#define AsgnDirect 0 /* rhs of special := can compute directly into var */ -#define AsgnCopy 1 /* special := must copy result into var */ -#define AsgnDeref 2 /* special := must dereference result into var */ - - -/* - * Macros for constructing basic nodes. - */ - -#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) -#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) -#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) -#define OpNode(a) int_leaf(N_Op,&tok_loc,a) -#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) -#define ResNode(a) int_leaf(N_Res,&tok_loc,a) -#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) - -/* - * MultiUnary - create subtree from an operator symbol that represents - * multiple unary operators. - */ -#define MultiUnary(a,b) multiunary(optab[Val0(a)].tok.t_word, a, b) diff --git a/src/iconc/dbase.c b/src/iconc/dbase.c deleted file mode 100644 index fdd3e50..0000000 --- a/src/iconc/dbase.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * dbase.c - routines to access data base of implementation information - * produced by rtt. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes. - */ -static int chck_spec (struct implement *ip); -static int acpt_op (struct implement *ip); - - -static struct optab *optr; /* pointer into operator table */ - -/* - * readdb - read data base produced by rtt. - */ -void readdb(db_name) -char *db_name; - { - char *op, *s; - int i; - struct implement *ip; - char buf[MaxPath]; /* file name construction buffer */ - struct fileparts *fp; - unsigned hashval; - - fp = fparse(db_name); - if (*fp->ext == '\0') - db_name = salloc(makename(buf, NULL, db_name, DBSuffix)); - else if (!smatch(fp->ext, DBSuffix)) - quitf("bad data base name: %s", db_name); - - if (!db_open(db_name, &s)) - db_err1(1, "cannot open data base"); - - if (largeints && (*s == 'N')) { - twarn("Warning, run-time system does not support large integers", NULL); - largeints = 0; - } - - /* - * Read information about functions. - */ - db_tbl("functions", bhash); - - /* - * Read information about operators. - */ - optr = optab; - - /* - * read past operators header. - */ - db_chstr("operators", "operators"); - - while ((op = db_string()) != NULL) { - if ((ip = db_impl('O')) == NULL) - db_err2(1, "no implementation information for operator", op); - ip->op = op; - if (acpt_op(ip)) { - db_code(ip); - hashval = IHasher(op); - ip->blink = ohash[hashval]; - ohash[hashval] = ip; - db_chstr("end", "end"); - } - else - db_dscrd(ip); - } - db_chstr("endsect", "endsect"); - - /* - * Read information about keywords. - */ - db_tbl("keywords", khash); - - db_close(); - - /* - * If error conversion is supported, make sure it is reflected in - * the minimum result sequence of operations. - */ - if (err_conv) { - for (i = 0; i < IHSize; ++i) - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = khash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - } - } - -/* - * acpt_opt - given a data base entry for an operator determine if it - * is in iconc's operator table. - */ -static int acpt_op(ip) -struct implement *ip; - { - register char *op; - register int opcmp; - - /* - * Calls to this function are in lexical order by operator symbol continue - * searching operator table from where we left off. - */ - op = ip->op; - for (;;) { - /* - * optab has augmented assignments out of lexical order. Skip anything - * which does not expect an implementation. This gets augmented - * assignments out of the way. - */ - while (optr->expected == 0 && optr->tok.t_word != NULL) - ++optr; - if (optr->tok.t_word == NULL) - return chck_spec(ip); - opcmp = strcmp(op, optr->tok.t_word); - if (opcmp > 0) - ++optr; - else if (opcmp < 0) - return chck_spec(ip); - else { - if (ip->nargs == 1 && (optr->expected & Unary)) { - if (optr->unary == NULL) { - optr->unary = ip; - return 1; - } - else - return 0; - } - else if (ip->nargs == 2 && (optr->expected & Binary)) { - if (optr->binary == NULL) { - optr->binary = ip; - return 1; - } - else - return 0; - } - else - return chck_spec(ip); - } - } - } - -/* - * chck_spec - check whether the operator is one that does not use standard - * unary or binary syntax. - */ -static int chck_spec(ip) -struct implement *ip; - { - register char *op; - int indx; - - indx = -1; - op = ip->op; - if (strcmp(op, "...") == 0) { - if (ip->nargs == 2) - indx = ToOp; - else - indx = ToByOp; - } - else if (strcmp(op, "[:]") == 0) - indx = SectOp; - else if (strcmp(op, "[]") == 0) - indx = SubscOp; - else if (strcmp(op, "[...]") == 0) - indx = ListOp; - - if (indx == -1) { - db_err2(0, "unexpected operator (or arity),", op); - return 0; - } - if (spec_op[indx] == NULL) { - spec_op[indx] = ip; - return 1; - } - else - return 0; - } diff --git a/src/iconc/fixcode.c b/src/iconc/fixcode.c deleted file mode 100644 index b8c06e0..0000000 --- a/src/iconc/fixcode.c +++ /dev/null @@ -1,372 +0,0 @@ -/* - * fixcode.c - routines to "fix code" by determining what signals are returned - * by continuations and what must be done when they are. Also perform - * optional control flow optimizations. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ccode.h" -#include "ctree.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static struct code *ck_unneed (struct code *cd, struct code *lbl); -static void clps_brch (struct code *branch); -static void dec_refs (struct code *cd); -static void rm_unrch (struct code *cd); - -/* - * fix_fncs - go through the generated C functions, determine how calls - * handle signals, in-line trivial functions where possible, remove - * goto's which immediately precede their labels, and remove unreachable - * code. - */ -void fix_fncs(fnc) -struct c_fnc *fnc; - { - struct code *cd, *cd1; - struct code *contbody; - struct sig_act *sa; - struct sig_lst *sl; - struct code *call; - struct code *create; - struct code *ret_sig; - struct code *sig; - struct c_fnc *calledcont; - int no_break; - int collapse; - - /* - * Fix any called functions and decide how the calls handle the - * returned signals. - */ - fnc->flag |= CF_Mark; - for (call = fnc->call_lst; call != NULL; call = call->NextCall) { - calledcont = call->Cont; - if (calledcont != NULL) { - if (!(calledcont->flag & CF_Mark)) - fix_fncs(calledcont); - if (calledcont->flag & CF_ForeignSig) { - call->Flags |= ForeignSig; - fnc->flag |= CF_ForeignSig; - } - } - - - /* - * Try to collapse call chains of continuations. - */ - if (opt_cntrl && calledcont != NULL) { - contbody = calledcont->cd.next; - if (call->OperName == NULL && contbody->cd_id == C_RetSig) { - /* - * A direct call of a continuation which consists of just a - * return. Replace call with code to handle the returned signal. - */ - ret_sig = contbody->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - cd1->prev = call->prev; - cd1->prev->next = cd1; - cd1->next = call->next; - if (cd1->next != NULL) - cd1->next->prev = cd1; - --calledcont->ref_cnt; - continue; /* move on to next call */ - } - else if (contbody->cd_id == C_CallSig && contbody->next == NULL) { - /* - * The called continuation contains only a call. - */ - if (call->OperName == NULL) { - /* - * We call the continuation directly, so we can in-line it. - * We must replace signal returns with appropriate actions. - */ - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->OperName = contbody->OperName; - call->ArgLst = contbody->ArgLst; - call->Cont = contbody->Cont; - call->Flags = contbody->Flags; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - call->SigActs = new_sgact(sa->sig, cd1, call->SigActs); - } - continue; /* move on to next call */ - } - else if (contbody->OperName == NULL) { - /* - * The continuation simply calls another continuation. We can - * eliminate the intermediate continuation as long as we can - * move signal conversions to the other side of the operation. - * The operation only intercepts resume signals. - */ - collapse = 1; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (sa->sig != ret_sig && (sa->sig == &resume || - ret_sig == &resume)) - collapse = 0; - } - if (collapse) { - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->Cont = contbody->Cont; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig != &resume) - call->SigActs = new_sgact(sa->sig, sig_cd(ret_sig, fnc), - call->SigActs); - } - continue; /* move on to next call */ - } - } - } - } - - /* - * We didn't do any optimizations. We must still figure out - * out how to handle signals returned by the continuation. - */ - if (calledcont != NULL) { - for (sl = calledcont->sig_lst; sl != NULL; sl = sl->next) { - if (sl->ref_cnt > 0) { - sig = sl->sig; - /* - * If an operation is being called, it handles failure from the - * continuation. - */ - if (sig != &resume || call->OperName == NULL) { - if (sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(sig, fnc); - call->SigActs = new_sgact(sig, cd1, call->SigActs); - } - } - } - } - } - - /* - * fix up the signal handling in the functions implementing co-expressions. - */ - for (create = fnc->creatlst; create != NULL; create = create->NextCreat) - fix_fncs(create->Cont); - - if (!opt_cntrl) - return; /* control flow optimizations disabled. */ - /* - * Collapse branch chains and remove unreachable code. - */ - for (cd = &(fnc->cd); cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_CallSig: - no_break = 1; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_Break) { - switch (cd->next->cd_id) { - case C_Goto: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->Lbl = cd->next->Lbl; - ++sa->cd->Lbl->RefCnt; - break; - case C_RetSig: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->SigRef= cd->next->SigRef; - ++sa->cd->SigRef->ref_cnt; - break; - default: - no_break = 0; - } - } - if (sa->cd->cd_id == C_Goto) - clps_brch(sa->cd); - } - if (no_break) - rm_unrch(cd); - /* - * Try converting gotos into breaks. - */ - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - if (sa->cd->cd_id == C_Goto) { - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || - cd1->cd_id == C_RBrack)) { - if (cd1 == sa->cd->Lbl) { - sa->cd->cd_id = C_Break; - --cd1->RefCnt; - break; - } - cd1 = cd1->next; - } - } - break; - - case C_Goto: - clps_brch(cd); - rm_unrch(cd); - if (cd->cd_id == C_Goto) - ck_unneed(cd, cd->Lbl); - break; - - case C_If: - if (cd->ThenStmt->cd_id == C_Goto) { - clps_brch(cd->ThenStmt); - if (cd->ThenStmt->cd_id == C_Goto) - ck_unneed(cd, cd->ThenStmt->Lbl); - } - break; - - case C_PFail: - case C_PRet: - case C_RetSig: - rm_unrch(cd); - break; - } - } - - /* - * If this function only contains a return, indicate that we can - * call a shared signal returning function instead of it. This is - * a special case of "common subROUTINE elimination". - */ - if (fnc->cd.next->cd_id == C_RetSig) - fnc->flag |= CF_SigOnly; - } - -/* - * clps_brch - collapse branch chains. - */ -static void clps_brch(branch) -struct code *branch; - { - struct code *cd; - int save_id; - - cd = branch->Lbl->next; - while (cd->cd_id == C_Label) - cd = cd->next; - - /* - * Avoid infinite recursion on empty infinite loops. - */ - save_id = branch->cd_id; - branch->cd_id = 0; - if (cd->cd_id == C_Goto) - clps_brch(cd); - branch->cd_id = save_id; - - switch (cd->cd_id) { - case C_Goto: - --branch->Lbl->RefCnt; - ++cd->Lbl->RefCnt; - branch->Lbl = cd->Lbl; - break; - case C_RetSig: - /* - * This optimization requires that C_Goto have as many fields - * as C_RetSig. - */ - --branch->Lbl->RefCnt; - ++cd->SigRef->ref_cnt; - branch->cd_id = C_RetSig; - branch->SigRef = cd->SigRef; - break; - } - } - -/* - * rm_unrch - any code after the given point up to the next label is - * unreachable. Remove it. - */ -static void rm_unrch(cd) -struct code *cd; - { - struct code *cd1; - - for (cd1 = cd->next; cd1 != NULL && cd1->cd_id != C_LBrack && - (cd1->cd_id != C_Label || cd1->RefCnt == 0); cd1 = cd1->next) { - if (cd1->cd_id == C_RBrack) { - /* - * Continue deleting past a '}', but don't delete the '}' itself. - */ - cd->next = cd1; - cd1->prev = cd; - cd = cd1; - } - else - dec_refs(cd1); - } - cd->next = cd1; - if (cd1 != NULL) - cd1->prev = cd; - } - -/* - * dec_refs - decrement reference counts for things this code references. - */ -static void dec_refs(cd) -struct code *cd; - { - struct sig_act *sa; - - if (cd == NULL) - return; - switch (cd->cd_id) { - case C_Goto: - --cd->Lbl->RefCnt; - return; - case C_RetSig: - --cd->SigRef->ref_cnt; - return; - case C_CallSig: - if (cd->Cont != NULL) - --cd->Cont->ref_cnt; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - dec_refs(sa->cd); - return; - case C_If: - dec_refs(cd->ThenStmt); - return; - case C_Create: - --cd->Cont->ref_cnt; - return; - } - } - -/* - * ck_unneed - if there is nothing between a goto and its label, except - * perhaps other labels or '}', it is useless, so remove it. - */ -static struct code *ck_unneed(cd, lbl) -struct code *cd; -struct code *lbl; - { - struct code *cd1; - - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || cd1->cd_id == C_RBrack)) { - if (cd1 == lbl) { - cd = cd->prev; - cd->next = cd->next->next; - cd->next->prev = cd; - --lbl->RefCnt; - break; - } - cd1 = cd1->next; - } - return cd; - } - diff --git a/src/iconc/incheck.c b/src/iconc/incheck.c deleted file mode 100644 index d4110f9..0000000 --- a/src/iconc/incheck.c +++ /dev/null @@ -1,802 +0,0 @@ -/* - * incheck.c - analyze a run-time operation using type information. - * Determine wither the operation can be in-lined and what kinds - * of parameter passing optimizations can be done. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct op_symentry *cur_symtab; /* symbol table for current operation */ - -/* - * Prototypes for static functions. - */ -static struct code *and_cond (struct code *cd1, struct code *cd2); -static int cnv_anlz (unsigned int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest, - struct code **cdp); -static int defer_il (struct il_code *il); -static int if_anlz (struct il_code *il); -static void ilc_anlz (struct il_c *ilc); -static int il_anlz (struct il_code *il); -static void ret_anlz (struct il_c *ilc); -static int tc_anlz (struct il_code *il, int has_dflt); - -static int n_branches; /* number branches caused by run-time type checking */ -static int side_effect; /* abstract clause indicates side-effect */ -static int n_vararg; /* size of variable part of arg list to operation */ -static int n_susp; /* number of suspends */ -static int n_ret; /* number of returns */ - -/* - * do_inlin - determine if this operation can be in-lined at the current - * invocation. Also gather information about how arguments are used, - * and determine where the success continuation for the operation - * should be put. - */ -int do_inlin(impl, n, cont_loc, symtab, n_va) -struct implement *impl; -nodeptr n; -int *cont_loc; -struct op_symentry *symtab; -int n_va; - { - int nsyms; - int i; - - /* - * Copy arguments needed by other functions into globals and - * initialize flags and counters for information to be gathered - * during analysis. - */ - cur_symtyps = n->symtyps; /* mapping from arguments to types */ - cur_symtab = symtab; /* parameter info to be filled in */ - n_vararg = n_va; - n_branches = 0; - side_effect = 0; - n_susp = 0; - n_ret = 0; - - /* - * Analyze the code for this operation using type information for - * the arguments to the invocation. - */ - il_anlz(impl->in_line); - - - /* - * Don't in-line if there is more than one decision made based on - * run-time type checks (this is a heuristic). - */ - if (n_branches > 1) - return 0; - - /* - * If the operation (after eliminating code not used in this context) - * has one suspend and no returns, the "success continuation" can - * be placed in-line at the suspend site. Otherwise, any suspends - * require a separate function for the continuation. - */ - if (n_susp == 1 && n_ret == 0) - *cont_loc = SContIL; /* in-line continuation */ - else if (n_susp > 0) - *cont_loc = SepFnc; /* separate function for continuation */ - else - *cont_loc = EndOper; /* place "continuation" after the operation */ - - /* - * When an argument at the source level is an Icon variable, it is - * sometimes safe to use it directly in the generated code as the - * argument to the operation. However, it is NOT safe under the - * following conditions: - * - * - if the operation modifies the argument. - * - if the operation suspends and resumes so that intervening - * changes to the variable would be visible as changes to the - * argument. - * - if the operation has side effects that might involve the - * variable and be visible as changes to the argument. - */ - nsyms = (cur_symtyps == NULL ? 0 : cur_symtyps->nsyms); - for (i = 0; i < nsyms; ++i) - if (symtab[i].n_mods == 0 && n->intrnl_lftm == n && !side_effect) - symtab[i].var_safe = 1; - - return 1; - } - -/* - * il_anlz - analyze a piece of RTL code. Return an indication of - * whether execution can continue beyond it. - */ -static int il_anlz(il) -struct il_code *il; - { - int fall_thru; - int ncases; - int condition; - int indx; - int i, j; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - /* - * if-then statement. Determine whether the condition may - * succeed or fail. Analyze the then clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru = 1; - return fall_thru; - - case IL_If2: - /* - * if-then-else statement. Determine whether the condition may - * succeed or fail. Analyze the "then" clause and the "else" - * clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru |= il_anlz(il->u[2].fld); - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return tc_anlz(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return tc_anlz(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return il_anlz(il->u[indx].fld); /* action */ - ++indx; - } - return il_anlz(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, NULL, - &chk2, NULL); - - /* - * Analyze the selected case (note, large integer code is not - * currently in-lined and can be ignored). - */ - fall_thru = 0; - if (maybe_int) - fall_thru |= il_anlz(il->u[2].fld); /* C_integer action */ - if (maybe_dbl) - fall_thru |= il_anlz(il->u[4].fld); /* C_double action */ - return fall_thru; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - indx = il->u[1].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - return 0; - - case IL_Block: - /* - * inline {...} statement. - */ - i = il->u[1].n + 2; /* skip declaration stuff */ - ilc_anlz(il->u[i].c_cd); /* body of block */ - return il->u[0].n; - - case IL_Call: - /* - * call to body function. - */ - if (il->u[3].n & DoesSusp) - n_susp = 2; /* force continuation into separate function */ - - /* - * Analyze the C code for prototype parameter declarations - * and actual arguments. There are twice as many pieces of - * C code to look at as there are parameters. - */ - j = 2 * il->u[7].n; - i = 8; /* index of first piece of C code */ - while (j--) - ilc_anlz(il->u[i++].c_cd); - return ((il->u[3].n & DoesFThru) != 0); - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = il_anlz(il->u[0].fld); - if (fall_thru) - fall_thru = il_anlz(il->u[1].fld); - return fall_thru; - - case IL_Abstr: - /* - * abstract type computation. See if it indicates side effects. - */ - if (il->u[0].fld != NULL) - side_effect = 1; - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * if_anlz - analyze the condition of an if statement. - */ -static int if_anlz(il) -struct il_code *il; - { - int cond; - int cond1; - - if (il->il_type == IL_Bang) { - /* - * ! <condition>, negate the result of the condition - */ - cond1 = cond_anlz(il->u[0].fld, NULL); - cond = 0; - if (cond1 & MaybeTrue) - cond = MaybeFalse; - if (cond1 & MaybeFalse) - cond |= MaybeTrue; - } - else - cond = cond_anlz(il, NULL); - if (cond == (MaybeTrue | MaybeFalse)) - ++n_branches; /* must make a run-time decision */ - return cond; - } - -/* - * cond_anlz - analyze a simple condition or the conjunction of two - * conditions. If cdp is not NULL, use it to return a pointer code - * that implements the condition. - */ -int cond_anlz(il, cdp) -struct il_code *il; -struct code **cdp; - { - struct code *cd1; - struct code *cd2; - int cond1; - int cond2; - int indx; - - switch (il->il_type) { - case IL_And: - /* - * <cond> && <cond> - */ - cond1 = cond_anlz(il->u[0].fld, (cdp == NULL ? NULL : &cd1)); - if (cond1 & MaybeTrue) { - cond2 = cond_anlz(il->u[1].fld, (cdp == NULL ? NULL : &cd2)); - if (cdp != NULL) { - if (!(cond2 & MaybeTrue)) - *cdp = NULL; - else - *cdp = and_cond(cd1, cd2); - } - return (cond1 & MaybeFalse) | cond2; - } - else { - if (cdp != NULL) - *cdp = cd1; - return cond1; - } - - case IL_Cnv1: - /* - * cnv:<dest-type>(<source>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, NULL, cdp); - - case IL_Cnv2: - /* - * cnv:<dest-type>(<source>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, il->u[2].c_cd, cdp); - - case IL_Def1: - /* - * def:<dest-type>(<source>,<default-value>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, NULL, cdp); - - case IL_Def2: - /* - * def:<dest-type>(<source>,<default-value>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, il->u[3].c_cd, - cdp); - - case IL_Is: - /* - * is:<type-name>(<variable>) - */ - indx = il->u[1].fld->u[0].n; - cond1 = eval_is(il->u[0].n, indx); - if (cdp == NULL) { - if (indx < cur_symtyps->nsyms && cond1 == (MaybeTrue | MaybeFalse)) - ++cur_symtab[indx].n_refs; - } - else { - if (cond1 == (MaybeTrue | MaybeFalse)) - *cdp = typ_chk(il->u[1].fld, il->u[0].n); - else - *cdp = NULL; - } - return cond1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - - -/* - * and_cond - construct && of two conditions, either of which may have - * been optimized away. - */ -static struct code *and_cond(cd1, cd2) -struct code *cd1; -struct code *cd2; - { - struct code *cd; - - if (cd1 == NULL) - return cd2; - else if (cd2 == NULL) - return cd1; - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Ary; - cd->Array(0) = cd1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " && "; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = cd2; - return cd; - } - } - -/* - * cnv_anlz - analyze a type conversion. Determine whether it can succeed - * and, if requested, produce code to perform the conversion. Also - * gather information about the variables it uses. - */ -static int cnv_anlz(typcd, src, dflt, dest, cdp) -unsigned int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; -struct code **cdp; - { - struct val_loc *src_loc; - int cond; - int cnv_flags; - int indx; - - /* - * Find out what is going on in the default and destination subexpressions. - * (The information is used elsewhere.) - */ - ilc_anlz(dflt); - ilc_anlz(dest); - - if (cdp != NULL) - *cdp = NULL; /* clear code pointer in case it is not set below */ - - /* - * Determine whether the conversion may succeed, whether it may fail, - * and whether it may actually convert a value or use the default - * value when it succeeds. - */ - indx = src->u[0].n; /* symbol table index for source of conversion */ - cond = eval_cnv(typcd, indx, dflt != NULL, &cnv_flags); - - /* - * Many optimizations are possible depending on whether a conversion - * is actually needed, whether type checking is needed, whether defaulting - * is done, and whether there is an explicit destination. Several - * optimizations are performed here; more may be added in the future. - */ - if (!(cnv_flags & MayDefault)) - dflt = NULL; /* demote defaulting to simple conversion */ - - if (cond & MaybeTrue) { - if (cnv_flags == MayKeep && dest == NULL) { - /* - * No type conversion, defaulting, or copying is needed. - */ - if (cond & MaybeFalse) { - /* - * A type check is needed. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source. */ - if (cdp != NULL) { - switch (typcd) { - case TypECInt: - *cdp = typ_chk(src, TypCInt); - break; - case TypEInt: - *cdp = typ_chk(src, int_typ); - break; - case TypTStr: - *cdp = typ_chk(src, str_typ); - break; - case TypTCset: - *cdp = typ_chk(src, cset_typ); - break; - default: - *cdp = typ_chk(src, typcd); - } - } - } - - if (cdp != NULL) { - /* - * Conversion from an integer to a C_integer can be done without - * any executable code; this is not considered a real conversion. - * It is accomplished by changing the symbol table so only the - * dword of the descriptor is accessed. - */ - switch (typcd) { - case TypCInt: - case TypECInt: - cur_symtab[indx].loc = loc_cpy(cur_symtab[indx].loc, M_CInt); - break; - } - } - } - else if (dest != NULL && cnv_flags == MayKeep && cond == MaybeTrue) { - /* - * There is an explicit destination, but no conversion, defaulting, - * or type checking is needed. Just copy the value to the - * destination. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source */ - if (cdp != NULL) { - src_loc = cur_symtab[indx].loc; - switch (typcd) { - case TypCInt: - case TypECInt: - /* - * The value is in the dword of the descriptor. - */ - src_loc = loc_cpy(src_loc, M_CInt); - break; - } - *cdp = il_copy(dest, src_loc); - } - } - else if (cnv_flags == MayDefault) { - /* - * The default value is used. - */ - if (dest == NULL) - ++cur_symtab[indx].n_mods; /* modifying reference */ - if (cdp != NULL) - *cdp = il_dflt(typcd, src, dflt, dest); - } - else { - /* - * Produce code to do the actual conversion. - * Determine whether the source location is being modified - * or just referenced. - */ - if (dest == NULL) { - /* - * "In place" conversion. - */ - switch (typcd) { - case TypCDbl: - case TypCInt: - case TypECInt: - /* - * not really converted in-place. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - break; - default: - ++cur_symtab[indx].n_mods; /* modifying reference */ - } - } - else - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - - if (cdp != NULL) - *cdp = il_cnv(typcd, src, dflt, dest); - } - } - return cond; - } - -/* - * ilc_anlz - gather information about in-line C code. - */ -static void ilc_anlz(ilc) -struct il_c *ilc; - { - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - /* - * Non-modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_refs; - } - break; - - case ILC_Mod: - /* - * Modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_mods; - } - break; - - case ILC_Ret: - /* - * Return statement. - */ - ++n_ret; - ret_anlz(ilc); - break; - - case ILC_Susp: - /* - * Suspend statement. - */ - ++n_susp; - ret_anlz(ilc); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - ilc_anlz(ilc->code[0]); - break; - } - ilc = ilc->next; - } - } - -/* - * ret_anlz - gather information about the in-line C code associated - * with a return or suspend. - */ -static void ret_anlz(ilc) -struct il_c *ilc; - { - int i; - int j; - - /* - * See if the code is simply returning a parameter. - */ - if (ilc->n == RetDesc && ilc->code[0]->il_c_type == ILC_Ref && - ilc->code[0]->next == NULL) { - j = ilc->code[0]->n; - ++cur_symtab[j].n_refs; - ++cur_symtab[j].n_rets; - } - else { - for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) - ilc_anlz(ilc->code[i]); - } - } - -/* - * deref_il - dummy routine to pass to a code walk. - */ -/*ARGSUSED*/ -static int defer_il(il) -struct il_code *il; - { - /* - * Called for each case in a type_case statement that might be selected. - * However, the actual analysis of the case, if it is needed, - * is done elsewhere, so just return. - */ - return 0; - } - -/* - * findcases - determine how many cases of an type_case statement may - * be true. If there are two or less, determine the "if" statement - * that can be used (if there are more than two, the code is not - * in-lined). - */ -void findcases(il, has_dflt, case_anlz) -struct il_code *il; -int has_dflt; -struct case_anlz *case_anlz; - { - int i; - - case_anlz->n_cases = 0; - case_anlz->typcd = -1; - case_anlz->il_then = NULL; - case_anlz->il_else = NULL; - i = type_case(il, defer_il, case_anlz); - /* - * See if the explicit cases have accounted for all possible - * types that might be present. - */ - if (i == -1) { /* all types accounted for */ - if (case_anlz->il_else == NULL && case_anlz->il_then != NULL) { - /* - * We don't need to actually check the type. - */ - case_anlz->il_else = case_anlz->il_then; - case_anlz->il_then = NULL; - case_anlz->typcd = -1; - } - } - else { /* not all types accounted for */ - if (case_anlz->il_else != NULL) - case_anlz->n_cases = 3; /* force no inlining */ - else if (has_dflt) - case_anlz->il_else = il->u[i].fld; /* default */ - } - - if (case_anlz->n_cases > 2) - n_branches = 2; /* no in-lining */ - else if (case_anlz->il_then != NULL) - ++n_branches; - } - - -/* - * tc_anlz - analyze a type_case statement. It is only of interest for - * in-lining if it can be reduced to an "if" statement or an - * unconditional statement. - */ -static int tc_anlz(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - int fall_thru; - int indx; - - findcases(il, has_dflt, &case_anlz); - - if (case_anlz.il_else == NULL) - fall_thru = 1; /* either no code at all or condition with no "else" */ - else - fall_thru = 0; /* either unconditional or if-then-else: check code */ - - if (case_anlz.il_then != NULL) { - fall_thru |= il_anlz(case_anlz.il_then); - indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - } - if (case_anlz.il_else != NULL) - fall_thru |= il_anlz(case_anlz.il_else); - return fall_thru; - } - -/* - * arth_anlz - analyze the type checking of an arith_case statement. - */ -void arth_anlz(var1, var2, maybe_int, maybe_dbl, chk1, conv1p, chk2, conv2p) -struct il_code *var1; -struct il_code *var2; -int *maybe_int; -int *maybe_dbl; -int *chk1; -struct code **conv1p; -int *chk2; -struct code **conv2p; - { - int cond; - int cnv_typ; - - - /* - * First do an analysis to find out which cases are needed. This is - * more accurate than analysing the conversions separately, but does - * not get all the information we need. - */ - eval_arith(var1->u[0].n, var2->u[0].n, maybe_int, maybe_dbl); - - if (*maybe_int & (largeints | *maybe_dbl)) { - /* - * Too much type checking; don't bother with these cases. Force no - * in-lining. - */ - n_branches += 2; - } - else { - if (*maybe_int) - cnv_typ = TypCInt; - else - cnv_typ = TypCDbl; - - /* - * See exactly what kinds of conversions/type checks are needed and, - * if requested, generate code for them. - */ - *chk1 = 0; - *chk2 = 0; - - cond = cnv_anlz(cnv_typ, var1, NULL, NULL, conv1p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk1 = 1; - if (var1->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var1->u[0].n].n_refs; /* used in runerr2() */ - } - cond = cnv_anlz(cnv_typ, var2, NULL, NULL, conv2p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk2 = 1; - if (var2->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var2->u[0].n].n_refs; /* used in runerr2() */ - } - } - } diff --git a/src/iconc/inline.c b/src/iconc/inline.c deleted file mode 100644 index 234229c..0000000 --- a/src/iconc/inline.c +++ /dev/null @@ -1,2007 +0,0 @@ -/* - * inline.c - routines to put run-time routines in-line. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ccode.h" -#include "csym.h" -#include "ctree.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes for static functions. - */ -static void arth_arg ( struct il_code *var, - struct val_loc *v_orig, int chk, - struct code *cnv); -static int body_fnc (struct il_code *il); -static void chkforblk (void); -static void cnv_dest (int loc, int is_cstr, - struct il_code *src, int sym_indx, - struct il_c *dest, struct code *cd, int i); -static void dwrd_asgn (struct val_loc *vloc, char *typ); -static struct il_c *line_ilc (struct il_c *ilc); -static int gen_if (struct code *cond_cd, - struct il_code *il_then, - struct il_code *il_else, - struct val_loc **locs); -static int gen_il (struct il_code *il); -static void gen_ilc (struct il_c *il); -static void gen_ilret (struct il_c *ilc); -static int gen_tcase (struct il_code *il, int has_dflt); -static void il_var (struct il_code *il, struct code *cd, - int indx); -static void mrg_locs (struct val_loc **locs); -static struct code *oper_lbl (char *s); -static void part_asgn (struct val_loc *vloc, char *asgn, - struct il_c *value); -static void rstr_locs (struct val_loc **locs); -static struct val_loc **sav_locs (void); -static void sub_ilc (struct il_c *ilc, struct code *cd, int indx); - -/* - * There are many parameters that are shared by multiple routines. There - * are copied into statics. - */ -static struct val_loc *rslt; /* result location */ -static struct code **scont_strt; /* label following operation code */ -static struct code **scont_fail; /* resumption label for in-line suspend */ -static struct c_fnc *cont; /* success continuation */ -static struct implement *impl; /* data base entry for operation */ -static int nsyms; /* number symbols in operation symbol table */ -static int n_vararg; /* size of variable part of arg list */ -static nodeptr intrnl_lftm; /* lifetime of internal variables */ -static struct val_loc **tended; /* array of tended locals */ - -/* - * gen_inlin - generate in-line code for an operation. - */ -void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va) -struct il_code *il; -struct val_loc *r; -struct code **strt; -struct code **fail; -struct c_fnc *c; -struct implement *ip; -int ns; -struct op_symentry *st; -nodeptr n; -int dcl_var; -int n_va; - { - struct code *cd; - struct val_loc *tnd; - int i; - - /* - * Copy arguments in to globals. - */ - rslt = r; - scont_strt = strt; - scont_fail = fail; - cont = c; - impl = ip; - nsyms = ns; - cur_symtab = st; - intrnl_lftm = n->intrnl_lftm; - cur_symtyps = n->symtyps; - n_vararg = n_va; - - /* - * Generate code to initialize local tended descriptors and determine - * how to access the descriptors. - */ - for (i = 0; i < impl->ntnds; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - tnd = chk_alc(NULL, n->intrnl_lftm); - switch (impl->tnds[i].var_type) { - case TndDesc: - cur_symtab[dcl_var].loc = tnd; - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr); - cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name; - break; - } - if (impl->tnds[i].init != NULL) { - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = cur_symtab[dcl_var].loc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - sub_ilc(impl->tnds[i].init, cd, 2); - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - } - ++dcl_var; - } - - /* - * If there are local non-tended variables, generate code for the - * declarations, placing everything in braces. - */ - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_LBrack; /* { */ - cd_add(cd); - for (i = 0; i < impl->nvars; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - gen_ilc(impl->vars[i].dcl); - cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name); - } - ++dcl_var; - } - } - - gen_il(il); /* generate executable code */ - - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_RBrack; /* } */ - cd_add(cd); - } - } - -/* - * gen_il - generate code from a sub-tree of in-line code from the data - * base. Determine if execution can continue past this code. - * - */ -static int gen_il(il) -struct il_code *il; - { - struct code *cd; - struct code *cd1; - struct il_code *il_cond; - struct il_code *il_then; - struct il_code *il_else; - struct il_code *il_t; - struct val_loc **locs; - struct val_loc **locs1; - struct val_loc *tnd; - int fall_thru; - int cond; - int ncases; - int indx; - int ntended; - int i; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - case IL_If2: - /* - * if-then or if-then-else statement. - */ - il_then = il->u[1].fld; - if (il->il_type == IL_If2) - il_else = il->u[2].fld; - else - il_else = NULL; - il_cond = il->u[0].fld; - if (il->u[0].fld->il_type == IL_Bang) { - il_cond = il_cond->u[0].fld; - il_t = il_then; - il_then = il_else; - il_else = il_t; - } - locs = sav_locs(); - cond = cond_anlz(il_cond, &cd1); - if (cond == (MaybeTrue | MaybeFalse)) - fall_thru = gen_if(cd1, il_then, il_else, locs); - else { - if (cd1 != NULL) { - cd_add(cd1); /* condition contains needed conversions */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - if (cond == MaybeTrue) - fall_thru = gen_il(il_then); - else if (cond == MaybeFalse) { - locs1 = sav_locs(); - rstr_locs(locs); - locs = locs1; - fall_thru = gen_il(il_else); - } - mrg_locs(locs); - } - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return gen_tcase(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return gen_tcase(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return gen_il(il->u[indx].fld); /* action */ - ++indx; - } - return gen_il(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - struct val_loc *v_orig1; - struct val_loc *v_orig2; - struct code *cnv1; - struct code *cnv2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - v_orig1 = cur_symtab[var1->u[0].n].loc; /* remember for error msgs */ - v_orig2 = cur_symtab[var2->u[0].n].loc; /* remember for error msgs */ - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1, - &chk2, &cnv2); - - /* - * This statement is in-lined if there is only C integer - * arithmetic, only C double arithmetic, or only a run-time - * error. - */ - arth_arg(var1, v_orig1, chk1, cnv1); - arth_arg(var2, v_orig2, chk2, cnv2); - if (maybe_int) - return gen_il(il->u[2].fld); /* C_integer action */ - else if (maybe_dbl) - return gen_il(il->u[4].fld); /* C_double action */ - else - return 0; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &("; - il_var(il->u[1].fld, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = gen_il(il->u[0].fld); - if (fall_thru) - fall_thru = gen_il(il->u[1].fld); - return fall_thru; - - case IL_Block: - /* - * inline {...} statement. - * - * Allocate and initialize any tended locals. - */ - ntended = il->u[1].n; - if (ntended > 0) - tended = (struct val_loc **)alloc((unsigned int) - sizeof(struct val_loc *) * ntended); - for (i = 2; i - 2 < ntended; ++i) { - tnd = chk_alc(NULL, intrnl_lftm); - tended[i - 2] = tnd; - switch (il->u[i].n) { - case TndDesc: - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - break; - } - } - gen_ilc(il->u[i].c_cd); /* body of block */ - /* - * See if execution can fall through this code. - */ - if (il->u[0].n) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - - case IL_Call: - /* - * call to body function. - */ - return body_fnc(il); - - case IL_Abstr: - /* - * abstract type computation. Only used by type inference. - */ - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - -/* - * arth_arg - in-line code to check a conversion for an arith_case statement. - */ -static void arth_arg(var, v_orig, chk, cnv) -struct il_code *var; -struct val_loc *v_orig; -int chk; -struct code *cnv; - { - struct code *lbl; - struct code *cd; - - if (chk) { - /* - * Must check the conversion. - */ - lbl = oper_lbl("converted"); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - if (cnv != NULL) { - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cnv; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - } - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(102, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = v_orig; /* var location before conversion */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else if (cnv != NULL) { - cd_add(cnv); /* conversion cannot fail */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - } - -/* - * body_fnc - generate code to call a body function. - */ -static int body_fnc(il) -struct il_code *il; - { - struct code *arg_lst; - struct code *cd; - struct c_fnc *cont1; - char *oper_nm; - int ret_val; - int ret_flag; - int need_rslt; - int num_sbuf; - int num_cbuf; - int expl_args; - int arglst_sz; /* size of arg list in number of code pieces */ - int il_indx; - int cd_indx; - int proto_prt; - int i; - - /* - * Determine if a function prototype has been printed yet for this - * body function. - */ - proto_prt = il->u[0].n; - il->u[0].n = 1; - - /* - * Construct the name of the body function. - */ - oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6)); - sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0], - impl->prefix[1], (char)il->u[1].n, impl->name); - - /* - * Extract from the call the flags and other information describing - * the function, then use this information to deduce the arguments - * needed by the function. - */ - ret_val = il->u[2].n; - ret_flag = il->u[3].n; - need_rslt = il->u[4].n; - num_sbuf = il->u[5].n; - num_cbuf = il->u[6].n; - expl_args = il->u[7].n; - - /* - * determine how large the argument list is. - */ - arglst_sz = 2 * expl_args - 1; - if (num_sbuf > 0) - arglst_sz += 3; - if (num_cbuf > 0) - arglst_sz += 2; - if (need_rslt) - arglst_sz += 3; - if (arglst_sz > 0) - arg_lst = alc_ary(arglst_sz); - else - arg_lst = alc_ary(0); - - if (!proto_prt) { - /* - * Determine whether the body function returns a C integer, double, - * no value, or a signal. - */ - switch (ret_val) { - case RetInt: - fprintf(inclfile, "C_integer %s (", oper_nm); - break; - case RetDbl: - fprintf(inclfile, "double %s (", oper_nm); - break; - case RetNoVal: - fprintf(inclfile, "void %s (", oper_nm); - break; - case RetSig: - fprintf(inclfile, "int %s (", oper_nm); - break; - } - } - - /* - * Produce prototype and code for the explicit arguments in the - * function call. Note that the call entry contains C code for both. - */ - il_indx = 8; - cd_indx = 0; - while (expl_args--) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - if (!proto_prt) - fprintf(inclfile, "%s", il->u[il_indx].c_cd->s); /* parameter dcl */ - ++il_indx; - sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++); - } - - /* - * If string buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_sbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; - arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_SBuf; - arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]"); - ++cd_indx; - } - - /* - * If cset buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_cbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_CBuf; - arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "struct b_cset *r_cbuf"); - ++cd_indx; - } - - /* - * See if the function needs a pointer to the result location - * of the operation. - */ - if (need_rslt) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; /* location of result */ - arg_lst->Str(cd_indx) = "&"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_ValLoc; - arg_lst->ValLoc(cd_indx) = rslt; - if (!proto_prt) - fprintf(inclfile, "dptr rslt"); - ++cd_indx; - } - - if (!proto_prt) { - /* - * The last possible argument is the success continuation. - * If there are no arguments, indicate this in the prototype. - */ - if (ret_flag & DoesSusp) { - if (cd_indx > 0) - fprintf(inclfile, ", "); - fprintf(inclfile, "continuation succ_cont"); - } - else if (cd_indx == 0) - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - } - - /* - * Does this call need the success continuation for the operation. - */ - if (ret_flag & DoesSusp) - cont1 = cont; - else - cont1 = NULL; - - switch (ret_val) { - case RetInt: - /* - * The body function returns a C integer. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.integr = "; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Integer"); - cd_add(mk_goto(*scont_strt)); - break; - case RetDbl: - /* - * The body function returns a C double. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = "));"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - cd_add(mk_goto(*scont_strt)); - break; - case RetNoVal: - /* - * The body function does not directly return a value. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = oper_nm; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "("; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = arg_lst; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail))) - cd_add(sig_cd(on_failure, cur_fnc)); - else if (ret_flag & DoesRet) - cd_add(mk_goto(*scont_strt)); - break; - case RetSig: - /* - * The body function returns a signal. - */ - callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt)); - break; - } - /* - * See if execution can fall through this call. - */ - if (ret_flag & DoesFThru) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - } - - -/* - * il_var - generate code for a possibly subscripted variable into - * an element of a code array. - */ -static void il_var(il, cd, indx) -struct il_code *il; -struct code *cd; -int indx; - { - struct code *cd1; - - if (il->il_type == IL_Subscr) { - /* - * Subscripted variable. - */ - cd1 = cd; - cd = alc_ary(4); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = il->u[1].n; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "]"; - } - - /* - * See if this is the result location of the operation or an ordinary - * variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (il->u[0].n == RsltIndx) - cd->ValLoc(indx) = rslt; - else - cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc; - } - -/* - * part_asgn - generate code for an assignment to (part of) a descriptor. - */ -static void part_asgn(vloc, asgn, value) -struct val_loc *vloc; -char *asgn; -struct il_c *value; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = asgn; - sub_ilc(value, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * dwrd_asgn - generate code to assign a type code to the dword of a descriptor. - */ -static void dwrd_asgn(vloc, typ) -struct val_loc *vloc; -char *typ; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_"; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = typ; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * sub_ilc - generate code from a sequence of C code and place it - * in a slot in a code array. - */ -static void sub_ilc(ilc, cd, indx) -struct il_c *ilc; -struct code *cd; -int indx; - { - struct il_c *ilc1; - struct code *cd1; - int n; - - /* - * Count the number of pieces of C code to process. - */ - n = 0; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) - ++n; - - /* - * If there is only one piece of code, place it directly in the - * slot of the array. Otherwise allocate a sub-array and place it - * in the slot. - */ - if (n > 1) { - cd1 = cd; - cd = alc_ary(n); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - } - - while (ilc != NULL) { - switch (ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(indx) = rslt; - else { - if (ilc->s == NULL) - cd->ValLoc(indx) = cur_symtab[ilc->n].loc; - else { - /* - * Access the entire descriptor. - */ - cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None); - } - } - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - cd->ValLoc(indx) = tended[ilc->n]; - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(indx) = A_Str; - cd->Str(indx) = ilc->s; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(indx) = A_SBuf; - cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(indx) = A_CBuf; - cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm); - break; - - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - ++indx; - } - - } - -/* - * gen_ilret - generate code to set the result value from a suspend or - * return. - */ -static void gen_ilret(ilc) -struct il_c *ilc; - { - struct il_c *ilc0; - struct code *cd; - char *cap_id; - int typcd; - - if (rslt == &ignore) - return; /* Don't bother computing the result; it's never used */ - - ilc0 = ilc->code[0]; - typcd = ilc->n; - - if (typcd < 0) { - /* - * RTL returns that do not look like function calls to standard Icon - * type name. - */ - switch (typcd) { - case TypCInt: - /* - * return/suspend C_integer <expr>; - */ - part_asgn(rslt, ".vword.integr = ", ilc0); - dwrd_asgn(rslt, "Integer"); - break; - case TypCDbl: - /* - * return/suspend C_double <expr>; - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - break; - case TypCStr: - /* - * return/suspend C_string <expr>; - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "AsgnCStr("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); /* <expr> */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - break; - case RetDesc: - /* - * return/suspend <expr>; - */ - part_asgn(rslt, " = ", ilc0); - break; - case RetNVar: - /* - * return/suspend named_var(<desc-pntr>); - */ - part_asgn(rslt, ".vword.descptr = ", ilc0); - dwrd_asgn(rslt, "Var"); - break; - case RetSVar: - /* - * return/suspend struct_var(<desc-pntr>, <block_pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]); - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)"; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = " - (word *)"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = rslt; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ".vword.descptr);"; - cd_add(cd); - break; - case RetNone: - /* - * return/suspend result; - * - * Result already set, do nothing. - */ - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - else { - /* - * RTL returns that look like function calls to standard Icon type - * names. - */ - cap_id = icontypes[typcd].cap_id; - switch (icontypes[typcd].rtl_ret) { - case TRetBlkP: - /* - * return/suspend <type>(<block-pntr>); - */ - part_asgn(rslt, ".vword.bptr = (union block *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetDescP: - /* - * return/suspend <type>(<descriptor-pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCharP: - /* - * return/suspend <type>(<char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = (char *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCInt: - /* - * return/suspend <type>(<integer>); - */ - part_asgn(rslt, ".vword.integr = (word)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetSpcl: - /* - * RTL returns that look like function calls to standard type - * names but take more than one argument. - */ - if (typcd == str_typ) { - /* - * return/suspend string(<len>, <char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = ", ilc->code[1]); - part_asgn(rslt, ".dword = ", ilc0); - } - else if (typcd == stv_typ) { - /* - * return/suspend substr(<desc-pntr>, <start>, <len>); - */ - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "SubStr(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - sub_ilc(ilc->code[2], cd, 5); - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ", "; - sub_ilc(ilc->code[1], cd, 7); - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - chkforblk(); /* make sure the block allocation succeeded */ - } - else { - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - } - -/* - * chkforblk - generate code to make sure the allocation of a block - * for the result descriptor was successful. - */ -static void chkforblk() - { - struct code *cd; - struct code *cd1; - struct code *lbl; - - lbl = alc_lbl("got allocation", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rslt; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").vword.bptr != NULL"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(307, NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - -/* - * gen_ilc - generate code for an sequence of in-line C code. - */ -static void gen_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct code *cd; - struct code *cd1; - struct code *lbl1; - struct code *fail_sav; - struct code **lbls; - int max_lbl; - int i; - - /* - * Determine how many labels there are in the code and allocate an - * array to map from label numbers to labels in the code. - */ - max_lbl = -1; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) { - switch(ilc1->il_c_type) { - case ILC_CGto: - case ILC_Goto: - case ILC_Lbl: - if (ilc1->n > max_lbl) - max_lbl = ilc1->n; - } - } - ++max_lbl; /* adjust for 0 indexing */ - if (max_lbl > 0) { - lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) * - max_lbl); - for (i = 0; i < max_lbl; ++i) - lbls[i] = NULL; - } - - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - /* - * The beginning of a sequence of code fragments that can be - * place on one line. - */ - ilc = line_ilc(ilc); - break; - - case ILC_Fail: - /* - * fail - perform failure action. - */ - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_EFail: - /* - * errorfail - same as fail if error conversion is supported. - */ - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_Ret: - /* - * return - set result location and jump out of operation. - */ - gen_ilret(ilc); - cd_add(mk_goto(*scont_strt)); - break; - - case ILC_Susp: - /* - * suspend - set result location. If there is a success - * continuation, call it. Otherwise the "continuation" - * will be generated in-line, so set up a resumption label. - */ - gen_ilret(ilc); - if (cont == NULL) - *scont_strt = cur_fnc->cursor; - lbl1 = oper_lbl("end suspend"); - cd_add(lbl1); - if (cont == NULL) - *scont_fail = lbl1; - else { - cur_fnc->cursor = lbl1->prev; - fail_sav = on_failure; - on_failure = lbl1; - callc_add(cont); - on_failure = fail_sav; - cur_fnc->cursor = lbl1; - } - break; - - case ILC_LBrc: - /* - * non-deletable '{' - */ - cd = NewCode(0); - cd->cd_id = C_LBrack; - cd_add(cd); - break; - - case ILC_RBrc: - /* - * non-deletable '}' - */ - cd = NewCode(0); - cd->cd_id = C_RBrack; - cd_add(cd); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - sub_ilc(ilc->code[0], cd1, 0); - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbls[i]); - cd_add(cd); - break; - - case ILC_Goto: - /* - * Goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(mk_goto(lbls[i])); - break; - - case ILC_Lbl: - /* - * Label. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(lbls[i]); - break; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - } - - if (max_lbl > 0) - free((char *)lbls); - } - -/* - * line_ilc - gather a line of in-line code. - */ -static struct il_c *line_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct il_c *last; - struct code *cd; - int n; - int i; - - /* - * Count the number of pieces in the line. Determine the last - * piece in the sequence; this is returned to the caller. - */ - n = 0; - ilc1 = ilc; - while (ilc1 != NULL) { - switch(ilc1->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - ++n; - last = ilc1; - ilc1 = ilc1->next; - break; - default: - ilc1 = NULL; - } - } - - /* - * Construct the line. - */ - cd = alc_ary(n); - for (i = 0; i < n; ++i) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(i) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(i) = rslt; - else - cd->ValLoc(i) = cur_symtab[ilc->n].loc; - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = tended[ilc->n]; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(i) = A_SBuf; - cd->Intgr(i) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(i) = A_CBuf; - cd->Intgr(i) = alc_cbufs(1, intrnl_lftm); - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(i) = A_Str; - cd->Str(i) = ilc->s; - break; - - default: - ilc = NULL; - } - ilc = ilc->next; - } - - cd_add(cd); - return last; - } - -/* - * generate code to perform simple type checking. - */ -struct code *typ_chk(var, typcd) -struct il_code *var; -int typcd; - { - struct code *cd; - - if (typcd == int_typ && largeints) { - /* - * Handle large integer support specially. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer || ("; - il_var(var, cd, 3); /* value */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ").dword == D_Lrgint)"; - return cd; - } - else if (typcd < 0) { - /* - * Not a standard Icon type name. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - switch (typcd) { - case TypVar: - cd->Str(0) = "((("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & D_Var) == D_Var)"; - break; - case TypCInt: - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer)"; - break; - } - } - else if (typcd == str_typ) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(!(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & F_Nqual))"; - } - else { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_"; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = icontypes[typcd].cap_id; /* type name */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")"; - } - - return cd; - } - -/* - * oper_lbl - generate a label with an associated comment that includes - * the operation name. - */ -static struct code *oper_lbl(s) -char *s; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3)); - sprintf(sbuf, "%s: %s", s, impl->name); - return alc_lbl(sbuf, 0); - } - -/* - * sav_locs - save the current interpretation of symbols that may - * be affected by conversions. - */ -static struct val_loc **sav_locs() - { - struct val_loc **locs; - int i; - - if (nsyms == 0) - return NULL; - - locs = (struct val_loc **)alloc((unsigned int)(nsyms * - sizeof(struct val_loc *))); - for (i = 0; i < nsyms; ++i) - locs[i] = cur_symtab[i].loc; - return locs; - } - -/* - * rstr_locs - restore the interpretation of symbols that may - * have been affected by conversions. - */ -static void rstr_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * mrg_locs - merge the interpretations of symbols along two execution - * paths. Any ambiguity is caught by rtt, so differences only occur - * if one path involves program termination so that the symbols - * no longer have an interpretation along that path. - */ -static void mrg_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - if (cur_symtab[i].loc == NULL) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * il_cnv - generate code for an in-line conversion. - */ -struct code *il_cnv(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - struct code *cd1; - int dflt_to_ptr; - int loc; - int is_cstr; - int sym_indx; - int n; - int i; - - sym_indx = src->u[0].n; - - /* - * Determine whether the address must be taken of a default value and - * whether the interpretation of the symbol in an in-place conversion - * changes. - */ - dflt_to_ptr = 0; - loc = PrmTend; - is_cstr = 0; - switch (typcd) { - case TypCInt: - case TypECInt: - loc = PrmInt; - break; - case TypCDbl: - loc = PrmDbl; - break; - case TypCStr: - is_cstr = 1; - break; - case TypEInt: - break; - case TypTStr: - case TypTCset: - dflt_to_ptr = 1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ || typcd == str_typ) - dflt_to_ptr = 1; - break; - } - - if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon real to C double. Just copy the C value - * from the block. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(GetReal(&("; - il_var(src, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "), "; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypCDbl && !largeints && - !(eval_is(int_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon integer (not large integer) to C double. - * Do as a C conversion by an assigment. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = IntVal( "; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - /* - * Note that cnv_dest() must be called after the source is output - * in case it changes the location of the parameter. - */ - il_var(src, cd, 3); - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1); - } - else { - /* - * Compute the number of code fragments required to construct the - * call to the conversion routine. - */ - n = 7; - if (dflt != NULL) - n += 2; - - cd = alc_ary(n); - - /* - * The names of simple conversions are distinguished from defaulting - * conversions by a prefix of "cnv_" or "def_". - */ - cd->ElemTyp(0) = A_Str; - if (dflt == NULL) - cd->Str(0) = "cnv_"; - else - cd->Str(0) = "def_"; - - /* - * Determine the name of the conversion routine. - */ - cd->ElemTyp(1) = A_Str; /* may be overridden */ - switch (typcd) { - case TypCInt: - cd->Str(1) = "c_int(&("; - break; - case TypCDbl: - cd->Str(1) = "c_dbl(&("; - break; - case TypCStr: - cd->Str(1) = "c_str(&("; - break; - case TypEInt: - cd->Str(1) = "eint(&("; - break; - case TypECInt: - cd->Str(1) = "ec_int(&("; - break; - case TypTStr: - /* - * Allocate a string buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tstr("; - cd1->ElemTyp(1) = A_SBuf; - cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (&"; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - case TypTCset: - /* - * Allocate a cset buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tcset("; - cd1->ElemTyp(1) = A_CBuf; - cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &("; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ) - cd->Str(1) = "cset(&("; - else if (typcd == real_typ) - cd->Str(1) = "real(&("; - else if (typcd == int_typ) - cd->Str(1) = "int(&("; - else if (typcd == str_typ) - cd->Str(1) = "str(&("; - break; - } - - il_var(src, cd, 2); - - cd->ElemTyp(3) = A_Str; - if (dflt != NULL && dflt_to_ptr) - cd->Str(3) = "), &("; - else - cd->Str(3) = "), "; - - - /* - * Determine if this conversion has a default value. - */ - i = 4; - if (dflt != NULL) { - sub_ilc(dflt, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - if (dflt_to_ptr) - cd->Str(i) = "), "; - else - cd->Str(i) = ", "; - ++i; - } - - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "&("; - ++i; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "))"; - } - return cd; - } - -/* - * il_dflt - generate code for a defaulting conversion that always defaults. - */ -struct code *il_dflt(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - int sym_indx; - - sym_indx = src->u[0].n; - - if (typcd == TypCDbl) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCInt || typcd == TypECInt) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypTStr || typcd == str_typ) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCStr) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(AsgnCStr("; - cnv_dest(0, 1, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypTCset || typcd == cset_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)&"; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Cset, 1)"; - } - else if (typcd == TypEInt || typcd == int_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(IntVal("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Integer, 1)"; - } - else if (typcd == real_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "((BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)alcreal("; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")) == NULL ? (fatalerr(0,NULL), 0) : ("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Real, 1))"; - } - - return cd; - } - -/* - * cnv_dest - output the destination of a conversion. - */ -static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i) -int loc; -int is_cstr; -struct il_code *src; -int sym_indx; -struct il_c *dest; -struct code *cd; -int i; - { - if (dest == NULL) { - /* - * Convert "in place", changing the location of a parameter if needed. - */ - switch (loc) { - case PrmInt: - if (cur_symtab[sym_indx].itmp_indx < 0) - cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm); - cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx); - break; - case PrmDbl: - if (cur_symtab[sym_indx].dtmp_indx < 0) - cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm); - cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx); - break; - } - il_var(src, cd, i); - if (is_cstr) - cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr); - } - else { - if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL && - dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) { - /* - * We are converting to a C string. The destination variable - * is not defined as a simple descriptor, but must be accessed - * as such for this conversion. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None); - } - else - sub_ilc(dest, cd, i); - } - - } - -/* - * il_copy - produce code for an optimized "conversion" that always succeeds - * and just copies a value from one place to another. - */ -struct code *il_copy(dest, src) -struct il_c *dest; -struct val_loc *src; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - sub_ilc(dest, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = src; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - return cd; - } - -/* - * loc_cpy - make a copy of a reference to a value location, but change - * the way the location is accessed. - */ -struct val_loc *loc_cpy(loc, mod_access) -struct val_loc *loc; -int mod_access; - { - struct val_loc *new_loc; - - if (loc == NULL) - return NULL; - new_loc = NewStruct(val_loc); - *new_loc = *loc; - new_loc->mod_access = mod_access; - return new_loc; - } - -/* - * gen_tcase - generate in-line code for a type_case statement. - */ -static int gen_tcase(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - - /* - * We can only get here if the type_case statement can be implemented - * with a no more than one type check. Determine how simple the - * code can be. - */ - findcases(il, has_dflt, &case_anlz); - if (case_anlz.il_then == NULL) { - if (case_anlz.il_else == NULL) - return 1; - else - return gen_il(case_anlz.il_else); - } - else - return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then, - case_anlz.il_else, sav_locs()); - } - -/* - * gen_if - generate code to test a condition that might be true - * of false. Determine if execution can continue past this if statement. - */ -static int gen_if(cond_cd, il_then, il_else, locs) -struct code *cond_cd; -struct il_code *il_then; -struct il_code *il_else; -struct val_loc **locs; - { - struct val_loc **locs1; - struct code *lbl_then; - struct code *lbl_end; - struct code *else_loc; - struct code *cd; - int fall_thru; - - lbl_then = oper_lbl("then"); - lbl_end = oper_lbl("end if"); - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cond_cd; - cd->ThenStmt = mk_goto(lbl_then); - cd_add(cd); - else_loc = cur_fnc->cursor; - cd_add(lbl_then); - fall_thru = gen_il(il_then); - cd_add(lbl_end); - locs1 = sav_locs(); - rstr_locs(locs); - cur_fnc->cursor = else_loc; /* go back for the else clause */ - fall_thru |= gen_il(il_else); - cd_add(mk_goto(lbl_end)); - cur_fnc->cursor = lbl_end; - mrg_locs(locs1); - return fall_thru; - } diff --git a/src/iconc/ivalues.c b/src/iconc/ivalues.c deleted file mode 100644 index 4fbb288..0000000 --- a/src/iconc/ivalues.c +++ /dev/null @@ -1,51 +0,0 @@ -/* - * ivalues.c - routines for manipulating Icon values. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - - -/* - * iconint - convert the string representation of an Icon integer to a C long. - * Return -1 if the number is too big and large integers are supported. - */ -long iconint(image) -char *image; - { - register int c; - register int r; - register char *s; - long n, n1; - int overflow; - - s = image; - overflow = 0; - n = 0L; - while ((c = *s++) >= '0' && c <= '9') { - n1 = n * 10 + (c - '0'); - if (n != n1 / 10) - overflow = 1; - n = n1; - } - if (c == 'r' || c == 'R') { - r = n; - n = 0L; - while ((c = *s++) != '\0') { - n1 = n * r + tonum(c); - if (n != n1 / r) - overflow = 1; - n = n1; - } - } - if (overflow) - if (largeints) - n = -1; - else - tfatal("large integer option required", image); - return n; - } diff --git a/src/iconc/lifetime.c b/src/iconc/lifetime.c deleted file mode 100644 index 9a4a7b5..0000000 --- a/src/iconc/lifetime.c +++ /dev/null @@ -1,496 +0,0 @@ -/* - * lifetime.c - perform liveness analysis to determine lifetime of intermediate - * results. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static void arg_life (nodeptr n, long min_result, long max_result, - int resume, int frst_arg, int nargs, nodeptr resumer, - nodeptr *failer, int *gen); - -static int postn = -1; /* relative position in execution order (all neg) */ - -/* - * liveness - compute lifetimes of intermediate results. - */ -void liveness(n, resumer, failer, gen) -nodeptr n; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - struct loop { - nodeptr resumer; - int gen; - nodeptr lifetime; - int every_cntrl; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop = NULL; - nodeptr failer1; - nodeptr failer2; - int gen1 = 0; - int gen2 = 0; - struct node *cases; - struct node *clause; - long min_result; /* minimum result sequence length */ - long max_result; /* maximum result sequence length */ - int resume; /* flag - resumption possible after last result */ - - n->postn = postn--; - - switch (n->n_type) { - case N_Activat: - /* - * Activation can fail or succeed. - */ - arg_life(n, 0L, 1L, 0, 1, 2, resumer, failer, gen); - break; - - case N_Alt: - Tree1(n)->lifetime = n->lifetime; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, &failer2, &gen2); - liveness(Tree0(n), resumer, &failer1, &gen1); - *failer = failer2; - *gen = 1; - break; - - case N_Apply: - /* - * Assume operation can suspend or fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 0, 2, resumer, failer, gen); - break; - - case N_Augop: - /* - * Impl0(n) is assignment. Impl1(n) is the augmented operation. - */ - min_result = Impl0(n)->min_result * Impl1(n)->min_result; - max_result = Impl0(n)->max_result * Impl1(n)->max_result; - resume = Impl0(n)->resume | Impl1(n)->resume; - arg_life(n, min_result, max_result, resume, 2, 2, resumer, failer, - gen); - break; - - case N_Bar: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, failer, &gen1); - *gen = 1; - break; - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return; - } - Tree0(n)->lifetime = cur_loop->lifetime; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - liveness(Tree0(n), loop_sav->resumer, &failer1, &gen1); - cur_loop = loop_sav; - cur_loop->gen |= gen1; - *failer = NULL; - *gen = 0; - break; - - case N_Case: - *failer = resumer; - *gen = 0; - - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * Body. - */ - Tree1(clause)->lifetime = n->lifetime; - liveness(Tree1(clause), resumer, &failer2, &gen2); - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - - /* - * The expression being compared can be resumed. - */ - Tree0(clause)->lifetime = clause; - liveness(Tree0(clause), clause, &failer1, &gen1); - } - - if (Tree2(n) == NULL) { - if (resumer == NULL) - *failer = n; - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* default */ - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - } - - /* - * control clause is bounded - */ - Tree0(n)->lifetime = n; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Create: - Tree0(n)->lifetime = n; - loop_sav = cur_loop; - cur_loop = NULL; /* check for invalid break and next */ - liveness(Tree0(n), n, &failer1, &gen1); - cur_loop = loop_sav; - *failer = NULL; - *gen = 0; - break; - - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Real: - case N_Str: - *failer = resumer; - *gen = 0; - break; - - case N_Field: - Tree0(n)->lifetime = n; - liveness(Tree0(n), resumer, failer, gen); - break; - - case N_If: - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - if (Tree2(n)->n_type != N_Empty) { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); - if (failer2 != NULL) { - if (*failer == NULL) - *failer = failer2; - else { - if ((*failer)->postn < failer2->postn) - *failer = failer2; - if ((*failer)->postn < n->postn) - *failer = n; - } - } - *gen |= gen2; - } - /* - * control clause is bounded - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (Tree2(n)->n_type == N_Empty && failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Invok: - /* - * Assume operation can suspend and fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 1, Val0(n) + 1, resumer, failer, gen); - break; - - case N_InvOp: - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, Val0(n), resumer, failer, gen); - break; - - case N_InvProc: - if (Proc1(n)->ret_flag & DoesFail) - min_result = 0L; - else - min_result = 1L; - if (Proc1(n)->ret_flag & DoesSusp) { - max_result = UnbndSeq; - resume = 1; - } - else { - max_result = 1L; - resume = 0; - } - arg_life(n, min_result, max_result, resume, 2, Val0(n), resumer, - failer, gen); - break; - - case N_InvRec: - arg_life(n, err_conv ? 0L : 1L, 1L, 1, 2, Val0(n), resumer, failer, - gen); - break; - - case N_Limit: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, &failer1, &gen1); - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer1 == NULL ? n : failer1, &failer2, &gen2); - *failer = failer2; - *gen = gen1 | gen2; - break; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.resumer = resumer; - loop_info.gen = 0; - loop_info.every_cntrl = 0; - loop_info.lifetime = n->lifetime; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case REPEAT: - /* - * The body is bounded. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - - case SUSPEND: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = n; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case WHILE: - case UNTIL: - /* - * The body and the control clause are each bounded. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer1, &gen1); - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - } - *failer = (resumer == NULL ? n : resumer); /* assume a loop can fail */ - *gen = cur_loop->gen; - cur_loop = cur_loop->prev; - } - break; - - case N_Next: - if (cur_loop == NULL) { - nfatal(n, "invalid context for next", NULL); - return; - } - if (cur_loop->every_cntrl) - *failer = n; - else - *failer = NULL; - *gen = 0; - break; - - case N_Not: - /* - * The expression is bounded. - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - *failer = (resumer == NULL ? n : resumer); - *gen = 0; - break; - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - /* - * The expression is bounded. - */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), NULL, &failer1, &gen1); - } - *failer = NULL; - *gen = 0; - break; - - case N_Scan: { - struct implement *asgn_impl; - - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - asgn_impl = optab[asgn_loc].binary; - arg_life(n, asgn_impl->min_result, asgn_impl->max_result, - asgn_impl->resume, 1, 2, resumer, failer, gen); - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* body */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer2, &failer1, &gen1); /* subject */ - *failer = failer1; - *gen = gen1 | gen2; - } - } - break; - - case N_Sect: - /* - * Impl0(n) is sectioning. - */ - min_result = Impl0(n)->min_result; - max_result = Impl0(n)->max_result; - resume = Impl0(n)->resume; - if (Impl1(n) != NULL) { - /* - * Impl1(n) is plus or minus. - */ - min_result *= Impl1(n)->min_result; - max_result *= Impl1(n)->max_result; - resume |= Impl1(n)->resume; - } - arg_life(n, min_result, max_result, resume, 2, 3, resumer, failer, - gen); - break; - - case N_Slist: - /* - * expr1 is not bounded, expr0 is bounded. - */ - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - break; - - case N_SmplAsgn: - Tree3(n)->lifetime = n; - liveness(Tree3(n), resumer, failer, gen); /* 2nd operand */ - Tree2(n)->lifetime = n->lifetime; /* may be result of := */ - liveness(Tree2(n), *failer, &failer1, &gen1); /* 1st operand */ - break; - - case N_SmplAug: - /* - * Impl1(n) is the augmented operation. - */ - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, 2, resumer, failer, gen); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * arg_life - compute the lifetimes of an argument list. - */ -static void arg_life(n, min_result, max_result, resume, frst_arg, nargs, - resumer, failer, gen) -nodeptr n; -long min_result; /* minimum result sequence length */ -long max_result; /* maximum result sequence length */ -int resume; /* flag - resumption possible after last result */ -int frst_arg; -int nargs; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - nodeptr failer1; - nodeptr failer2; - nodeptr lifetime; - int inv_fail; /* failure after operation in invoked */ - int reuse; - int gen2; - int i; - - /* - * Determine what, if anything, can resume the rightmost argument. - */ - if (resumer == NULL && min_result == 0) - failer1 = n; - else - failer1 = resumer; - if (failer1 == NULL) - inv_fail = 0; - else - inv_fail = 1; - - /* - * If the operation can be resumed, variables internal to the operation - * have and extended lifetime. - */ - if (resumer != NULL && (max_result > 1 || max_result == UnbndSeq || resume)) - n->intrnl_lftm = resumer; - else - n->intrnl_lftm = n; - - /* - * Go through the parameter list right to left, propagating resumption - * information, computing lifetimes, and determining whether anything - * can generate. - */ - lifetime = n; - reuse = 0; - *gen = 0; - for (i = frst_arg + nargs - 1; i >= frst_arg; --i) { - n->n_field[i].n_ptr->lifetime = lifetime; - n->n_field[i].n_ptr->reuse = reuse; - liveness(n->n_field[i].n_ptr, failer1, &failer2, &gen2); - if (resumer != NULL && gen2) - lifetime = resumer; - if (inv_fail && gen2) - reuse = 1; - failer1 = failer2; - *gen |= gen2; - } - *failer = failer1; - if (max_result > 1 || max_result == UnbndSeq) - *gen = 1; - } diff --git a/src/iconc/types.c b/src/iconc/types.c deleted file mode 100644 index cd3a3ef..0000000 --- a/src/iconc/types.c +++ /dev/null @@ -1,893 +0,0 @@ -/* - * typinfer.c - routines to perform type inference. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" -#ifdef TypTrc -#ifdef HighResTime -#include <sys/time.h> -#include <sys/resource.h> -#endif /* HighResTime */ -#endif /* TypTrc */ - -extern unsigned int null_bit; /* bit for null type */ -extern unsigned int str_bit; /* bit for string type */ -extern unsigned int cset_bit; /* bit for cset type */ -extern unsigned int int_bit; /* bit for integer type */ -extern unsigned int real_bit; /* bit for real type */ -extern unsigned int n_icntyp; /* number of non-variable types */ -extern unsigned int n_intrtyp; /* number of types in intermediate values */ -extern unsigned int val_mask; /* mask for non-var types in last int of type*/ -extern struct typ_info *type_array; - -/* - * free_struct_typinfo - frees a struct typinfo structure by placing - * it one a list of free structures - */ -#ifdef OptimizeType -extern struct typinfo *start_typinfo; -extern struct typinfo *high_typinfo; -extern struct typinfo *low_typinfo; -extern struct typinfo *free_typinfo; - -void free_struct_typinfo(struct typinfo *typ) { - - typ->bits = (unsigned int *)free_typinfo; - free_typinfo = typ; -} -#endif /* OptimizeType */ - -/* - * alloc_typ - allocate a compressed type structure and initializes - * the members to zero or NULL. - */ -#ifdef OptimizeType -struct typinfo *alloc_typ(n_types) -#else /* OptimizeType */ -unsigned int *alloc_typ(n_types) -#endif /* OptimizeType */ -int n_types; -{ -#ifdef OptimizeType - struct typinfo *typ; - int i; - unsigned int init = 0; - - if ((free_typinfo == NULL) && (high_typinfo == low_typinfo)) { - /* - * allocate a large block of memory used to parcel out struct typinfo - * structures from - */ - start_typinfo = (struct typinfo *)alloc(sizeof(struct typinfo) * TYPINFO_BLOCK); - high_typinfo = start_typinfo; - low_typinfo = start_typinfo + TYPINFO_BLOCK; - free_typinfo = NULL; - typ = start_typinfo; - high_typinfo++; - } - else if (free_typinfo != NULL) { - /* - * get a typinfo stucture from the list of free structures - */ - typ = free_typinfo; - free_typinfo = (struct typinfo *)free_typinfo->bits; - } - else { - /* - * get a typinfo structure from the chunk of memory allocated - * previously - */ - typ = high_typinfo; - high_typinfo++; - } - typ->packed = n_types; - if (!do_typinfer) - typ->bits = alloc_mem_typ(n_types); - else - typ->bits= NULL; - return typ; -#else /* OptimizeType */ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - - /* - * Initialization: if we are doing inference, start out assuming no types. - * If we are not doing inference, assume any type. - */ - if (!do_typinfer) - init = ~init; - for (i = 0; i < n_ints; ++i) - typ[i] = init; - return typ; -#endif /* OptimizeType */ -} - -/* - * alloc_mem_typ - actually allocates a full sized bit vector. - */ -#ifdef OptimizeType -unsigned int *alloc_mem_typ(n_types) -unsigned int n_types; -{ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - if (!do_typinfer) - init = ~init; - for(i=0; i < n_ints ;++i) - typ[i] = init; - return typ; -} -#endif /* OptimizeType */ - -/* - * set_typ - set a particular type bit in a type bit vector. - */ -void set_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - if (bit == null_bit) - type->packed |= NULL_T; - else if (bit == real_bit) - type->packed |= REAL_T; - else if (bit == int_bit) - type->packed |= INT_T; - else if (bit == cset_bit) - type->packed |= CSET_T; - else if (bit == str_bit) - type->packed |= STR_T; - else { - /* - * if the bit to set is not one of the five builtin types - * then allocate a whole bit vector, copy the packed - * bits over, and set the requested bit - */ - type->bits = alloc_mem_typ(DecodeSize(type->packed)); - xfer_packed_types(type); - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } - } - else { - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] |= mask; -#endif /* OptimizeType */ -} - -/* - * clr_type - clear a particular type bit in a type bit vector. - */ -void clr_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - /* - * can only clear one of five builtin types - */ - if (bit == null_bit) - type->packed &= ~NULL_T; - else if (bit == real_bit) - type->packed &= ~REAL_T; - else if (bit == int_bit) - type->packed &= ~INT_T; - else if (bit == cset_bit) - type->packed &= ~CSET_T; - else if (bit == str_bit) - type->packed &= ~STR_T; - } - else { - /* - * build bit mask to clear requested type in full bit vector - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] &= ~mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] &= ~mask; -#endif /* OptimizeType */ -} - -/* - * has_type - determine if a bit vector representing types has any bits - * set that correspond to a specific type code from the data base. Also, - * if requested, clear any such bits. - */ -int has_type(typ, typcd, clear) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; -int clear; -{ - int frst_bit, last_bit; - int i; - int found; - - found = 0; - bitrange(typcd, &frst_bit, &last_bit); - for (i = frst_bit; i < last_bit; ++i) { - if (bitset(typ, i)) { - found = 1; - if (clear) - clr_typ(typ, i); - } - } - return found; -} - -/* - * other_type - determine if a bit vector representing types has any bits - * set that correspond to a type *other* than specific type code from the - * data base. - */ -int other_type(typ, typcd) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; - { - int frst_bit, last_bit; - int i; - - bitrange(typcd, &frst_bit, &last_bit); - for (i = 0; i < frst_bit; ++i) - if (bitset(typ, i)) - return 1; - for (i = last_bit; i < n_intrtyp; ++i) - if (bitset(typ, i)) - return 1; - return 0; - } - -/* - * bitrange - determine the range of bit positions in a type bit vector - * that correspond to a type code from the data base. - */ -void bitrange(typcd, frst_bit, last_bit) -int typcd; -int *frst_bit; -int *last_bit; - { - if (typcd == TypVar) { - /* - * All variable types. - */ - *frst_bit = n_icntyp; - *last_bit = n_intrtyp; - } - else { - *frst_bit = type_array[typcd].frst_bit; - *last_bit = *frst_bit + type_array[typcd].num_bits; - } - } - -/* - * typcd_bits - set the bits of a bit vector corresponding to a type - * code from the data base. - */ -void typcd_bits(typcd, typ) -int typcd; -struct type *typ; - { - int frst_bit; - int last_bit; - int i; - - if (typcd == TypEmpty) - return; /* Do nothing. */ - - if (typcd == TypAny) { - /* - * Set bits corresponding to first-class types. - */ -#ifdef OptimizeType - /* - * allocate a full bit vector and copy over packed types first - */ - if (typ->bits->bits == NULL) { - typ->bits->bits = alloc_mem_typ(DecodeSize(typ->bits->packed)); - xfer_packed_types(typ->bits); - } - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits->bits[i] |= ~(unsigned int)0; - typ->bits->bits[i] |= val_mask; -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits[i] |= ~(unsigned int)0; - typ->bits[i] |= val_mask; -#endif /* OptimizeType */ - return; - } - - bitrange(typcd, &frst_bit, &last_bit); -#ifdef OptimizeType - if (last_bit > DecodeSize(typ->bits->packed)) /* bad abstract type computation */ - return; -#endif /* OptimizeType */ - for (i = frst_bit; i < last_bit; ++i) - set_typ(typ->bits, i); - } - -/* - * bitset - determine if a specific bit in a bit vector is set. - */ -int bitset(typ, bit) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int bit; -{ - int mask; - int indx; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * check to see if the requested bit is set in the packed representation - * if the requested bit is not one of the five builtins then the - * lookup fails no matter what - */ - if (bit == null_bit) - return (typ->packed & NULL_T); - else if (bit == real_bit) - return (typ->packed & REAL_T); - else if (bit == int_bit) - return (typ->packed & INT_T); - else if (bit == cset_bit) - return (typ->packed & CSET_T); - else if (bit == str_bit) - return (typ->packed & STR_T); - else - return 0; - } - else { - /* - * create a mask to check to see if the requested type bit is - * set on - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ->bits[indx] & mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ[indx] & mask; -#endif /* OptimizeType */ -} - -/* - * is_empty - determine if a type bit vector is empty. - */ -int is_empty(typ) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -{ - int i; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * if any bits are set on then the vector is not empty - */ - if (DecodePacked(typ->packed)) - return 0; - else - return 1; - } - else { - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ->bits[i] != 0) - return 0; - } - return 1; - } -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ[i] != 0) - return 0; - } - return 1; -#endif /* OptimizeType */ -} - -/* - * xfer_packed_types - transfers the packed type representation - * to a full length bit vector representation in the same - * struct typinfo structure. - */ -#ifdef OptimizeType -void xfer_packed_types(type) -struct typinfo *type; -{ - unsigned int indx, mask; - - /* - * for each IF statement built a mask to set each of the five builtins - * if they are present in the packed representation - */ - if (type->packed & NULL_T) { - indx = null_bit / IntBits; - mask = 1; - mask <<= null_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & REAL_T) { - indx = real_bit / IntBits; - mask = 1; - mask <<= real_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & INT_T) { - indx = int_bit / IntBits; - mask = 1; - mask <<= int_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & CSET_T) { - indx = cset_bit / IntBits; - mask = 1; - mask <<= cset_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & STR_T) { - indx = str_bit / IntBits; - mask = 1; - mask <<= str_bit % IntBits; - type->bits[indx] |= mask; - } -} - -/* - * xfer_packed_to_bits - sets those type bits from the src typinfo structure - * to the dest typinfo structure AND the src is a packed representation - * while the dest is a bit vector. Returns the number of new bits that - * were set in the destination. - */ -int xfer_packed_to_bits(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, mask, old, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix, membr = 0, i; - - ix = 0; - rnsize = NumInts(nsize); - /* - * for each possible type set in the packed vector, create a mask - * and apply it to the dest. check to see if there was actually - * a change in the dest vector. - */ - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= null_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - /* - * checks to see if the bit just set happens to be in the - * same word as any other of the five builtins. if they - * are then we only want to count this as one change - */ - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= real_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= int_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= cset_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= str_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - return ix; -} - -/* - * and_bits_to_packed - performs a bitwise AND of two typinfo structures - * taking into account of packed or full bit representation. - */ -void and_bits_to_packed(src, dest, size) -struct typinfo *src; -struct typinfo *dest; -int size; -{ - unsigned int indx, mask, val, destsz; - int i; - - if ((src->bits == NULL) && (dest->bits == NULL)) - /* Both are packed */ - dest->packed &= (0xFF000000 | src->packed); - else if ((src->bits == NULL) && (dest->bits != NULL)) { - /* - * built a bit mask for each type in the src and AND it too - * the bit vector in dest - */ - for (i=0; i < NumInts(size) ;i++) { - val = get_bit_vector(src,i); - dest->bits[i] &= val; - } - } - else if ((src->bits != NULL) && (dest->bits == NULL)) { - /* - * because an AND is being performed only those bits in the dest - * have the possibility of remaining set (i.e. five builtins) - * therefore if the bit is set in the packed check to see if - * it is also set in the full vector, if so then set it in the - * resulting vector, otherwise don't - */ - destsz = DecodeSize(dest->packed); - mask = 1; val = 0; - if (dest->packed & NULL_T) { - mask <<= (null_bit % IntBits); - if (src->bits[(null_bit/IntBits)] & mask) - val |= NULL_T; - } - mask = 1; - if (dest->packed & REAL_T) { - mask <<= (real_bit % IntBits); - if (src->bits[(real_bit/IntBits)] & mask) - val |= REAL_T; - } - mask = 1; - if (dest->packed & INT_T) { - mask <<= (int_bit % IntBits); - if (src->bits[(int_bit/IntBits)] & mask) - val |= INT_T; - } - mask = 1; - if (dest->packed & CSET_T) { - mask <<= (cset_bit % IntBits); - if (src->bits[(cset_bit/IntBits)] & mask) - val |= CSET_T; - } - mask = 1; - if (dest->packed & STR_T) { - mask <<= (str_bit % IntBits); - if (src->bits[(str_bit/IntBits)] & mask) - val |= STR_T; - } - dest->packed = val | destsz; - } - else - for (i=0; i < NumInts(size) ;i++) - dest->bits[i] &= src->bits[i]; -} - - -/* - * get_bit_vector - returns a bit mask from the selected word of a bit - * vector. e.g. if pos == 2, then check to see if any of the five - * builtins fall in the second word of a normal bit vector, if so - * create a bit mask with those types that fall in that word. - */ - -unsigned int get_bit_vector(src, pos) -struct typinfo *src; -int pos; -{ - unsigned int val = 0, mask; - - val = 0; - if ((src->packed & NULL_T) && ((null_bit / IntBits) == pos)) { - mask = 1; - mask <<= null_bit % IntBits; - val |= mask; - } - if ((src->packed & REAL_T) && ((real_bit / IntBits) == pos)) { - mask = 1; - mask <<= real_bit % IntBits; - val |= mask; - } - if ((src->packed & INT_T) && ((int_bit / IntBits) == pos)) { - mask = 1; - mask <<= int_bit % IntBits; - val |= mask; - } - if ((src->packed & CSET_T) && ((cset_bit / IntBits) == pos)) { - mask = 1; - mask <<= cset_bit % IntBits; - val |= mask; - } - if ((src->packed & STR_T) && ((str_bit / IntBits) == pos)) { - mask = 1; - mask <<= str_bit % IntBits; - val |= mask; - } - return val; -} - - -/* - * clr_packed - clears all bits within the nsize-th word for a packed - * representation. - */ - -void clr_packed(src, nsize) -struct typinfo *src; -int nsize; -{ - unsigned int rnsize; - - rnsize = NumInts(nsize); - if ((null_bit / IntBits) < rnsize) - src->packed &= ~NULL_T; - if ((real_bit / IntBits) < rnsize) - src->packed &= ~REAL_T; - if ((int_bit / IntBits) < rnsize) - src->packed &= ~INT_T; - if ((cset_bit / IntBits) < rnsize) - src->packed &= ~CSET_T; - if ((str_bit / IntBits) < rnsize) - src->packed &= ~STR_T; -} - -/* - * cpy_packed_to_packed - copies the packed bits from one bit vector - * to another. - */ - -void cpy_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - - rnsize = NumInts(nsize); - /* - * for each of the possible builtin types, check to see if the bit is - * set in the src and if present set it in the dest. - */ - dest->packed = DecodeSize(dest->packed); - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) - dest->packed |= NULL_T; - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) - dest->packed |= REAL_T; - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) - dest->packed |= INT_T; - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) - dest->packed |= CSET_T; - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) - dest->packed |= STR_T; - } -} - - -/* - * mrg_packed_to_packed - merges the packed type bits of a src and dest - * bit vector. - */ -int mrg_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix = 0, membr = 0, i; - - rnsize = NumInts(nsize); - /* - * for each of the five possible types in the src, check to see if it - * is set in the src and not set in the dest. if so then set it in - * the dest vector. - */ - if ((src->packed & NULL_T) && !(dest->packed & NULL_T)) { - indx = null_bit / IntBits; - if (indx < rnsize) { - dest->packed |= NULL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & REAL_T) && !(dest->packed & REAL_T)) { - indx = real_bit / IntBits; - if (indx < rnsize) { - dest->packed |= REAL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & INT_T) && !(dest->packed & INT_T)){ - indx = int_bit / IntBits; - if (indx < rnsize) { - dest->packed |= INT_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & CSET_T) && !(dest->packed & CSET_T)) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - dest->packed |= CSET_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & STR_T) && !(dest->packed & STR_T)) { - indx = str_bit / IntBits; - if (indx < rnsize) { - dest->packed |= STR_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - return ix; -} -#endif /* OptimizeType */ diff --git a/src/iconc/typinfer.c b/src/iconc/typinfer.c deleted file mode 100644 index 8a96e23..0000000 --- a/src/iconc/typinfer.c +++ /dev/null @@ -1,5189 +0,0 @@ -/* - * typinfer.c - routines to perform type inference. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" -#ifdef TypTrc -#ifdef HighResTime -#include <sys/time.h> -#include <sys/resource.h> -#endif /* HighResTime */ -#endif /* TypTrc */ - -/* - * Information about co-expressions is keep on a list. - */ -struct t_coexpr { - nodeptr n; /* code for co-expression */ - int typ_indx; /* relative type number (index) */ - struct store *in_store; /* store entry into co-expression via activation */ - struct store *out_store; /* store at end of co-expression */ -#ifdef OptimizeType - struct typinfo *act_typ; /* types passed via co-expression activation */ - struct typinfo *rslt_typ; /* types resulting from "co-expression return" */ -#else /* OptimizeType */ - unsigned int *act_typ; /* types passed via co-expression activation */ - unsigned int *rslt_typ; /* types resulting from "co-expression return" */ -#endif /* OptimizeType */ - int iteration; - struct t_coexpr *next; - }; - -struct t_coexpr *coexp_lst; - -#ifdef TypTrc -extern int typealloc; /* flag to account for allocation */ -extern long typespace; /* amount of space for type inference */ -#endif /* TypTrc */ - -struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ - -/* - * argtyps is the an array of types large enough to accommodate the argument - * list of any operation. - */ -struct argtyps { - struct argtyps *next; -#ifdef OptimizeType - struct typinfo *types[1]; /* actual size is max_prm */ -#else /* OptimizeType */ - unsigned int *types[1]; /* actual size is max_prm */ -#endif /* OptimizeType */ - }; - -/* - * prototypes for static functions. - */ -#ifdef OptimizeType -void and_bits_to_packed (struct typinfo *src, - struct typinfo *dest, int size); -struct typinfo *alloc_typ (int n_types); -unsigned int *alloc_mem_typ (unsigned int n_types); -int bitset (struct typinfo *typ, int bit); -void clr_typ (struct typinfo *type, unsigned int bit); -void clr_packed (struct typinfo *src, int nsize); -void cpy_packed_to_packed (struct typinfo *src, - struct typinfo *dest, int nsize); -static void deref_lcl (struct typinfo *src, - struct typinfo *dest); -static int findloops ( struct node *n, int resume, - struct typinfo *rslt_type); -static void gen_inv (struct typinfo *prc_typ, nodeptr n); -int has_type (struct typinfo *typ, int typcd, int clear); -static void infer_impl (struct implement *impl, - nodeptr n, struct symtyps *symtyps, - struct typinfo *rslt_typ); -int is_empty (struct typinfo *typ); -int mrg_packed_to_packed (struct typinfo *src, - struct typinfo *dest, int nsize); -int other_type (struct typinfo *typ, int typcd); -static void set_ret (struct typinfo *typ); -void set_typ (struct typinfo *type, unsigned int bit); -void typcd_bits (int typcd, struct type *typ); -static void typ_deref (struct typinfo *src, - struct typinfo *dest, int chk); -int xfer_packed_to_bits (struct typinfo *src, - struct typinfo *dest, int nsize); -#else /* OptimizeType */ -unsigned int *alloc_typ (int n_types); -int bitset (unsigned int *typ, int bit); -void clr_typ (unsigned int *type, unsigned int bit); -static void deref_lcl (unsigned int *src, unsigned int *dest); -static int findloops ( struct node *n, int resume, - unsigned int *rslt_type); -static void gen_inv (unsigned int *prc_typ, nodeptr n); -int has_type (unsigned int *typ, int typcd, int clear); -static void infer_impl (struct implement *impl, - nodeptr n, struct symtyps *symtyps, - unsigned int *rslt_typ); -int is_empty (unsigned int *typ); -int other_type (unsigned int *typ, int typcd); -static void set_ret (unsigned int *typ); -void set_typ (unsigned int *type, unsigned int bit); -void typcd_bits (int typcd, struct type *typ); -static void typ_deref (unsigned int *src, unsigned int *dest, int chk); -#endif /* OptimizeType */ - -static void abstr_new (struct node *n, struct il_code *il); -static void abstr_typ (struct il_code *il, struct type *typ); -static struct store *alloc_stor (int stor_sz, int n_types); -static void chk_succ (int ret_flag, struct store *susp_stor); -static struct store *cpy_store (struct store *source); -static int eval_cond (struct il_code *il); -static void free_argtyp (struct argtyps *argtyps); -static void free_store (struct store *store); -static void free_wktyp (struct type *typ); -static void find_new (struct node *n); -static struct argtyps *get_argtyp (void); -static struct store *get_store (int clear); -static struct type *get_wktyp (void); -static void infer_act (nodeptr n); -static void infer_con (struct rentry *rec, nodeptr n); -static int infer_il (struct il_code *il); -static void infer_nd (nodeptr n); -static void infer_prc (struct pentry *proc, nodeptr n); -static void mrg_act (struct t_coexpr *coexp, - struct store *e_store, - struct type *rslt_typ); -static void mrg_store (struct store *source, struct store *dest); -static void side_effect (struct il_code *il); -static struct symtyps *symtyps (int nsyms); - -#ifdef TypTrc -static void prt_d_typ (FILE *file, struct typinfo *typ); -static void prt_typ (FILE *file, struct typinfo *typ); -#endif /* TypTrc */ - -#define CanFail 1 - -/* - * cur_coexp is non-null while performing type inference on code from a - * create expression. If it is null, the possible current co-expressions - * must be found from cur_proc. - */ -struct t_coexpr *cur_coexp = NULL; - -struct gentry **proc_map; /* map procedure types to symbol table entries */ -struct rentry **rec_map; /* map record types to record information */ -struct t_coexpr **coexp_map; /* map co-expression types to information */ - -struct typ_info *type_array; - -static int num_new; /* number of types supporting "new" abstract type comp */ - -/* - * Data base component codes are mapped to type inferencing information - * using an array. - */ -struct compnt_info { - int frst_bit; /* first bit in bit vector allocated to component */ - int num_bits; /* number of bits allocated to this component */ - struct store *store; /* maps component "reference" to the type it holds */ - }; -static struct compnt_info *compnt_array; - -static unsigned int frst_fld; /* bit number of 1st record field */ -static unsigned int n_fld; /* number of record fields */ -static unsigned int frst_gbl; /* bit number of 1st global reference type */ -static unsigned int n_gbl; /* number of global variables */ -static unsigned int n_nmgbl; /* number of named global variables */ -static unsigned int frst_loc; /* bit number of 1st local reference type */ -static unsigned int n_loc; /* maximum number of locals in any procedure */ - -static unsigned int nxt_bit; /* next unassigned bit in bit vector */ -unsigned int n_icntyp; /* number of non-variable types */ -unsigned int n_intrtyp; /* number of types in intermediate values */ -static unsigned int n_rttyp; /* number of types in runtime computations */ -unsigned int val_mask; /* mask for non-var types in last int of type */ - -unsigned int null_bit; /* bit for null type */ -unsigned int str_bit; /* bit for string type */ -unsigned int cset_bit; /* bit for cset type */ -unsigned int int_bit; /* bit for integer type */ -unsigned int real_bit; /* bit for real type */ - -static struct store *fld_stor; /* record fields */ - -static int *cur_new; /* allocated types for current operation */ - -static struct store *succ_store = NULL; /* current success store */ -static struct store *fail_store = NULL; /* current failure store */ - -static struct store *dummy_stor; -static struct store *store_pool = NULL; /* free list of store structs */ - -static struct type *type_pool = NULL; /* free list of type structs */ -static struct type cur_rslt = {0, NULL, NULL}; /* result type of operation */ - -static struct argtyps *argtyp_pool = NULL; /* free list of arg type arrays */ -static struct argtyps *arg_typs = NULL; /* current arg type array */ - -static int num_args; /* number of arguments for current operation */ -static int n_vararg; /* size of variable part of arg list to run-time routine */ - -#ifdef OptimizeType -static struct typinfo *any_typ; /* type bit vector with all bits on */ -struct typinfo *free_typinfo = NULL; -struct typinfo *start_typinfo = NULL; -struct typinfo *high_typinfo = NULL; -struct typinfo *low_typinfo = NULL; -#else /* OptimizeType */ -static unsigned int *any_typ; /* type bit vector with all bits on */ -#endif /* OptimizeType */ - -long changed; /* number of changes to type information in this iteration */ -int iteration; /* iteration number for type inferencing */ - -#ifdef TypTrc -static FILE *trcfile = NULL; /* output file pointer for tracing */ -static char *trcname = NULL; /* output file name for tracing */ -static char *trc_indent = ""; -#endif /* TypTrc */ - - -/* - * typeinfer - infer types of operands. If "do_typinfer" is set, actually - * do abstract interpretation, otherwise assume any type for all operands. - */ -void typeinfer() - { - struct gentry *gptr; - struct lentry *lptr; - nodeptr call_main; - struct pentry *p; - struct rentry *rec; - struct t_coexpr *coexp; - struct store *init_store; - struct store *f_store; -#ifdef OptimizeType - struct typinfo *type; -#else /* OptimizeType */ - unsigned int *type; -#endif /* OptimizeType */ - struct implement *ip; - struct lentry **lhash; - struct lentry **vartypmap; - int i, j, k; - int size; - int flag; - -#ifdef TypTrc - /* - * Set up for type tracing. - */ - long start_infer, end_infer; - -#ifdef HighResTime - struct rusage rusage; - - getrusage(RUSAGE_SELF, &rusage); - start_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; -#else /* HighResTime */ - start_infer = millisec(); -#endif /* HighResTime */ - - typealloc = 1; /* note allocation in this phase */ - - trcname = getenv("TYPTRC"); - - if (trcname != NULL && strlen(trcname) != 0) { - - if (trcname[0] == '|') { - FILE *popen(); - - trcfile = popen(trcname+1, "w"); - } - else - - trcfile = fopen(trcname, "w"); - - if (trcfile == NULL) { - fprintf(stderr, "TYPTRC: cannot open %s\n", trcname); - fflush(stderr); - exit(EXIT_FAILURE); - } - } -#endif /* TypTrc */ - - /* - * Make sure max_prm is large enough for any run-time routine. - */ - for (i = 0; i < IHSize; ++i) - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - if (ip->nargs > max_prm) - max_prm = ip->nargs; - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->nargs > max_prm) - max_prm = ip->nargs; - - /* - * Allocate an arrays to map data base type codes and component codes - * to type inferencing information. - */ - type_array = (struct typ_info *)alloc((unsigned int)(num_typs * - sizeof(struct typ_info))); - compnt_array = (struct compnt_info *)alloc((unsigned int)(num_cmpnts * - sizeof(struct compnt_info))); - - /* - * Find those types that support the "new" abstract type computation - * assign to them locations in the arrays of allocated types associated - * with operation invocations. Also initialize the number of type bits. - * Types with no subtypes have one bit. Types allocated with the the "new" - * abstract have a default sub-type that is allocated here. Procedures - * have a subtype to for string invocable operators. Co-expressions - * have a subtype for &main. Records are handled below. - */ - num_new = 0; - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].support_new) - type_array[i].new_indx = num_new++; - type_array[i].num_bits = 1; /* reserve one type bit */ - } - type_array[list_typ].num_bits = 2; /* default & list for arg to main() */ - - cur_coexp = NewStruct(t_coexpr); - cur_coexp->n = NULL; - cur_coexp->next = NULL; - coexp_lst = cur_coexp; - - if (do_typinfer) { - /* - * Go through the syntax tree for each procedure locating program - * points that may create structures at run time. Allocate the - * appropriate structure type(s) to each such point. - */ - for (p = proc_lst; p != NULL; p = p->next) { - if (p->nargs < 0) - p->arg_lst = type_array[list_typ].num_bits++; /* list for varargs */ - find_new(Tree1(p->tree)); /* initial clause */ - find_new(Tree2(p->tree)); /* body of procedure */ - } - } - - /* - * Allocate a type number for each record type (use record number for - * offset) and a variable type number for each field. - */ - n_fld = 0; - if (rec_lst == NULL) { - type_array[rec_typ].num_bits = 0; - rec_map = NULL; - } - else { - type_array[rec_typ].num_bits = rec_lst->rec_num + 1; - rec_map = (struct rentry **)alloc( - (unsigned int)((rec_lst->rec_num + 1)*sizeof(struct rentry *))); - for (rec = rec_lst; rec != NULL; rec = rec->next) { - rec->frst_fld = n_fld; - n_fld += rec->nfields; - rec_map[rec->rec_num] = rec; - } - } - - /* - * Allocate type numbers to global variables. Don't count those procedure - * variables that are no longer referenced in the syntax tree. Do count - * static variables. Also allocate types to procedures, built-in functions, - * record constructors. - */ - n_gbl = 0; - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (flag & F_SmplInv) - gptr->index = -1; /* unused: set to something not a valid type */ - else { - gptr->index = n_gbl++; - if (flag & (F_Proc | F_Record | F_Builtin)) - gptr->init_type = type_array[proc_typ].num_bits++; - } - if (flag & F_Proc) { - for (lptr = gptr->val.proc->statics; lptr != NULL;lptr = lptr->next) - lptr->val.index = n_gbl++; - } - } - n_nmgbl = n_gbl; - - /* - * Determine relative bit numbers for predefined variable types that - * are treated as sets of global variables. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfGlbl) - type_array[i].frst_bit = n_gbl++; /* converted to absolute later */ - - proc_map = (struct gentry **)alloc( - (unsigned int)((type_array[proc_typ].num_bits)*sizeof(struct gentry *))); - proc_map[0] = NULL; /* proc type for string invocable operators */ - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (!(flag & F_SmplInv) && (flag & (F_Proc | F_Record | F_Builtin))) - proc_map[gptr->init_type] = gptr; - } - - /* - * Allocate type numbers to local variables. The same numbers are reused - * in different procedures. - */ - n_loc = 0; - for (p = proc_lst; p != NULL; p = p->next) { - i = Abs(p->nargs); - for (lptr = p->args; lptr != NULL; lptr = lptr->next) - lptr->val.index = --i; - i = Abs(p->nargs); - for (lptr = p->dynams; lptr != NULL; lptr = lptr->next) - lptr->val.index = i++; - n_loc = Max(n_loc, i); - - /* - * produce a mapping from the variable types used in this procedure - * to the corresponding symbol table entries. - */ - if (n_gbl + n_loc == 0) - vartypmap = NULL; - else - vartypmap = (struct lentry **)alloc( - (unsigned int)((n_gbl + n_loc)*sizeof(struct lentry *))); - for (i = 0; i < n_gbl + n_loc; ++i) - vartypmap[i] = NULL; /* no entries for foreign statics */ - p->vartypmap = vartypmap; - lhash = p->lhash; - for (i = 0; i < LHSize; ++i) { - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { - switch (lptr->flag) { - case F_Global: - gptr = lptr->val.global; - if (!(gptr->flag & F_SmplInv)) - vartypmap[gptr->index] = lptr; - break; - case F_Static: - vartypmap[lptr->val.index] = lptr; - break; - case F_Dynamic: - case F_Argument: - vartypmap[n_gbl + lptr->val.index] = lptr; - } - } - } - } - - /* - * There is a component reference subtype for every subtype of the - * associated aggregate type. - */ - for (i = 0; i < num_cmpnts; ++i) - compnt_array[i].num_bits = type_array[typecompnt[i].aggregate].num_bits; - - /* - * Assign bits for non-variable (first-class) types. - */ - nxt_bit = 0; - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfNone) { - type_array[i].frst_bit = nxt_bit; - nxt_bit += type_array[i].num_bits; - } - - n_icntyp = nxt_bit; /* number of first-class types */ - - /* - * Load some commonly needed bit numbers into global variable. - */ - null_bit = type_array[null_typ].frst_bit; - str_bit = type_array[str_typ].frst_bit; - cset_bit = type_array[cset_typ].frst_bit; - int_bit = type_array[int_typ].frst_bit; - real_bit = type_array[real_typ].frst_bit; - - /* - * Assign bits for predefined variable types that are not treated as - * sets of globals. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfCnst || icontypes[i].deref == DrfSpcl) { - type_array[i].frst_bit = nxt_bit; - nxt_bit += type_array[i].num_bits; - } - - /* - * Assign bits to aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) - if (typecompnt[i].var) { - compnt_array[i].frst_bit = nxt_bit; - nxt_bit += compnt_array[i].num_bits; - } - - /* - * Assign bits to record fields and named variables. - */ - frst_fld = nxt_bit; - nxt_bit += n_fld; - frst_gbl = nxt_bit; - nxt_bit += n_gbl; - frst_loc = nxt_bit; - nxt_bit += n_loc; - - /* - * Convert from relative to ablsolute bit numbers for predefined variable - * types that are treated as sets of global variables. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfGlbl) - type_array[i].frst_bit += frst_gbl; - - n_intrtyp = nxt_bit; /* number of types for intermediate values */ - - /* - * Assign bits to aggregate compontents that are not variables. These - * are the runtime system's internal descriptor reference types. - */ - for (i = 0; i < num_cmpnts; ++i) - if (!typecompnt[i].var) { - compnt_array[i].frst_bit = nxt_bit; - nxt_bit += compnt_array[i].num_bits; - } - - n_rttyp = nxt_bit; /* total size of type system */ - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Output a summary of the type system. - */ - for (i = 0; i < num_typs; ++i) { - fprintf(trcfile, "%s", icontypes[i].id); - if (strcmp(icontypes[i].id, icontypes[i].abrv) != 0) - fprintf(trcfile, "(%s)", icontypes[i].abrv); - fprintf(trcfile, " sub-types: %d\n", type_array[i].num_bits); - } - } -#endif /* TypTrc */ - - /* - * The division between bits for first-class types and variables types - * generally occurs in the middle of a word. Set up a mask for extracting - * the first-class types from this word. - */ - val_mask = 0; - i = n_icntyp - (NumInts(n_icntyp) - 1) * IntBits; - while (i--) - val_mask = (val_mask << 1) | 1; - - if (do_typinfer) { - /* - * Create stores large enough for the component references. These - * are global to the entire program, rather than being propagated - * from node to node in the syntax tree. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (i == str_var) - size = n_intrtyp; - else - size = n_icntyp; - compnt_array[i].store = alloc_stor(compnt_array[i].num_bits, size); - } - fld_stor = alloc_stor(n_fld, n_icntyp); - - dummy_stor = get_store(0); - - /* - * First list is arg to main: a list of strings. - */ - set_typ(compnt_array[lst_elem].store->types[1], str_typ); - } - - /* - * Set up a type bit vector with all bits on. - */ -#ifdef OptimizeType - any_typ = alloc_typ(n_rttyp); - any_typ->bits = alloc_mem_typ(DecodeSize(any_typ->packed)); - for (i = 0; i < NumInts(n_rttyp); ++i) - any_typ->bits[i] = ~(unsigned int)0; -#else /* OptimizeType */ - any_typ = alloc_typ(n_rttyp); - for (i = 0; i < NumInts(n_rttyp); ++i) - any_typ[i] = ~(unsigned int)0; -#endif /* OptimizeType */ - - /* - * Initialize stores and return values for procedures. Also initialize - * flag indicating whether the procedure can be executed. - */ - call_main = NULL; - for (p = proc_lst; p != NULL; p = p->next) { - if (do_typinfer) { - p->iteration = 0; - p->ret_typ = alloc_typ(n_intrtyp); - p->coexprs = alloc_typ(n_icntyp); - p->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (p->ret_flag & DoesSusp) - p->susp_store = alloc_stor(n_gbl, n_icntyp); - else - p->susp_store = NULL; - for (i = Abs(p->nargs); i < n_loc; ++i) - set_typ(p->in_store->types[n_gbl + i], null_bit); - if (p->nargs < 0) - set_typ(p->in_store->types[n_gbl + Abs(p->nargs) - 1], - type_array[list_typ].frst_bit + p->arg_lst); - if (strcmp(p->name, "main") == 0) { - /* - * create a the initial call to main with one list argument. - */ - call_main = invk_main(p); - call_main->type = alloc_typ(n_intrtyp); - Tree2(call_main)->type = alloc_typ(n_intrtyp); - set_typ(Tree2(call_main)->type, type_array[list_typ].frst_bit + 1); - call_main->store = alloc_stor(n_gbl + n_loc, n_icntyp); - } - p->out_store = alloc_stor(n_gbl, n_icntyp); - p->reachable = 0; - } - else - p->reachable = 1; - /* - * Analyze the code of the procedure to determine where to place stores - * that survive iterations of type inferencing. Note, both the initial - * clause and the body of the procedure are bounded. - */ - findloops(Tree1(p->tree), 0, NULL); - findloops(Tree2(p->tree), 0, NULL); - } - - /* - * If type inferencing is suppressed, we have set up very conservative - * type information and will do no inferencing. - */ - if (!do_typinfer) - return; - - if (call_main == NULL) - return; /* no main procedure, cannot continue */ - if (tfatals > 0) - return; /* don't do inference if there are fatal errors */ - - /* - * Construct mapping from co-expression types to information - * about the co-expressions and finish initializing the information. - */ - i = type_array[coexp_typ].num_bits; - coexp_map = (struct t_coexpr **)alloc( - (unsigned int)(i * sizeof(struct t_coexpr *))); - for (coexp = coexp_lst; coexp != NULL; coexp = coexp->next) { - coexp_map[--i] = coexp; - coexp->typ_indx = i; - coexp->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); - coexp->out_store = alloc_stor(n_gbl + n_loc, n_icntyp); - coexp->act_typ = alloc_typ(n_intrtyp); - coexp->rslt_typ = alloc_typ(n_intrtyp); - coexp->iteration = 0; - } - - /* - * initialize globals - */ - init_store = get_store(1); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (!(flag & F_SmplInv)) { - type = init_store->types[gptr->index]; - if (flag & (F_Proc | F_Record | F_Builtin)) - set_typ(type, type_array[proc_typ].frst_bit + gptr->init_type); - else - set_typ(type, null_bit); - } - } - - /* - * Initialize types for predefined variable types. - */ - for (i = 0; i < num_typs; ++i) { - type = NULL; - switch (icontypes[i].deref) { - case DrfGlbl: - /* - * Treated as a global variable. - */ - type = init_store->types[type_array[i].frst_bit - frst_gbl]; - break; - case DrfCnst: - /* - * Type doesn't change so keep one copy. - */ - type = alloc_typ(n_intrtyp); - type_array[i].typ = type; - break; - } - if (type != NULL) { - /* - * Determine which types are in the initial type for this variable. - */ - for (j = 0; j < num_typs; ++j) { - if (icontypes[i].typ[j] != '.') { - for (k = 0; k < type_array[j].num_bits; ++k) - set_typ(type, type_array[j].frst_bit + k); - } - } - } - } - - f_store = get_store(1); - - /* - * Type inferencing iterates over the program until a fixed point is - * reached. - */ - changed = 1L; /* force first iteration */ - iteration = 0; - if (verbose > 1) - fprintf(stderr, "type inferencing: "); - - while (changed > 0L) { - changed = 0L; - ++iteration; - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "**** iteration %d ****\n", iteration); -#endif /* TypTrc */ - - /* - * Start at the implicit initial call to the main procedure. Inferencing - * walks the call graph from here. - */ - succ_store = cpy_store(init_store); - fail_store = f_store; - infer_nd(call_main); - - /* - * If requested, monitor the progress of inferencing. - */ - switch (verbose) { - case 0: - case 1: - break; - case 2: - fprintf(stderr, "."); - break; - default: /* > 2 */ - if (iteration != 1) - fprintf(stderr, ", "); - fprintf(stderr, "%ld", changed); - } - } - - /* - * Type inferencing is finished, complete any diagnostic output. - */ - if (verbose > 1) - fprintf(stderr, "\n"); - -#ifdef TypTrc - if (trcfile != NULL) { - -#ifdef HighResTime - getrusage(RUSAGE_SELF, &rusage); - end_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; -#else /* HighResTime */ - end_infer = millisec(); -#endif /* HighResTime */ - fprintf(trcfile, "\n**** inferencing time: %ld milliseconds\n", - end_infer - start_infer); - fprintf(trcfile, "\n**** inferencing space: %ld bytes\n",typespace); - fclose(trcfile); - } - typealloc = 0; -#endif /* TypTrc */ - } - -/* - * find_new - walk the syntax tree allocating structure types where - * operations create new structures. - */ -static void find_new(n) -struct node *n; - { - struct t_coexpr *coexp; - struct node *cases; - struct node *clause; - int nargs; - int i; - - n->new_types = NULL; - switch (n->n_type) { - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Next: - case N_Real: - case N_Str: - break; - - case N_Bar: - case N_Break: - case N_Field: - case N_Not: - find_new(Tree0(n)); - break; - - case N_Alt: - case N_Apply: - case N_Limit: - case N_Slist: - find_new(Tree0(n)); - find_new(Tree1(n)); - break; - - case N_Activat: - find_new(Tree1(n)); - find_new(Tree2(n)); - break; - - case N_If: - find_new(Tree0(n)); /* control clause */ - find_new(Tree1(n)); /* then clause */ - find_new(Tree2(n)); /* else clause, may be N_Empty */ - break; - - case N_Create: - /* - * Allocate a sub-type for the co-expressions created here. - */ - n->new_types = (int *)alloc((unsigned int)(sizeof(int))); - n->new_types[0] = type_array[coexp_typ].num_bits++; - coexp = NewStruct(t_coexpr); - coexp->n = Tree0(n); - coexp->next = coexp_lst; - coexp_lst = coexp; - find_new(Tree0(n)); - break; - - case N_Augop: - abstr_new(n, Impl0(n)->in_line); /* assignment */ - abstr_new(n, Impl1(n)->in_line); /* the operation */ - find_new(Tree2(n)); /* 1st operand */ - find_new(Tree3(n)); /* 2nd operand */ - break; - - case N_Case: - find_new(Tree0(n)); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - find_new(Tree0(clause)); /* value of clause */ - find_new(Tree1(clause)); /* body of clause */ - } - if (Tree2(n) != NULL) - find_new(Tree2(n)); /* deflt */ - break; - - case N_Invok: - nargs = Val0(n); /* number of arguments */ - find_new(Tree1(n)); /* thing being invoked */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_InvOp: - /* - * This is a call to an operation, this is what we must - * check for "new" abstract type computation. - */ - nargs = Val0(n); /* number of arguments */ - abstr_new(n, Impl1(n)->in_line); /* operation */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_InvProc: - case N_InvRec: - nargs = Val0(n); /* number of arguments */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_Loop: - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - case WHILE: - case UNTIL: - find_new(Tree1(n)); /* control clause */ - find_new(Tree2(n)); /* do clause - may be N_Empty*/ - break; - - case REPEAT: - find_new(Tree1(n)); /* clause */ - break; - } - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) - find_new(Tree1(n)); /* value - may be N_Empty */ - break; - - case N_Scan: - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) - abstr_new(n, optab[asgn_loc].binary->in_line); - find_new(Tree1(n)); /* subject */ - find_new(Tree2(n)); /* body */ - break; - - case N_Sect: - abstr_new(n, Impl0(n)->in_line); /* sectioning */ - if (Impl1(n) != NULL) - abstr_new(n, Impl1(n)->in_line); /* plus, minus, or nothing */ - find_new(Tree2(n)); /* 1st operand */ - find_new(Tree3(n)); /* 2nd operand */ - find_new(Tree4(n)); /* 3rd operand */ - break; - - case N_SmplAsgn: - case N_SmplAug: - find_new(Tree3(n)); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * abstr_new - find the abstract clauses in the implementation of an operation. - * If they indicate that the operations creates structures, allocate a - * type for the structures and associate it with the node in the syntax tree. - */ -static void abstr_new(n, il) -struct node *n; -struct il_code *il; - { - int i; - int num_cases, indx; - struct typ_info *t_info; - - if (il == NULL) - return; - - switch (il->il_type) { - case IL_New: - /* - * We have found a "new" construct in an abstract type computation. - * Make sure an array has been created to hold the types allocated - * to this call, then allocate the indicated type if one has not - * already been allocated. - */ - if (n->new_types == NULL) { - n->new_types = (int *)alloc((unsigned int)(num_new * sizeof(int))); - for (i = 0; i < num_new; ++i) - n->new_types[i] = -1; - } - t_info = &type_array[il->u[0].n]; /* index by type code */ - if (n->new_types[t_info->new_indx] < 0) { - n->new_types[t_info->new_indx] = t_info->num_bits++; -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s\n", n->n_file, n->n_line, - n->n_col, icontypes[il->u[0].n].id); -#endif /* TypTrc */ - } - i = il->u[1].n; /* num args */ - indx = 2; - while (i--) - abstr_new(n, il->u[indx++].fld); - break; - - case IL_If1: - abstr_new(n, il->u[1].fld); - break; - - case IL_If2: - abstr_new(n, il->u[1].fld); - abstr_new(n, il->u[2].fld); - break; - - case IL_Tcase1: - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - indx += 2; /* skip type info */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - break; - - case IL_Tcase2: - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - indx += 2; /* skip type info */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - abstr_new(n, il->u[indx].fld); /* default */ - break; - - case IL_Lcase: - num_cases = il->u[0].n; - indx = 1; - for (i = 0; i < num_cases; ++i) { - ++indx; /* skip selection num */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - abstr_new(n, il->u[indx].fld); /* default */ - break; - - case IL_Acase: - abstr_new(n, il->u[2].fld); /* C_integer action */ - if (largeints) - abstr_new(n, il->u[3].fld); /* integer action */ - abstr_new(n, il->u[4].fld); /* C_double action */ - break; - - case IL_Abstr: - case IL_Inter: - case IL_Lst: - case IL_TpAsgn: - case IL_Union: - abstr_new(n, il->u[0].fld); - abstr_new(n, il->u[1].fld); - break; - - case IL_Compnt: - case IL_Store: - case IL_VarTyp: - abstr_new(n, il->u[0].fld); - break; - - case IL_Block: - case IL_Call: - case IL_Const: /* should have been replaced by literal node */ - case IL_Err1: - case IL_Err2: - case IL_IcnTyp: - case IL_Subscr: - case IL_Var: - break; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - } - } - -/* - * alloc_stor - allocate a store with empty types. - */ -static struct store *alloc_stor(stor_sz, n_types) -int stor_sz; -int n_types; - { - struct store *stor; - int i; - - /* - * If type inferencing is disabled, we don't actually make use of - * any stores, but the initialization code asks for them anyway. - */ - if (!do_typinfer) - return NULL; - -#ifdef OptimizeType - stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + - ((stor_sz - 1) * sizeof(struct typinfo *)))); - stor->next = NULL; - stor->perm = 1; - for (i = 0; i < stor_sz; ++i) { - stor->types[i] = (struct typinfo *)alloc_typ(n_types); - } -#else /* OptimizeType */ - stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + - ((stor_sz - 1) * sizeof(unsigned int *)))); - stor->next = NULL; - stor->perm = 1; - for (i = 0; i < stor_sz; ++i) { - stor->types[i] = (unsigned int *)alloc_typ(n_types); - } -#endif /* OptimizeType */ - - return stor; - } - -/* - * findloops - find both explicit loops and implicit loops caused by - * goal-directed evaluation. Allocate stores for them. Determine which - * expressions cannot fail (used to eliminate dynamic store allocation - * for some bounded expressions). Allocate stores for 'if' and 'case' - * expressions that can be resumed. Initialize expression types. - * The syntax tree is walked in reverse execution order looking for - * failure and for generators. - */ -static int findloops(n, resume, rslt_type) -struct node *n; -int resume; -#ifdef OptimizeType -struct typinfo *rslt_type; -#else /* OptimizeType */ -unsigned int *rslt_type; -#endif /* OptimizeType */ - { - struct loop { - int resume; - int can_fail; - int every_cntrl; -#ifdef OptimizeType - struct typinfo *type; -#else /* OptimizeType */ - unsigned int *type; -#endif /* OptimizeType */ - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop = NULL; - struct node *cases; - struct node *clause; - int can_fail; - int nargs, i; - - n->store = NULL; - if (!do_typinfer) - rslt_type = any_typ; - - switch (n->n_type) { - case N_Activat: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - /* - * Assume activation can fail. - */ - can_fail = findloops(Tree2(n), 1, NULL); - can_fail = findloops(Tree1(n), can_fail, NULL); - n->symtyps = symtyps(2); - if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) - n->symtyps->next = symtyps(2); - break; - - case N_Alt: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = findloops(Tree0(n), resume, rslt_type) | - findloops(Tree1(n), resume, rslt_type); - break; - - case N_Apply: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - /* - * Assume operation can suspend or fail. - */ - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = findloops(Tree1(n), 1, NULL); - can_fail = findloops(Tree0(n), can_fail, NULL); - n->symtyps = symtyps(max_sym); - break; - - case N_Augop: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - - can_fail = resume; - /* - * Impl0(n) is assignment. - */ - if (resume && Impl0(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl0(n)->ret_flag)) - can_fail = 1; - /* - * Impl1(n) is the augmented operation. - */ - if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ - can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ - n->type = Tree2(n)->type; - Typ4(n) = alloc_typ(n_intrtyp); - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - n->symtyps->next = symtyps(n_arg_sym(Impl0(n))); - break; - - case N_Bar: - can_fail = findloops(Tree0(n), resume, rslt_type); - n->type = Tree0(n)->type; - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - break; - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return 0; - } - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - loop_sav->can_fail |= findloops(Tree0(n), loop_sav->resume, - loop_sav->type); - cur_loop = loop_sav; - can_fail = 0; - break; - - case N_Case: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - - /* - * control clause is bounded - */ - can_fail = findloops(Tree0(n), 0, NULL); - - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * The expression being compared can be resumed. - */ - findloops(Tree0(clause), 1, NULL); - - /* - * Body. - */ - can_fail |= findloops(Tree1(clause), resume, rslt_type); - } - - if (Tree2(n) == NULL) - can_fail = 1; - else - can_fail |= findloops(Tree2(n), resume, rslt_type); /* default */ - break; - - case N_Create: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - findloops(Tree0(n), 1, NULL); /* co-expression code */ - /* - * precompute type - */ - i= type_array[coexp_typ].frst_bit; - if (do_typinfer) - i += n->new_types[0]; - set_typ(n->type, i); - can_fail = resume; - break; - - case N_Cset: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, type_array[cset_typ].frst_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Empty: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, null_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Id: { - struct lentry *var; - - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - /* - * Precompute type - */ - var = LSym0(n); - if (var->flag & F_Global) - set_typ(n->type, frst_gbl + var->val.global->index); - else if (var->flag & F_Static) - set_typ(n->type, frst_gbl + var->val.index); - else - set_typ(n->type, frst_loc + var->val.index); - can_fail = resume; - } - break; - - case N_Field: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = findloops(Tree0(n), resume, NULL); - n->symtyps = symtyps(1); - break; - - case N_If: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - /* - * control clause is bounded - */ - findloops(Tree0(n), 0, NULL); - can_fail = findloops(Tree1(n), resume, rslt_type); - if (Tree2(n)->n_type == N_Empty) - can_fail = 1; - else { - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail |= findloops(Tree2(n), resume, rslt_type); - } - break; - - case N_Int: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, int_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Invok: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - /* - * Assume operation can suspend and fail. - */ - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = 1; - for (i = nargs; i >= 0; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - n->symtyps = symtyps(max_sym); - break; - - case N_InvOp: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - if (resume && Impl1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - break; - - case N_InvProc: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - if (resume && Proc1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (Proc1(n)->ret_flag & DoesFail) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - break; - - case N_InvRec: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of args */ - if (err_conv) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - break; - - case N_Limit: - findloops(Tree0(n), resume, rslt_type); - can_fail = findloops(Tree1(n), 1, NULL); - n->type = Tree0(n)->type; - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - n->symtyps = symtyps(1); - break; - - case N_Loop: { - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - loop_info.prev = cur_loop; - loop_info.resume = resume; - loop_info.can_fail = 0; - loop_info.every_cntrl = 0; - loop_info.type = n->type; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - /* - * The control clause can be resumed. The body is bounded. - */ - loop_info.every_cntrl = 1; - can_fail = findloops(Tree1(n), 1, NULL); - loop_info.every_cntrl = 0; - findloops(Tree2(n), 0, NULL); - break; - - case REPEAT: - /* - * The loop needs a saved store. The body is bounded. - */ - findloops(Tree1(n), 0, NULL); - can_fail = 0; - break; - - case WHILE: - /* - * The loop needs a saved store. The control - * clause and the body are each bounded. - */ - can_fail = findloops(Tree1(n), 0, NULL); - findloops(Tree2(n), 0, NULL); - break; - - case UNTIL: - /* - * The loop needs a saved store. The control - * clause and the body are each bounded. - */ - findloops(Tree1(n), 0, NULL); - findloops(Tree2(n), 0, NULL); - can_fail = 1; - break; - } - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (do_typinfer && resume) - n->store->next = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail |= cur_loop->can_fail; - cur_loop = cur_loop->prev; - } - break; - - case N_Next: - if (cur_loop == NULL) { - nfatal(n, "invalid context for next", NULL); - return 1; - } - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = cur_loop->every_cntrl; - break; - - case N_Not: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, null_bit); /* precompute type */ - /* - * The expression is bounded. - */ - findloops(Tree0(n), 0, NULL); - can_fail = 1; - break; - - case N_Real: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, real_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Ret: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - if (Val0(Tree0(n)) == RETURN) { - /* - * The expression is bounded. - */ - findloops(Tree1(n), 0, NULL); - } - can_fail = 0; - break; - - case N_Scan: { - struct implement *asgn_impl; - - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - n->symtyps = symtyps(1); - can_fail = resume; - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - asgn_impl = optab[asgn_loc].binary; - if (resume && asgn_impl->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(asgn_impl->ret_flag)) - can_fail = 1; - n->symtyps->next = symtyps(n_arg_sym(asgn_impl)); - } - can_fail = findloops(Tree2(n), can_fail, NULL); /* body */ - can_fail = findloops(Tree1(n), can_fail, NULL); /* subject */ - } - break; - - case N_Sect: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = resume; - /* - * Impl0(n) is sectioning. - */ - if (resume && Impl0(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl0(n)->ret_flag)) - can_fail = 1; - n->symtyps = symtyps(n_arg_sym(Impl0(n))); - if (Impl1(n) != NULL) { - /* - * Impl1(n) is plus or minus - */ - if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - n->symtyps->next = symtyps(n_arg_sym(Impl1(n))); - } - can_fail = findloops(Tree4(n), can_fail, NULL); /* operand 3 */ - can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ - can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ - break; - - case N_Slist: - /* - * 1st expression is bounded. - */ - findloops(Tree0(n), 0, NULL); - can_fail = findloops(Tree1(n), resume, rslt_type); - n->type = Tree1(n)->type; - break; - - case N_SmplAsgn: - can_fail = findloops(Tree3(n), resume, NULL); /* 2nd operand */ - findloops(Tree2(n), can_fail, rslt_type); /* variable */ - n->type = Tree2(n)->type; - break; - - case N_SmplAug: - can_fail = resume; - /* - * Impl1(n) is the augmented operation. - */ - if (resume && Impl1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - can_fail = findloops(Tree3(n), can_fail, NULL); /* 2nd operand */ - findloops(Tree2(n), can_fail, rslt_type); /* variable */ - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - n->type = Tree2(n)->type; - Typ4(n) = alloc_typ(n_intrtyp); - break; - - case N_Str: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, str_bit); /* precompute type */ - can_fail = resume; - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - if (can_fail) - n->flag = CanFail; - else - n->flag = 0; - return can_fail; - } - -/* - * symtyps - determine the number of entries needed for a symbol table - * that maps argument indexes to types for an operation in the - * data base. Allocate the symbol table. - */ -static struct symtyps *symtyps(nsyms) -int nsyms; - { - struct symtyps *tab; - - if (nsyms == 0) - return NULL; - -#ifdef OptimizeType - tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + - (nsyms - 1) * sizeof(struct typinfo *))); -#else /* OptimizeType */ - tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + - (nsyms - 1) * sizeof(int *))); -#endif /* OptimizeType */ - tab->nsyms = nsyms; - tab->next = NULL; - while (nsyms) - tab->types[--nsyms] = alloc_typ(n_intrtyp); - return tab; - } - -/* - * infer_proc - perform type inference on a call to an Icon procedure. - */ -static void infer_prc(proc, n) -struct pentry *proc; -nodeptr n; - { - struct store *s_store; - struct store *f_store; - struct store *store; - struct pentry *sv_proc; - struct t_coexpr *sv_coexp; - struct lentry *lptr; - nodeptr n1; - int i; - int nparams; - int coexp_bit; - - /* - * Determine what co-expressions the procedure might be called from. - */ - if (cur_coexp == NULL) - ChkMrgTyp(n_icntyp, cur_proc->coexprs, proc->coexprs) - else { - coexp_bit = type_array[coexp_typ].frst_bit + cur_coexp->typ_indx; - if (!bitset(proc->coexprs, coexp_bit)) { - ++changed; - set_typ(proc->coexprs, coexp_bit); - } - } - - proc->reachable = 1; /* this procedure can be called */ - - /* - * If this procedure can suspend, there may be backtracking paths - * to this invocation. If so, propagate types of globals from the - * backtracking paths to the suspends of the procedure and propagate - * types of locals to the success store of the call. - */ - if (proc->ret_flag & DoesSusp && n->store != NULL) { - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, n->store->types[i], proc->susp_store->types[i]) - for (i = 0; i < n_loc; ++i) - MrgTyp(n_icntyp, n->store->types[n_gbl + i], succ_store->types[n_gbl + - i]) - } - - /* - * Merge the types of global variables into the "in store" of the - * procedure. Because the body of the procedure may already have - * been processed for this pass, the "changed" flag must be set if - * there is a change of type in the store. This will insure that - * there will be another iteration in which to propagate the change - * into the body. - */ - store = proc->in_store; - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[i], store->types[i]) - -#ifdef TypTrc - /* - * Trace the call. - */ - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, - trc_indent, proc->name); -#endif /* TypTrc */ - - /* - * Get the types of the arguments, starting with the non-varargs part. - */ - nparams = proc->nargs; /* number of parameters */ - if (nparams < 0) - nparams = -nparams - 1; - for (i = 0; i < num_args && i < nparams; ++i) { - typ_deref(arg_typs->types[i], store->types[n_gbl + i], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Trace the argument type to the call. - */ - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * Get the type of the varargs part of the argument list. - */ - if (proc->nargs < 0) - while (i < num_args) { - typ_deref(arg_typs->types[i], - compnt_array[lst_elem].store->types[proc->arg_lst], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Trace the argument type to the call. - */ - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++i; - } - - /* - * Missing arguments have the null type. - */ - while (i < nparams) { - set_typ(store->types[n_gbl + i], null_bit); - ++i; - } - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, ")\n"); - { - char *trc_ind_sav = trc_indent; - trc_indent = ""; /* staring a new procedure, don't indent tracing */ -#endif /* TypTrc */ - - /* - * only perform type inference on the body of a procedure - * once per iteration - */ - if (proc->iteration < iteration) { - proc->iteration = iteration; - s_store = succ_store; - f_store = fail_store; - sv_proc = cur_proc; - succ_store = cpy_store(proc->in_store); - cur_proc = proc; - sv_coexp = cur_coexp; - cur_coexp = NULL; /* we are not in a create expression */ - /* - * Perform type inference on the initial clause. Static variables - * are initialized to null on this path. - */ - for (lptr = proc->statics; lptr != NULL; lptr = lptr->next) - set_typ(succ_store->types[lptr->val.index], null_bit); - n1 = Tree1(proc->tree); - if (n1->flag & CanFail) { - /* - * The initial clause can fail. Because it is bounded, we need - * a new failure store that we can merge into the success store - * at the end of the clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(n1); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(n1); - /* - * Perform type inference on the body of procedure. Execution may - * pass directly to it without executing initial clause. - */ - mrg_store(proc->in_store, succ_store); - n1 = Tree2(proc->tree); - if (n1->flag & CanFail) { - /* - * The body can fail. Because it is bounded, we need a new failure - * store that we can merge into the success store at the end of - * the procedure. - */ - store = get_store(1); - fail_store = store; - infer_nd(n1); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(n1); - set_ret(NULL); /* implicit fail */ - free_store(succ_store); - succ_store = s_store; - fail_store = f_store; - cur_proc = sv_proc; - cur_coexp = sv_coexp; - } - -#ifdef TypTrc - trc_indent = trc_ind_sav; - } -#endif /* TypTrc */ - - /* - * Get updated types for global variables at the end of the call. - */ - store = proc->out_store; - for (i = 0; i < n_gbl; ++i) - CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); - - /* - * If the procedure can fail, merge variable types into the failure - * store. - */ - if (proc->ret_flag & DoesFail) - mrg_store(succ_store, fail_store); - - /* - * The return type of the procedure is the result type of the call. - */ - MrgTyp(n_intrtyp, proc->ret_typ, n->type); - } - -/* - * cpy_store - make a copy of a store. - */ -static struct store *cpy_store(source) -struct store *source; - { - struct store *dest; - int stor_sz; - int i; - - if (source == NULL) - dest = get_store(1); - else { - stor_sz = n_gbl + n_loc; - dest = get_store(0); - for (i = 0; i < stor_sz; ++i) - CpyTyp(n_icntyp, source->types[i], dest->types[i]) - } - return dest; - } - -/* - * mrg_store - merge the source store into the destination store. - */ -static void mrg_store(source, dest) -struct store *source; -struct store *dest; - { - int i; - - if (source == NULL) - return; - - /* - * Is this store included in the state that must be checked for a fixed - * point? - */ - if (dest->perm) { - for (i = 0; i < n_gbl + n_loc; ++i) - ChkMrgTyp(n_icntyp, source->types[i], dest->types[i]) - } - else { - for (i = 0; i < n_gbl + n_loc; ++i) - MrgTyp(n_icntyp, source->types[i], dest->types[i]) - } - } - -/* - * set_ret - Save return type and the store for global variables. - */ -static void set_ret(typ) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ - { - int i; - - /* - * Merge the return type into the type of the procedure, dereferencing - * locals in the process. - */ - if (typ != NULL) - deref_lcl(typ, cur_proc->ret_typ); - - /* - * Update the types that variables may have upon exit of the procedure. - */ - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, succ_store->types[i], cur_proc->out_store->types[i]); - } - -/* - * deref_lcl - dereference local variable sub-types. - */ -static void deref_lcl(src, dest) -#ifdef OptimizeType -struct typinfo *src; -struct typinfo *dest; -#else /* OptimizeType */ -unsigned int *src; -unsigned int *dest; -#endif /* OptimizeType */ - { - int i, j; - int ref_gbl; - int frst_stv; - int num_stv; - struct store *stv_stor; - struct type *wktyp; - - /* - * Make a copy of the type to be dereferenced. - */ - wktyp = get_wktyp(); - CpyTyp(n_intrtyp, src, wktyp->bits); - - /* - * Determine which variable types must be dereferenced. Merge the - * dereferenced type into the return type and delete the variable - * type. Start with simple local variables. - */ - for (i = 0; i < n_loc; ++i) - if (bitset(wktyp->bits, frst_loc + i)) { - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], wktyp->bits) - clr_typ(wktyp->bits, frst_loc + i); - } - - /* - * Check for substring trapped variables. If a sub-string trapped - * variable references a local, add "string" to the return type. - * If a sub-string trapped variable references a global, leave the - * trapped variable in the return type. - * It is theoretically possible for a sub-string trapped variable type to - * reference both a local and a global. When the trapped variable type - * is returned to the calling procedure, the local is re-interpreted - * as a local of that procedure. This is a "valid" overestimate of - * of the semantics of the return. Because this is unlikely to occur - * in real programs, the overestimate is of no practical consequence. - */ - num_stv = type_array[stv_typ].num_bits; - frst_stv = type_array[stv_typ].frst_bit; - stv_stor = compnt_array[str_var].store; - for (i = 0; i < num_stv; ++i) { - if (bitset(wktyp->bits, frst_stv + i)) { - /* - * We have found substring trapped variable i, see whether it - * references locals or globals. Globals include structure - * element references. - */ - for (j = 0; j < n_loc; ++j) - if (bitset(stv_stor->types[i], frst_loc + j)) { - set_typ(wktyp->bits, str_bit); - break; - } - ref_gbl = 0; - for (j = n_icntyp; j < frst_loc; ++j) - if (bitset(stv_stor->types[i], j)) { - ref_gbl = 1; - break; - } - /* - * Keep the trapped variable only if it references globals. - */ - if (!ref_gbl) - clr_typ(wktyp->bits, frst_stv + i); - } - } - - /* - * Merge the types into the destination. - */ - MrgTyp(n_intrtyp, wktyp->bits, dest); - -#ifdef TypTrc - if (trcfile != NULL) { - prt_typ(trcfile, wktyp->bits); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - free_wktyp(wktyp); - } - -/* - * get_store - get a store large enough to hold globals and locals. - */ -static struct store *get_store(clear) -int clear; - { - struct store *store; - int store_sz; - int i; - - /* - * Warning, stores for all procedures must be the same size. In some - * situations involving sub-string trapped variables (for example - * when using the "default" trapped variable) a referenced local variable - * type may be interpreted in a procedure to which it does not belong. - * This represents an impossible execution and type inference may - * "legally" produce any results for this part of the abstract - * interpretation. As long as the store is large enough to include any - * such "impossible" variables, type inference will do something legal. - * Note that n_loc is the maximum number of locals in any procedure, - * so store_sz is large enough. - */ - store_sz = n_gbl + n_loc; - if ((store = store_pool) == NULL) { - store = alloc_stor(store_sz, n_icntyp); - store->perm = 0; - } - else { - store_pool = store_pool->next; - /* - * See if the variables in the store should be initialized to the - * empty type. - */ - if (clear) - for (i = 0; i < store_sz; ++i) - ClrTyp(n_icntyp, store->types[i]); - } - return store; - } - -static void free_store(store) -struct store *store; - { - store->next = store_pool; - store_pool = store; - } - -/* - * infer_nd - perform type inference on a subtree of the syntax tree. - */ -static void infer_nd(n) -nodeptr n; - { - struct node *cases; - struct node *clause; - struct store *s_store; - struct store *f_store; - struct store *store; - struct loop { - struct store *succ_store; - struct store *fail_store; - struct store *next_store; - struct store *susp_store; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop; - struct argtyps *sav_argtyp; - int sav_nargs; - struct type *wktyp; - int i; - - switch (n->n_type) { - case N_Activat: - infer_act(n); - break; - - case N_Alt: - f_store = fail_store; - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); /* 1st alternative */ - - /* - * "Correct" type inferencing of alternation has a performance - * problem. Propagating stores through nested alternation - * requires as many iterations as the depth of the nesting. - * This is solved by adding two edges to the flow graph. These - * represent impossible execution paths but this does not - * affect the soundness of type inferencing and, in "real" - * programs, does not affect the preciseness of its inference. - * One edge is directly from the 1st alternative to the 2nd. - * The other is a backtracking edge immediately back into - * the alternation from the 1st alternative. - */ - mrg_store(succ_store, store); /* imaginary edge to 2nd alternative */ - - if (n->store != NULL) { - mrg_store(succ_store, n->store); /* imaginary backtracking edge */ - mrg_store(n->store, fail_store); - } - s_store = succ_store; - succ_store = store; - fail_store = f_store; - infer_nd(Tree1(n)); /* 2nd alternative */ - mrg_store(s_store, succ_store); - free_store(s_store); - if (n->store != NULL) - mrg_store(n->store, fail_store); - fail_store = n->store; -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree0(n)->type, n->type); - MrgTyp(n_intrtyp, Tree1(n)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by sub-expressions directly into n->type. - */ -#endif /* TypTrc */ - break; - - case N_Apply: { - struct type *lst_types; - int frst_lst; - int num_lst; - struct store *lstel_stor; - - infer_nd(Tree0(n)); /* thing being invoked */ - infer_nd(Tree1(n)); /* list */ - - frst_lst = type_array[list_typ].frst_bit; - num_lst = type_array[list_typ].num_bits; - lstel_stor = compnt_array[lst_elem].store; - - /* - * All that is available is a "summary" of the types of the - * elements of the list. Each argument to the invocation - * could be any type in the summary. Set up a maximum length - * argument list. - */ - lst_types = get_wktyp(); - typ_deref(Tree1(n)->type, lst_types->bits, 0); - wktyp = get_wktyp(); - for (i = 0; i < num_lst; ++i) - if (bitset(lst_types->bits, frst_lst + i)) - MrgTyp(n_icntyp, lstel_stor->types[i], wktyp->bits); - bitset(wktyp->bits, null_bit); /* arg list extension might be done */ - - sav_nargs = num_args; - sav_argtyp = arg_typs; - num_args = max_prm; - arg_typs = get_argtyp(); - for (i = 0; i < max_prm; ++i) - arg_typs->types[i] = wktyp->bits; - gen_inv(Tree0(n)->type, n); /* inference on general invocation */ - - free_wktyp(wktyp); - free_wktyp(lst_types); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - break; - - case N_Augop: - infer_nd(Tree2(n)); /* 1st operand */ - infer_nd(Tree3(n)); /* 2nd operand */ - /* - * Perform type inference on the operation. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree2(n)->type; - arg_typs->types[1] = Tree3(n)->type; - infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); - chk_succ(Impl1(n)->ret_flag, n->store); - /* - * Perform type inference on the assignment. - */ - arg_typs->types[1] = Typ4(n); - infer_impl(Impl0(n), n, n->symtyps->next, n->type); - chk_succ(Impl0(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Bar: - /* - * This operation intercepts failure and has an associated - * resumption store. If backtracking reaches this operation - * execution may either continue backward or proceed forward - * again. - */ - mrg_store(n->store, fail_store); - mrg_store(n->store, succ_store); - fail_store = n->store; - infer_nd(Tree0(n)); - /* - * Type is computed by operand. - */ - break; - - case N_Break: - /* - * The success and failure stores for the operand of break are - * those associated with the enclosing loop. - */ - fail_store = cur_loop->fail_store; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - infer_nd(Tree0(n)); - cur_loop = loop_sav; - mrg_store(succ_store, cur_loop->succ_store); - if (cur_loop->susp_store != NULL) - mrg_store(cur_loop->susp_store, fail_store); - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Result of break is empty type. Result type of expression - * is computed directly into result type of loop. - */ - break; - - case N_Case: - f_store = fail_store; - s_store = get_store(1); - infer_nd(Tree0(n)); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * Set up a failure store to capture the effects of failure - * of the selection clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree0(clause)); /* value of clause */ - - /* - * Create the effect of the possible failure of the comparison - * of the selection value to the control value. - */ - mrg_store(succ_store, fail_store); - - /* - * The success and failure stores and the result of the body - * of the clause are those of the whole case expression. - */ - fail_store = f_store; - infer_nd(Tree1(clause)); /* body of clause */ - mrg_store(succ_store, s_store); - free_store(succ_store); - succ_store = store; - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'case' can be resumed */ -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree1(clause)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by case clause directly into n->type. - */ -#endif /* TypTrc */ - } - - /* - * Check for default clause. - */ - if (Tree2(n) == NULL) - mrg_store(succ_store, f_store); - else { - fail_store = f_store; - infer_nd(Tree2(n)); /* default */ - mrg_store(succ_store, s_store); - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'case' can be resumed */ -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by default clause directly into n->type. - */ -#endif /* TypTrc */ - } - free_store(succ_store); - succ_store = s_store; - if (n->store != NULL) - fail_store = n->store; - break; - - case N_Create: - /* - * Record initial values of local variables for coexpression. - */ - store = coexp_map[n->new_types[0]]->in_store; - for (i = 0; i < n_loc; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], - store->types[n_gbl + i]) - /* - * Type is precomputed. - */ - break; - - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Real: - case N_Str: - /* - * Type is precomputed. - */ - break; - - case N_Field: { - struct fentry *fp; - struct par_rec *rp; - int frst_rec; - - if ((fp = flookup(Str0(Tree1(n)))) == NULL) { - break; /* error message printed elsewhere */ - } - - /* - * Determine the record types. - */ - infer_nd(Tree0(n)); - typ_deref(Tree0(n)->type, n->symtyps->types[0], 0); - - /* - * For each record containing this field, get the tupe of - * the field in that record. - */ - frst_rec = type_array[rec_typ].frst_bit; - for (rp = fp->rlist; rp != NULL; rp = rp->next) { - if (bitset(n->symtyps->types[0], frst_rec + rp->rec->rec_num)) - set_typ(n->type, frst_fld + rp->rec->frst_fld + rp->offset); - } - } - break; - - case N_If: - f_store = fail_store; - if (Tree2(n)->n_type != N_Empty) { - /* - * If there is an else clause, we must set up a failure store - * to capture the effects of failure of the control clause. - */ - store = get_store(1); - fail_store = store; - } - - infer_nd(Tree0(n)); /* control clause */ - - /* - * If the control clause succeeds, execution passes into the - * then clause with the failure store for the entire if expression. - */ - fail_store = f_store; - infer_nd(Tree1(n)); /* then clause */ - - if (Tree2(n)->n_type != N_Empty) { - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ - s_store = succ_store; - - /* - * The entering success store of the else clause is the failure - * store of the control clause. The failure store is that of - * the entire if expression. - */ - succ_store = store; - fail_store = f_store; - infer_nd(Tree2(n)); /* else clause */ - - if (n->store != NULL) { - mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ - fail_store = n->store; - } - - /* - * Join the exiting success stores of the then and else clauses. - */ - mrg_store(s_store, succ_store); - free_store(s_store); - } - -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree1(n)->type, n->type); - if (Tree2(n)->n_type != N_Empty) - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); -#else /* TypTrc */ - /* - * Type computed by 'then' and 'else' clauses directly into n->type. - */ -#endif /* TypTrc */ - break; - - case N_Invok: - /* - * General invocation. - */ - infer_nd(Tree1(n)); /* thing being invoked */ - - /* - * Perform type inference on all the arguments and copy the - * results into the argument type array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * If this is mutual evaluation, get the type of the last argument, - * otherwise do inference on general invocation. - */ - if (Tree1(n)->n_type == N_Empty) { - MrgTyp(n_intrtyp, arg_typs->types[num_args - 1], n->type); - } - else - gen_inv(Tree1(n)->type, n); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvOp: - /* - * Invocation of a run-time operation. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * Perform inference on operation invocation. - */ - infer_impl(Impl1(n), n, n->symtyps, n->type); - chk_succ(Impl1(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvProc: - /* - * Invocation of a procedure. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * Perform inference on the procedure invocation. - */ - infer_prc(Proc1(n), n); - chk_succ(Proc1(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvRec: - /* - * Invocation of a record constructor. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - infer_con(Rec1(n), n); /* inference on constructor invocation */ - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Limit: - infer_nd(Tree1(n)); /* limit */ - typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); - mrg_store(succ_store, fail_store); /* limit might be 0 */ - mrg_store(n->store, fail_store); /* resumption may bypass expr */ - infer_nd(Tree0(n)); /* expression */ - if (fail_store != NULL) - mrg_store(n->store, fail_store); /* expression may be resumed */ - fail_store = n->store; - /* - * Type is computed by expression being limited. - */ - break; - - case N_Loop: { - /* - * Establish stores used by break and next. - */ - loop_info.prev = cur_loop; - loop_info.succ_store = get_store(1); - loop_info.fail_store = fail_store; - loop_info.next_store = NULL; - loop_info.susp_store = n->store->next; - cur_loop = &loop_info; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - infer_nd(Tree1(n)); /* control clause */ - f_store = fail_store; - - /* - * Next in the do clause resumes the control clause as - * does success of the do clause. - */ - loop_info.next_store = fail_store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, f_store); - break; - - case REPEAT: - /* - * The body of the loop can be entered by entering the - * loop, by executing a next in the body, or by having - * the loop succeed or fail. n->store captures all but - * the first case, which is covered by the initial success - * store. - */ - fail_store = n->store; - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - infer_nd(Tree1(n)); - mrg_store(succ_store, n->store); - break; - - case SUSPEND: - infer_nd(Tree1(n)); /* value */ -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) suspend ", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - set_ret(Tree1(n)->type); /* set return type of procedure */ - - /* - * Get changes to types of global variables from - * resumption. - */ - store = cur_proc->susp_store; - for (i = 0; i < n_gbl; ++i) - CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); - - /* - * Next in the do clause resumes the control clause as - * does success of the do clause. - */ - f_store = fail_store; - loop_info.next_store = fail_store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, f_store); - break; - - case WHILE: - /* - * The control clause can be entered by entering the loop, - * executing a next expression, or by having the do clause - * succeed or fail. n->store captures all but the first case, - * which is covered by the initial success store. - */ - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - infer_nd(Tree1(n)); /* control clause */ - fail_store = n->store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, n->store); - break; - - case UNTIL: - /* - * The control clause can be entered by entering the loop, - * executing a next expression, or by having the do clause - * succeed or fail. n->store captures all but the first case, - * which is covered by the initial success store. - */ - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - f_store = fail_store; - /* - * Set up a failure store to capture the effects of failure - * of the control clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree1(n)); /* control clause */ - mrg_store(succ_store, f_store); - free_store(succ_store); - succ_store = store; - fail_store = n->store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, n->store); - break; - } - free_store(succ_store); - succ_store = loop_info.succ_store; - if (n->store->next != NULL) - fail_store = n->store->next; - cur_loop = cur_loop->prev; - /* - * Type is computed by break expressions. - */ - } - break; - - case N_Next: - if (cur_loop->next_store == NULL) - mrg_store(succ_store, fail_store); /* control clause of every */ - else - mrg_store(succ_store, cur_loop->next_store); - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Result is empty type. - */ - break; - - case N_Not: - /* - * Set up a failure store to capture the effects of failure - * of the negated expression, it becomes the success store - * of the entire expression. - */ - f_store = fail_store; - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); - mrg_store(succ_store, f_store); /* if success, then fail */ - free_store(succ_store); - succ_store = store; - fail_store = f_store; - /* - * Type is precomputed. - */ - break; - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - if (Tree1(n)->flag & CanFail) { - /* - * Set up a failure store to capture the effects of failure - * of the returned expression and the corresponding procedure - * failure. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree1(n)); /* return value */ - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(Tree1(n)); /* return value */ - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) return ", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - set_ret(Tree1(n)->type); - } - else { /* fail */ - set_ret(NULL); - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) fail\n", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - } - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Empty type. - */ - break; - - case N_Scan: { - struct implement *asgn_impl; - - infer_nd(Tree1(n)); /* subject */ - typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); - infer_nd(Tree2(n)); /* body */ - - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - /* - * Perform type inference on the assignment. - */ - asgn_impl = optab[asgn_loc].binary; - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree1(n)->type; - arg_typs->types[1] = Tree2(n)->type; - infer_impl(asgn_impl, n, n->symtyps->next, n->type); - chk_succ(asgn_impl->ret_flag, n->store); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - else - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); - } - break; - - case N_Sect: - infer_nd(Tree2(n)); /* 1st operand */ - infer_nd(Tree3(n)); /* 2nd operand */ - infer_nd(Tree4(n)); /* 3rd operand */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - if (Impl1(n) != NULL) { - /* - * plus or minus. - */ - num_args = 2; - arg_typs->types[0] = Tree3(n)->type; - arg_typs->types[1] = Tree4(n)->type; - wktyp = get_wktyp(); - infer_impl(Impl1(n), n, n->symtyps->next, wktyp->bits); - chk_succ(Impl1(n)->ret_flag, n->store); - arg_typs->types[2] = wktyp->bits; - } - else - arg_typs->types[2] = Tree4(n)->type; - num_args = 3; - arg_typs->types[0] = Tree2(n)->type; - arg_typs->types[1] = Tree3(n)->type; - /* - * sectioning - */ - infer_impl(Impl0(n), n, n->symtyps, n->type); - chk_succ(Impl0(n)->ret_flag, n->store); - if (Impl1(n) != NULL) - free_wktyp(wktyp); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Slist: - f_store = fail_store; - if (Tree0(n)->flag & CanFail) { - /* - * Set up a failure store to capture the effects of failure - * of the first operand; this is merged into the - * incoming success store of the second operand. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(Tree0(n)); - fail_store = f_store; - infer_nd(Tree1(n)); - /* - * Type is computed by second operand. - */ - break; - - case N_SmplAsgn: { - /* - * Optimized assignment to a named variable. - */ - struct lentry *var; - int indx; - - infer_nd(Tree3(n)); - var = LSym0(Tree2(n)); - if (var->flag & F_Global) - indx = var->val.global->index; - else if (var->flag & F_Static) - indx = var->val.index; - else - indx = n_gbl + var->val.index; - ClrTyp(n_icntyp, succ_store->types[indx]); - typ_deref(Tree3(n)->type, succ_store->types[indx], 0); - -#ifdef TypTrc - /* - * Trace assignment. - */ - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, - n->n_col, trc_indent, var->name); - prt_d_typ(trcfile, Tree3(n)->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - /* - * Type is precomputed. - */ - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct lentry *var; - int indx; - - /* - * Perform type inference on the operation. - */ - infer_nd(Tree3(n)); /* 2nd operand */ - - /* - * Set up type array for arguments of operation. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree2(n)->type; /* type was precomputed */ - arg_typs->types[1] = Tree3(n)->type; - - /* - * Perform inference on the operation. - */ - infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); - chk_succ(Impl1(n)->ret_flag, n->store); - - /* - * Perform assignment to the variable. - */ - var = LSym0(Tree2(n)); - if (var->flag & F_Global) - indx = var->val.global->index; - else if (var->flag & F_Static) - indx = var->val.index; - else - indx = n_gbl + var->val.index; - ClrTyp(n_icntyp, succ_store->types[indx]); - typ_deref(Typ4(n), succ_store->types[indx], 0); - -#ifdef TypTrc - /* - * Trace assignment. - */ - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, - n->n_col, trc_indent, var->name); - prt_d_typ(trcfile, Typ4(n)); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - - /* - * Type is precomputed. - */ - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * infer_con - perform type inference for the invocation of a record - * constructor. - */ -static void infer_con(rec, n) -struct rentry *rec; -nodeptr n; - { - int fld_indx; - int nfields; - int i; - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, - trc_indent, rec->name); -#endif /* TypTrc */ - - /* - * Dereference argument types into appropriate entries of field store. - */ - fld_indx = rec->frst_fld; - nfields = rec->nfields; - for (i = 0; i < num_args && i < nfields; ++i) { - typ_deref(arg_typs->types[i], fld_stor->types[fld_indx++], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * If there are too few arguments, add null type to appropriate entries - * of field store. - */ - while (i < nfields) { - if (!bitset(fld_stor->types[fld_indx], null_bit)) { - ++changed; - set_typ(fld_stor->types[fld_indx], null_bit); - } - ++fld_indx; - ++i; - } - - /* - * return record type - */ - set_typ(n->type, type_array[rec_typ].frst_bit + rec->rec_num); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, ") =>> "); - prt_typ(trcfile, n->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - -/* - * infer_act - perform type inference on coexpression activation. - */ -static void infer_act(n) -nodeptr n; - { - struct implement *asgn_impl; - struct store *s_store; - struct store *f_store; - struct store *e_store; - struct store *store; - struct t_coexpr *sv_coexp; - struct t_coexpr *coexp; - struct type *rslt_typ; - struct argtyps *sav_argtyp; - int frst_coexp; - int num_coexp; - int sav_nargs; - int i; - int j; - -#ifdef TypTrc - FILE *trc_save; -#endif /* TypTrc */ - - num_coexp = type_array[coexp_typ].num_bits; - frst_coexp = type_array[coexp_typ].frst_bit; - - infer_nd(Tree1(n)); /* value to transmit */ - infer_nd(Tree2(n)); /* coexpression */ - - /* - * Dereference the two arguments. Note that only locals in the - * transmitted value are dereferenced. - */ - -#ifdef TypTrc - trc_save = trcfile; - trcfile = NULL; /* don't trace value during dereferencing */ -#endif /* TypTrc */ - - deref_lcl(Tree1(n)->type, n->symtyps->types[0]); - -#ifdef TypTrc - trcfile = trc_save; -#endif /* TypTrc */ - - typ_deref(Tree2(n)->type, n->symtyps->types[1], 0); - - rslt_typ = get_wktyp(); - - /* - * Set up a store for the end of the activation and propagate local - * variables across the activation; the activation may succeed or - * fail. - */ - e_store = get_store(1); - for (i = 0; i < n_loc; ++i) - CpyTyp(n_icntyp, succ_store->types[n_gbl + i], e_store->types[n_gbl + i]) - if (fail_store->perm) { - for (i = 0; i < n_loc; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], - fail_store->types[n_gbl + i]) - } - else { - for (i = 0; i < n_loc; ++i) - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], - fail_store->types[n_gbl + i]) - } - - - /* - * Go through all the co-expressions that might be activated, - * perform type inference on them, and transmit stores along - * the execution paths induced by the activation. - */ - s_store = succ_store; - f_store = fail_store; - for (j = 0; j < num_coexp; ++j) { - if (bitset(n->symtyps->types[1], frst_coexp + j)) { - coexp = coexp_map[j]; - /* - * Merge the types of global variables into the "in store" of the - * co-expression. Because the body of the co-expression may already - * have been processed for this pass, the "changed" flag must be - * set if there is a change of type in the store. This will insure - * that there will be another iteration in which to propagate the - * change into the body. - */ - store = coexp->in_store; - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, s_store->types[i], store->types[i]) - - ChkMrgTyp(n_intrtyp, n->symtyps->types[0], coexp->act_typ) - - /* - * Only perform type inference on the body of a co-expression - * once per iteration. The main co-expression has no body. - */ - if (coexp->iteration < iteration & coexp->n != NULL) { - coexp->iteration = iteration; - succ_store = cpy_store(coexp->in_store); - fail_store = coexp->out_store; - sv_coexp = cur_coexp; - cur_coexp = coexp; - infer_nd(coexp->n); - - /* - * Dereference the locals in the value resulting from - * the execution of the co-expression body. - */ - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %sC%d =>> ", coexp->n->n_file, - coexp->n->n_line, coexp->n->n_col, trc_indent, j); -#endif /* TypTrc */ - - deref_lcl(coexp->n->type, coexp->rslt_typ); - - mrg_store(succ_store, coexp->out_store); - free_store(succ_store); - cur_coexp = sv_coexp; - } - - /* - * Get updated types for global variables, assuming the co-expression - * fails or returns by completing. - */ - store = coexp->out_store; - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], e_store->types[i]); - if (f_store->perm) { - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, store->types[i], f_store->types[i]); - } - else { - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], f_store->types[i]); - } - MrgTyp(n_intrtyp, coexp->rslt_typ, rslt_typ->bits) - } - } - - /* - * Control may return from the activation if another co-expression - * activates the current one. If we are in a create expression, - * cur_coexp is the current co-expression, otherwise the current - * procedure may be called within several co-expressions. - */ - if (cur_coexp == NULL) { - for (j = 0; j < num_coexp; ++j) - if (bitset(cur_proc->coexprs, frst_coexp + j)) - mrg_act(coexp_map[j], e_store, rslt_typ); - } - else - mrg_act(cur_coexp, e_store, rslt_typ); - - free_store(s_store); - succ_store = e_store; - fail_store = f_store; - - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, - trc_indent); - prt_typ(trcfile, n->symtyps->types[0]); - fprintf(trcfile, " @ "); - prt_typ(trcfile, n->symtyps->types[1]); - fprintf(trcfile, " =>> "); - prt_typ(trcfile, rslt_typ->bits); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) { - /* - * Perform type inference on the assignment. - */ - asgn_impl = optab[asgn_loc].binary; - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree1(n)->type; - arg_typs->types[1] = rslt_typ->bits; - infer_impl(asgn_impl, n, n->symtyps->next, n->type); - chk_succ(asgn_impl->ret_flag, n->store); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - else - ChkMrgTyp(n_intrtyp, rslt_typ->bits, n->type) - - free_wktyp(rslt_typ); - } - -/* - * mrg_act - merge entry information for the co-expression to the - * the ending store and result type for the activation being - * analyzed. - */ -static void mrg_act(coexp, e_store, rslt_typ) -struct t_coexpr *coexp; -struct store *e_store; -struct type *rslt_typ; - { - struct store *store; - int i; - - store = coexp->in_store; - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], e_store->types[i]); - - MrgTyp(n_intrtyp, coexp->act_typ, rslt_typ->bits) - } - -/* - * typ_deref - perform dereferencing in the abstract type realm. - */ -static void typ_deref(src, dest, chk) -#ifdef OptimizeType -struct typinfo *src; -struct typinfo *dest; -#else /* OptimizeType */ -unsigned int *src; -unsigned int *dest; -#endif /* OptimizeType */ -int chk; - { - struct store *tblel_stor; - struct store *tbldf_stor; - struct store *ttv_stor; - struct store *store; - unsigned int old; - int num_tbl; - int frst_tbl; - int num_bits; - int frst_bit; - int i; - int j; - int ret; -/* - if (src->bits == NULL) { - src->bits = alloc_mem_typ(src->size); - xfer_packed_types(src); - } - if (dest->bits == NULL) { - dest->bits = alloc_mem_typ(dest->size); - xfer_packed_types(dest); - } -*/ - /* - * copy values to destination - */ -#ifdef OptimizeType - if ((src->bits != NULL) && (dest->bits != NULL)) { - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest->bits[i]; - dest->bits[i] |= src->bits[i]; - if (chk && (old != dest->bits[i])) - ++changed; - } - old = dest->bits[i]; - dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ - if (chk && (old != dest->bits[i])) - ++changed; - } - else if ((src->bits != NULL) && (dest->bits == NULL)) { - dest->bits = alloc_mem_typ(DecodeSize(dest->packed)); - xfer_packed_types(dest); - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest->bits[i]; - dest->bits[i] |= src->bits[i]; - if (chk && (old != dest->bits[i])) - ++changed; - } - old = dest->bits[i]; - dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ - if (chk && (old != dest->bits[i])) - ++changed; - } - else if ((src->bits == NULL) && (dest->bits != NULL)) { - ret = xfer_packed_to_bits(src, dest, n_icntyp); - if (chk) - changed += ret; - } - else { - ret = mrg_packed_to_packed(src, dest, n_icntyp); - if (chk) - changed += ret; - } -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest[i]; - dest[i] |= src[i]; - if (chk && (old != dest[i])) - ++changed; - } - old = dest[i]; - dest[i] |= src[i] & val_mask; /* mask out variables */ - if (chk && (old != dest[i])) - ++changed; -#endif /* OptimizeType */ - - /* - * predefined variables whose types do not change. - */ - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].deref == DrfCnst) { - if (bitset(src, type_array[i].frst_bit)) - if (chk) - ChkMrgTyp(n_icntyp, type_array[i].typ, dest) - else - MrgTyp(n_icntyp, type_array[i].typ, dest) - } - } - - - /* - * substring trapped variables - */ - num_bits = type_array[stv_typ].num_bits; - frst_bit = type_array[stv_typ].frst_bit; - for (i = 0; i < num_bits; ++i) - if (bitset(src, frst_bit + i)) - if (!bitset(dest, str_bit)) { - if (chk) - ++changed; - set_typ(dest, str_bit); - } - - /* - * table element trapped variables - */ - num_bits = type_array[ttv_typ].num_bits; - frst_bit = type_array[ttv_typ].frst_bit; - num_tbl = type_array[tbl_typ].num_bits; - frst_tbl = type_array[tbl_typ].frst_bit; - tblel_stor = compnt_array[tbl_val].store; - tbldf_stor = compnt_array[tbl_dflt].store; - ttv_stor = compnt_array[trpd_tbl].store; - for (i = 0; i < num_bits; ++i) - if (bitset(src, frst_bit + i)) - for (j = 0; j < num_tbl; ++j) - if (bitset(ttv_stor->types[i], frst_tbl + j)) { - if (chk) { - ChkMrgTyp(n_icntyp, tblel_stor->types[j], dest) - ChkMrgTyp(n_icntyp, tbldf_stor->types[j], dest) - } - else { - MrgTyp(n_icntyp, tblel_stor->types[j], dest) - MrgTyp(n_icntyp, tbldf_stor->types[j], dest) - } - } - - /* - * Aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (typecompnt[i].var) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(src, frst_bit + j)) - if (chk) - ChkMrgTyp(n_icntyp, store->types[j], dest) - else - MrgTyp(n_icntyp, store->types[j], dest) - } - } - } - - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(src, frst_fld + i)) { - if (chk) - ChkMrgTyp(n_icntyp, fld_stor->types[i], dest) - else - MrgTyp(n_icntyp, fld_stor->types[i], dest) - } - - /* - * global variables - */ - for (i = 0; i < n_gbl; ++i) - if (bitset(src, frst_gbl + i)) { - if (chk) - ChkMrgTyp(n_icntyp, succ_store->types[i], dest) - else - MrgTyp(n_icntyp, succ_store->types[i], dest) - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(src, frst_loc + i)) { - if (chk) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) - else - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) - } -} - -/* - * infer_impl - perform type inference on a call to built-in operation - * using the implementation entry from the data base. - */ -static void infer_impl(impl, n, symtyps, rslt_typ) -struct implement *impl; -nodeptr n; -struct symtyps *symtyps; -#ifdef OptimizeType -struct typinfo *rslt_typ; -#else /* OptimizeType */ -unsigned int *rslt_typ; -#endif /* OptimizeType */ - { -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int flag; - int nparms; - int i; - int j; - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, - trc_indent); - if (impl->oper_typ == 'K') - fprintf(trcfile, "&%s", impl->name); - else - fprintf(trcfile, "%s(", impl->name); - } -#endif /* TypTrc */ - /* - * Set up the "symbol table" of dereferenced and undereferenced - * argument types as needed by the operation. - */ - nparms = impl->nargs; - j = 0; - for (i = 0; i < num_args && i < nparms; ++i) { - if (impl->arg_flgs[i] & RtParm) { - CpyTyp(n_intrtyp, arg_typs->types[i], symtyps->types[j]); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++j; - } - if (impl->arg_flgs[i] & DrfPrm) { - typ_deref(arg_typs->types[i], symtyps->types[j], 0); - -#ifdef TypTrc - if (trcfile != NULL) { - if (impl->arg_flgs[i] & RtParm) - fprintf(trcfile, "->"); - else if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++j; - } - } - if (nparms > 0) { - /* - * Check for varargs. Merge remaining arguments into the - * type of the variable part of the parameter list. - */ - flag = impl->arg_flgs[nparms - 1]; - if (flag & VarPrm) { - n_vararg = num_args - nparms + 1; - if (n_vararg < 0) - n_vararg = 0; - typ = symtyps->types[j - 1]; - while (i < num_args) { - if (flag & RtParm) { - MrgTyp(n_intrtyp, arg_typs->types[i], typ) - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - else { - typ_deref(arg_typs->types[i], typ, 0); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - ++i; - } - nparms -= 1; /* Don't extend with nulls into variable part */ - } - } - while (i < nparms) { - if (impl->arg_flgs[i] & RtParm) - set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ - if (impl->arg_flgs[i] & DrfPrm) - set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ - ++i; - } - - /* - * If this operation can suspend, there may be backtracking paths - * to this invocation. Merge type information from those paths - * into the current store. - */ - if (impl->ret_flag & DoesSusp) - mrg_store(n->store, succ_store); - - cur_symtyps = symtyps; - cur_rslt.bits = rslt_typ; - cur_rslt.size = n_intrtyp; - cur_new = n->new_types; - infer_il(impl->in_line); /* perform inference on operation */ - - if (MightFail(impl->ret_flag)) - mrg_store(succ_store, fail_store); - -#ifdef TypTrc - if (trcfile != NULL) { - if (impl->oper_typ != 'K') - fprintf(trcfile, ")"); - fprintf(trcfile, " =>> "); - prt_typ(trcfile, rslt_typ); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - -/* - * chk_succ - check to see if the operation can succeed. In particular, - * see if it can suspend. Change the succ_store and failure store - * appropriately. - */ -static void chk_succ(ret_flag, susp_stor) -int ret_flag; -struct store *susp_stor; - { - if (ret_flag & DoesSusp) { - if (susp_stor != NULL && (ret_flag & DoesRet)) - mrg_store(susp_stor, fail_store); /* "pass along" failure */ - fail_store = susp_stor; - } - else if (!(ret_flag & DoesRet)) { - free_store(succ_store); - succ_store = get_store(1); - fail_store = dummy_stor; /* shouldn't be used */ - } - } - -/* - * infer_il - perform type inference on a piece of code within built-in - * operation and determine whether execution can get past it. - */ -static int infer_il(il) -struct il_code *il; - { - struct il_code *il1; - int condition; - int case_fnd; - int ncases; - int may_fallthru; - int indx; - int i; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 0; - - case IL_If1: - condition = eval_cond(il->u[0].fld); - may_fallthru = (condition & MaybeFalse); - if (condition & MaybeTrue) - may_fallthru |= infer_il(il->u[1].fld); - return may_fallthru; - - case IL_If2: - condition = eval_cond(il->u[0].fld); - may_fallthru = 0; - if (condition & MaybeTrue) - may_fallthru |= infer_il(il->u[1].fld); - if (condition & MaybeFalse) - may_fallthru |= infer_il(il->u[2].fld); - return may_fallthru; - - case IL_Tcase1: - type_case(il, infer_il, NULL); - return 1; /* no point in trying very hard here */ - - case IL_Tcase2: - indx = type_case(il, infer_il, NULL); - if (indx != -1) - infer_il(il->u[indx].fld); /* default */ - return 1; /* no point in trying very hard here */ - - case IL_Lcase: - ncases = il->u[0].n; - indx = 1; - case_fnd = 0; - for (i = 0; i < ncases && !case_fnd; ++i) { - if (il->u[indx++].n == n_vararg) { /* selection number */ - infer_il(il->u[indx].fld); /* action */ - case_fnd = 1; - } - ++indx; - } - if (!case_fnd) - infer_il(il->u[indx].fld); /* default */ - return 1; /* no point in trying very hard here */ - - case IL_Acase: { - int maybe_int; - int maybe_dbl; - - eval_arith((int)il->u[0].fld->u[0].n, (int)il->u[1].fld->u[0].n, - &maybe_int, &maybe_dbl); - if (maybe_int) { - infer_il(il->u[2].fld); /* C_integer action */ - if (largeints) - infer_il(il->u[3].fld); /* integer action */ - } - if (maybe_dbl) - infer_il(il->u[4].fld); /* C_double action */ - return 1; /* no point in trying very hard here */ - } - - case IL_Err1: - case IL_Err2: - return 0; - - case IL_Block: - return il->u[0].n; - - case IL_Call: - return ((il->u[3].n & DoesFThru) != 0); - - case IL_Lst: - if (infer_il(il->u[0].fld)) - return infer_il(il->u[1].fld); - else - return 0; - - case IL_Abstr: - /* - * Handle side effects. - */ - il1 = il->u[0].fld; - if (il1 != NULL) { - while (il1->il_type == IL_Lst) { - side_effect(il1->u[1].fld); - il1 = il1->u[0].fld; - } - side_effect(il1); - } - - /* - * Set return type. - */ - abstr_typ(il->u[1].fld, &cur_rslt); - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * side_effect - perform a side effect from an abstract clause of a - * built-in operation. - */ -static void side_effect(il) -struct il_code *il; - { - struct type *var_typ; - struct type *val_typ; - struct store *store; - int num_bits; - int frst_bit; - int i, j; - - /* - * il is IL_TpAsgn, get the variable type and value type, and perform - * the side effect. - */ - var_typ = get_wktyp(); - val_typ = get_wktyp(); - abstr_typ(il->u[0].fld, var_typ); /* variable type */ - abstr_typ(il->u[1].fld, val_typ); /* value type */ - - /* - * Determine which types that can be assigned to are in the variable - * type. - * - * Aggregate compontents. - */ - for (i = 0; i < num_cmpnts; ++i) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(var_typ->bits, frst_bit + j)) - ChkMrgTyp(n_icntyp, val_typ->bits, store->types[j]) - } - } - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(var_typ->bits, frst_fld + i)) - ChkMrgTyp(n_icntyp, val_typ->bits, fld_stor->types[i]); - - /* - * global variables - */ - for (i = 0; i < n_gbl; ++i) - if (bitset(var_typ->bits, frst_gbl + i)) - MrgTyp(n_icntyp, val_typ->bits, succ_store->types[i]); - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(var_typ->bits, frst_loc + i)) - MrgTyp(n_icntyp, val_typ->bits, succ_store->types[n_gbl + i]); - - - free_wktyp(var_typ); - free_wktyp(val_typ); - } - -/* - * abstr_typ - compute the type bits corresponding to an abstract type - * from an abstract clause of a built-in operation. - */ -static void abstr_typ(il, typ) -struct il_code *il; -struct type *typ; - { - struct type *typ1; - struct type *typ2; - struct rentry *rec; - struct store *store; - struct compnt_info *compnts; - int num_bits; - int frst_bit; - int frst_cmpnt; - int num_comps; - int typcd; - int new_indx; - int i; - int j; - int indx; - int size; - int t_indx; -#ifdef OptimizeType - struct typinfo *prmtyp; -#else /* OptimizeType */ - unsigned int *prmtyp; -#endif /* OptimizeType */ - - if (il == NULL) - return; - - switch (il->il_type) { - case IL_VarTyp: - /* - * type(<parameter>) - */ - indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ - if (indx >= cur_symtyps->nsyms) { - prmtyp = any_typ; - size = n_rttyp; - } - else { - prmtyp = cur_symtyps->types[indx]; - size = n_intrtyp; - } - if (typ->size < size) - size = typ->size; - MrgTyp(size, prmtyp, typ->bits); - break; - - case IL_Store: - /* - * store[<type>] - */ - typ1 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); /* type to be "dereferenced" */ - - /* - * Dereference types that are Icon varaibles. - */ - typ_deref(typ1->bits, typ->bits, 0); - - /* - * "Dereference" aggregate compontents that are not Icon variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (!typecompnt[i].var) { - if (i == stv_typ) { - /* - * Substring trapped variable stores contain variable - * references, so the types are larger, but we cannot - * copy more than the destination holds. - */ - size = n_intrtyp; - if (typ->size < size) - size = typ->size; - } - else - size = n_icntyp; - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ1->bits, frst_bit + j)) - MrgTyp(size, store->types[j], typ->bits); - } - } - } - - free_wktyp(typ1); - break; - - case IL_Compnt: - /* - * <type>.<component> - */ - typ1 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); /* type */ - i = il->u[1].n; - if (i == CM_Fields) { - /* - * The all_fields component must be handled differently - * from the others. - */ - frst_bit = type_array[rec_typ].frst_bit; - num_bits = type_array[rec_typ].num_bits; - for (i = 0; i < num_bits; ++i) - if (bitset(typ1->bits, frst_bit + i)) { - rec = rec_map[i]; - for (j = 0; j < rec->nfields; ++j) - set_typ(typ->bits, frst_fld + rec->frst_fld + j); - } - } - else { - /* - * Use component information arrays to transform type bits to - * the corresponding component bits. - */ - frst_bit = type_array[typecompnt[i].aggregate].frst_bit; - num_bits = type_array[typecompnt[i].aggregate].num_bits; - frst_cmpnt = compnt_array[i].frst_bit; - if (!typecompnt[i].var && typ->size < n_rttyp) - break; /* bad abstract type computation */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ1->bits, frst_bit + i)) - set_typ(typ->bits, frst_cmpnt + i); - free_wktyp(typ1); - } - break; - - case IL_Union: - /* - * <type 1> ++ <type 2> - */ - abstr_typ(il->u[0].fld, typ); - abstr_typ(il->u[1].fld, typ); - break; - - case IL_Inter: - /* - * <type 1> ** <type 2> - */ - typ1 = get_wktyp(); - typ2 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); - abstr_typ(il->u[1].fld, typ2); - size = n_rttyp; -#ifdef OptimizeType - and_bits_to_packed(typ2->bits, typ1->bits, size); -#else /* OptimizeType */ - for (i = 0; i < NumInts(size); ++i) - typ1->bits[i] &= typ2->bits[i]; -#endif /* OptimizeType */ - if (typ->size < size) - size = typ->size; - MrgTyp(size, typ1->bits, typ->bits); - free_wktyp(typ1); - free_wktyp(typ2); - break; - - case IL_New: - /* - * new <type-name>(<type 1> , ...) - * - * If a type was not allocated for this node, use the default - * one. - */ - typ1 = get_wktyp(); - typcd = il->u[0].n; /* type code */ - new_indx = type_array[typcd].new_indx; - t_indx = 0; /* default is first index of type */ - if (cur_new != NULL && cur_new[new_indx] > 0) - t_indx = cur_new[new_indx]; - - /* - * This RTL expression evaluates to the "new" sub-type. - */ - set_typ(typ->bits, type_array[typcd].frst_bit + t_indx); - - /* - * Update stores for components based on argument types in the - * "new" expression. - */ - num_comps = icontypes[typcd].num_comps; - j = icontypes[typcd].compnts; - compnts = &compnt_array[j]; - if (typcd == stv_typ) { - size = n_intrtyp; - } - else - size = n_icntyp; - for (i = 0; i < num_comps; ++i) { - ClrTyp(n_rttyp, typ1->bits); - abstr_typ(il->u[2 + i].fld, typ1); - ChkMrgTyp(size, typ1->bits, compnts[i].store->types[t_indx]); - } - - free_wktyp(typ1); - break; - - case IL_IcnTyp: - typcd_bits((int)il->u[0].n, typ); /* type code */ - break; - } - } - -/* - * eval_cond - evaluate the condition of in 'if' statement from a - * built-in operation. The result can be both true and false because - * of uncertainty and because more than one execution path may be - * involved. - */ -static int eval_cond(il) -struct il_code *il; - { - int cond1; - int cond2; - - switch (il->il_type) { - case IL_Bang: - cond1 = eval_cond(il->u[0].fld); - cond2 = 0; - if (cond1 & MaybeTrue) - cond2 = MaybeFalse; - if (cond1 & MaybeFalse) - cond2 |= MaybeTrue; - return cond2; - - case IL_And: - cond1 = eval_cond(il->u[0].fld); - cond2 = eval_cond(il->u[1].fld); - return (cond1 & cond2 & MaybeTrue) | ((cond1 | cond2) & MaybeFalse); - - case IL_Cnv1: - case IL_Cnv2: - return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, - 0, NULL); - - case IL_Def1: - case IL_Def2: - return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, - 1, NULL); - - case IL_Is: - return eval_is((int)il->u[0].n, il->u[1].fld->u[0].n); - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * eval_cnv - evaluate the conversion of a variable to a specific type - * to see if it may succeed or fail. - */ -int eval_cnv(typcd, indx, def, cnv_flags) -int typcd; /* type to convert to */ -int indx; /* index into symbol table of variable */ -int def; /* flag: conversion has a default value */ -int *cnv_flags; /* return flag for detailed conversion information */ - { - struct type *may_succeed; /* types where conversion sometimes succeed */ - struct type *must_succeed; /* types where conversion always succeeds */ - struct type *must_cnv; /* types where actual conversion is performed */ - struct type *as_is; /* types where value already has correct type */ -#ifdef OptimizeType - struct typinfo *typ; /* possible types of the variable */ -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int cond; - int i; -#ifdef OptimizeType - unsigned int val1, val2; -#endif /* OptimizeType */ - - /* - * Conversions may succeed for strings, integers, csets, and reals. - * Conversions may fail for any other types. In addition, - * conversions to integer or real may fail for specific values. - */ - if (indx >= cur_symtyps->nsyms) - return MaybeTrue | MaybeFalse; - typ = cur_symtyps->types[indx]; - - may_succeed = get_wktyp(); - must_succeed = get_wktyp(); - must_cnv = get_wktyp(); - as_is = get_wktyp(); - - if (typcd == cset_typ || typcd == TypTCset) { - set_typ(as_is->bits, cset_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == str_typ || typcd == TypTStr) { - set_typ(as_is->bits, str_bit); - - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == TypCStr) { - /* - * as_is is empty. - */ - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == real_typ) { - set_typ(as_is->bits, real_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == TypCDbl) { - /* - * as_is is empty. - */ - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == int_typ) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypCInt) { - /* - * Note that conversion from an integer to a C integer can be - * done by changing the way the descriptor is accessed. It - * is not considered a real conversion. Conversion may fail - * even for integers if large integers are supported. - */ - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, real_bit); - - if (!largeints) - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypEInt) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypECInt) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - - if (!largeints) - set_typ(must_succeed->bits, int_bit); - } - - MrgTyp(n_icntyp, as_is->bits, may_succeed->bits); - MrgTyp(n_icntyp, must_cnv->bits, may_succeed->bits); - if (def) { - set_typ(may_succeed->bits, null_bit); - set_typ(must_succeed->bits, null_bit); - } - - /* - * Determine if the conversion expression may evaluate to true or false. - */ - cond = 0; - -/* - if (typ->bits == NULL) { - typ->bits = alloc_mem_typ(typ->size); - xfer_packed_types(typ); - } - if (may_succeed->bits->bits == NULL) { - may_succeed->bits->bits = alloc_mem_typ(may_succeed->bits->size); - xfer_packed_types(may_succeed->bits); - } - if (must_succeed->bits->bits == NULL) { - must_succeed->bits->bits = alloc_mem_typ(must_succeed->bits->size); - xfer_packed_types(must_succeed->bits); - } -*/ - for (i = 0; i < NumInts(n_intrtyp); ++i) { -#ifdef OptimizeType - if ((typ->bits != NULL) && (may_succeed->bits->bits != NULL)) { - if (typ->bits[i] & may_succeed->bits->bits[i]) - cond = MaybeTrue; - } - else if ((typ->bits == NULL) && (may_succeed->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & may_succeed->bits->bits[i]) - cond = MaybeTrue; - } - else if ((typ->bits != NULL) && (may_succeed->bits->bits == NULL)) { - val2 = get_bit_vector(may_succeed->bits, i); - if (typ->bits[i] & val2) - cond = MaybeTrue; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(may_succeed->bits, i); - if (val1 & val2) - cond = MaybeTrue; - } - if ((typ->bits != NULL) && (must_succeed->bits->bits != NULL)) { - if (typ->bits[i] & ~must_succeed->bits->bits[i]) - cond |= MaybeFalse; - } - else if ((typ->bits == NULL) && (must_succeed->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & ~must_succeed->bits->bits[i]) - cond |= MaybeFalse; - } - else if ((typ->bits != NULL) && (must_succeed->bits->bits == NULL)) { - val2 = get_bit_vector(must_succeed->bits, i); - if (typ->bits[i] & ~val2) - cond |= MaybeFalse; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(must_succeed->bits, i); - if (val1 & ~val2) - cond |= MaybeFalse; - } -#else /* OptimizeType */ - if (typ[i] & may_succeed->bits[i]) - cond = MaybeTrue; - if (typ[i] & ~must_succeed->bits[i]) - cond |= MaybeFalse; -#endif /* OptimizeType */ - } - - /* - * See if more detailed information about the conversion is needed. - */ - if (cnv_flags != NULL) { - *cnv_flags = 0; -/* - if (as_is->bits == NULL) { - as_is->bits->bits = alloc_mem_typ(as_is->bits->size); - xfer_packed_types(as_is->bits); - } - if (must_cnv->bits->bits == NULL) { - must_cnv->bits->bits = alloc_mem_typ(must_cnv->bits->size); - xfer_packed_types(must_cnv->bits); - } -*/ - for (i = 0; i < NumInts(n_intrtyp); ++i) { -#ifdef OptimizeType - if ((typ->bits != NULL) && (as_is->bits->bits != NULL)) { - if (typ->bits[i] & as_is->bits->bits[i]) - *cnv_flags |= MayKeep; - } - else if ((typ->bits == NULL) && (as_is->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & as_is->bits->bits[i]) - *cnv_flags |= MayKeep; - } - else if ((typ->bits != NULL) && (as_is->bits->bits == NULL)) { - val2 = get_bit_vector(as_is->bits, i); - if (typ->bits[i] & val2) - *cnv_flags |= MayKeep; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(as_is->bits, i); - if (val1 & val2) - *cnv_flags |= MayKeep; - } - if ((typ->bits != NULL) && (must_cnv->bits->bits != NULL)) { - if (typ->bits[i] & must_cnv->bits->bits[i]) - *cnv_flags |= MayConvert; - } - else if ((typ->bits == NULL) && (must_cnv->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & must_cnv->bits->bits[i]) - *cnv_flags |= MayConvert; - } - else if ((typ->bits != NULL) && (must_cnv->bits->bits == NULL)) { - val2 = get_bit_vector(must_cnv->bits, i); - if (typ->bits[i] & val2) - *cnv_flags |= MayConvert; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(must_cnv->bits, i); - if (val1 & val2) - *cnv_flags |= MayConvert; - } -#else /* OptimizeType */ - if (typ[i] & as_is->bits[i]) - *cnv_flags |= MayKeep; - if (typ[i] & must_cnv->bits[i]) - *cnv_flags |= MayConvert; -#endif /* OptimizeType */ - } - if (def && bitset(typ, null_bit)) - *cnv_flags |= MayDefault; - } - - free_wktyp(may_succeed); - free_wktyp(must_succeed); - free_wktyp(must_cnv); - free_wktyp(as_is); - - return cond; - } - -/* - * eval_is - evaluate the result of an 'is' expression within a built-in - * operation. - */ -int eval_is(typcd, indx) -int typcd; -int indx; - { - int cond; -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - - if (indx >= cur_symtyps->nsyms) - return MaybeTrue | MaybeFalse; - typ = cur_symtyps->types[indx]; - if (has_type(typ, typcd, 0)) - cond = MaybeTrue; - else - cond = 0; - if (other_type(typ, typcd)) - cond |= MaybeFalse; - return cond; - } - -/* - * eval_arith - determine which cases of an arith_case may be taken based - * on the types of its arguments. - */ -void eval_arith(indx1, indx2, maybe_int, maybe_dbl) -int indx1; -int indx2; -int *maybe_int; -int *maybe_dbl; - { -#ifdef OptimizeType - struct typinfo *typ1; /* possible types of first variable */ - struct typinfo *typ2; /* possible types of second variable */ -#else /* OptimizeType */ - unsigned int *typ1; /* possible types of first variable */ - unsigned int *typ2; /* possible types of second variable */ -#endif /* OptimizeType */ - int int1 = 0; - int int2 = 0; - int dbl1 = 0; - int dbl2 = 0; - - typ1 = cur_symtyps->types[indx1]; - typ2 = cur_symtyps->types[indx2]; - - /* - * First see what might result if you do a convert to numeric on each - * variable. - */ - if (bitset(typ1, int_bit)) - int1 = 1; - if (bitset(typ1, real_bit)) - dbl1 = 1; - if (bitset(typ1, str_bit) || bitset(typ1, cset_bit)) { - int1 = 1; - dbl1 = 1; - } - if (bitset(typ2, int_bit)) - int2 = 1; - if (bitset(typ2, real_bit)) - dbl2 = 1; - if (bitset(typ2, str_bit) || bitset(typ2, cset_bit)) { - int2 = 1; - dbl2 = 1; - } - - /* - * Use the conversion information to figure out what type of arithmetic - * might be done. - */ - if (int1 && int2) - *maybe_int = 1; - else - *maybe_int = 0; - - *maybe_dbl = 0; - if (dbl1 && dbl2) - *maybe_dbl = 1; - else if (dbl1 && int2) - *maybe_dbl = 1; - else if (int1 && dbl2) - *maybe_dbl = 1; - } - -/* - * type_case - Determine which cases are selected in a type_case - * statement. This routine is used by both type inference and - * the code generator: a different fnc is passed in each case. - * In addition, the code generator passes a case_anlz structure. - */ -int type_case(il, fnc, case_anlz) -struct il_code *il; -int (*fnc)(); -struct case_anlz *case_anlz; - { - int *typ_vect; - int i, j; - int num_cases; - int num_types; - int indx; - int sym_indx; - int typcd; - int use_dflt; -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int select; - struct type *wktyp; - - /* - * Make a copy of the type of the variable the type case is - * working on. - */ - sym_indx = il->u[0].fld->u[0].n; /* symbol table index */ - if (sym_indx >= cur_symtyps->nsyms) - typ = any_typ; /* variable is not a parameter, don't know type */ - else - typ = cur_symtyps->types[sym_indx]; - wktyp = get_wktyp(); - CpyTyp(n_intrtyp, typ, wktyp->bits); - typ = wktyp->bits; - - /* - * Loop through all the case clauses. - */ - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - /* - * For each of the types selected by this clause, see if the variable's - * type bit vector contains that type and delete the type from the - * bit vector (so we know if we need the default when we are done). - */ - num_types = il->u[indx++].n; - typ_vect = il->u[indx++].vect; - select = 0; - for (j = 0; j < num_types; ++j) - if (has_type(typ, typ_vect[j], 1)) { - typcd = typ_vect[j]; - select += 1; - } - - if (select > 0) { - fnc(il->u[indx].fld); /* action */ - - /* - * If this routine was called by the code generator, we need to - * return extra information. - */ - if (case_anlz != NULL) { - ++case_anlz->n_cases; - if (select == 1) { - if (case_anlz->il_then == NULL) { - case_anlz->typcd = typcd; - case_anlz->il_then = il->u[indx].fld; - } - else if (case_anlz->il_else == NULL) - case_anlz->il_else = il->u[indx].fld; - } - else { - /* - * There is more than one possible type that will cause - * us to select this case. It can only be used in the "else". - */ - if (case_anlz->il_else == NULL) - case_anlz->il_else = il->u[indx].fld; - else - case_anlz->n_cases = 3; /* force no inlining. */ - } - } - } - ++indx; - } - - /* - * If there are types that have not been handled, indicate this by - * returning the index of the default clause. - */ - use_dflt = 0; - for (i = 0; i < n_intrtyp; ++i) - if (bitset(typ, i)) { - use_dflt = 1; - break; - } - free_wktyp(wktyp); - if (use_dflt) - return indx; - else - return -1; - } - -/* - * gen_inv - general invocation. The argument list is set up, perform - * abstract interpretation on each possible things being invoked. - */ -static void gen_inv(typ, n) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -nodeptr n; - { - int ret_flag = 0; - struct store *s_store; - struct store *store; - struct gentry *gptr; - struct implement *ip; - struct type *prc_typ; - int frst_prc; - int num_prcs; - int i; - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) {\n", n->n_file, n->n_line, n->n_col); - trc_indent = " "; - } -#endif /* TypTrc */ - - frst_prc = type_array[proc_typ].frst_bit; - num_prcs = type_array[proc_typ].num_bits; - - /* - * Dereference the type of the thing being invoked. - */ - prc_typ = get_wktyp(); - typ_deref(typ, prc_typ->bits, 0); - - s_store = succ_store; - store = get_store(1); - - if (bitset(prc_typ->bits, str_bit) || - bitset(prc_typ->bits, cset_bit) || - bitset(prc_typ->bits, int_bit) || - bitset(prc_typ->bits, real_bit)) { - /* - * Assume integer invocation; any argument may be the result type. - */ - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s{i}(", n->n_file, n->n_line, n->n_col, - trc_indent); - } -#endif /* TypTrc */ - - for (i = 0; i < num_args; ++i) { - MrgTyp(n_intrtyp, arg_typs->types[i], n->type); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * Integer invocation may succeed or fail. - */ - ret_flag |= DoesRet | DoesFail; - mrg_store(s_store, store); - mrg_store(s_store, fail_store); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, ") =>> "); - prt_typ(trcfile, n->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - - if (bitset(prc_typ->bits, str_bit) || - bitset(prc_typ->bits, cset_bit)) { - /* - * Assume string invocation; add all procedure types to the thing - * being invoked. - */ - for (i = 0; i < num_prcs; ++i) - set_typ(prc_typ->bits, frst_prc + i); - } - - if (bitset(prc_typ->bits, frst_prc)) { - /* - * First procedure type represents all operators that are - * available via string invocation. Scan the operator table - * looking for those that are in the string invocation table. - * Note, this is not particularly efficient or precise. - */ - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->iconc_flgs & InStrTbl) { - succ_store = cpy_store(s_store); - infer_impl(ip, n, n->symtyps, n->type); - ret_flag |= ip->ret_flag; - mrg_store(succ_store, store); - free_store(succ_store); - } - } - - /* - * Check for procedure, built-in, and record constructor types - * and perform type inference on invocations of them. - */ - for (i = 1; i < num_prcs; ++i) - if (bitset(prc_typ->bits, frst_prc + i)) { - succ_store = cpy_store(s_store); - gptr = proc_map[i]; - switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - infer_prc(gptr->val.proc, n); - ret_flag |= gptr->val.proc->ret_flag; - break; - case F_Builtin: - infer_impl(gptr->val.builtin, n, n->symtyps, n->type); - ret_flag |= gptr->val.builtin->ret_flag; - break; - case F_Record: - infer_con(gptr->val.rec, n); - ret_flag |= DoesRet | (err_conv ? DoesFail : 0); - break; - } - mrg_store(succ_store, store); - free_store(succ_store); - } - - /* - * If error conversion is supported and a non-procedure value - * might be invoked, assume the invocation can fail. - */ - if (err_conv && other_type(prc_typ->bits, proc_typ)) - mrg_store(s_store, fail_store); - - free_store(s_store); - succ_store = store; - chk_succ(ret_flag, n->store); - - free_wktyp(prc_typ); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) }\n", n->n_file, n->n_line, n->n_col); - trc_indent = ""; - } -#endif /* TypTrc */ - } - -/* - * get_wktyp - get a dynamically allocated bit vector to use as a - * work area for doing type computations. - */ -static struct type *get_wktyp() - { - struct type *typ; - - if ((typ = type_pool) == NULL) { - typ = NewStruct(type); - typ->size = n_rttyp; - typ->bits = alloc_typ(n_rttyp); - } - else { - type_pool = type_pool->next; - ClrTyp(n_rttyp, typ->bits); - } - return typ; - } - -/* - * free_wktyp - free a dynamically allocated type bit vector. - */ -static void free_wktyp(typ) -struct type *typ; - { - typ->next = type_pool; - type_pool = typ; - } - -#ifdef TypTrc - -/* - * ChkSep - supply a separating space if this is not the first item. - */ -#define ChkSep(n) (++n > 1 ? " " : "") - -/* - * prt_typ - print a type that can include variable references. - */ -static void prt_typ(file, typ) -FILE *file; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ - { - struct gentry *gptr; - struct lentry *lptr; - char *name; - int i, j, k; - int n; - int frst_bit; - int num_bits; - char *abrv; - - fprintf(trcfile, "{"); - n = 0; - /* - * Go through the types and see any sub-types are present. - */ - for (k = 0; k < num_typs; ++k) { - frst_bit = type_array[k].frst_bit; - num_bits = type_array[k].num_bits; - abrv = icontypes[k].abrv; - if (k == proc_typ) { - /* - * procedures, record constructors, and built-in functions. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) { - if (i == 0) - fprintf(file, "%sops", ChkSep(n)); - else { - gptr = proc_map[i]; - switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - fprintf(file, "%s%s:%s", ChkSep(n), abrv, gptr->name); - break; - case F_Builtin: - fprintf(file, "%sfnc:%s", ChkSep(n), gptr->name); - break; - case F_Record: - fprintf(file, "%sconstr:%s", ChkSep(n), gptr->name); - break; - } - } - } - } - else if (k == rec_typ) { - /* - * records - include record name. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s:%s", ChkSep(n), abrv, rec_map[i]->name); - } - else if (icontypes[k].support_new | k == coexp_typ) { - /* - * A type with sub-types. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s%d", ChkSep(n), abrv, i); - } - else { - /* - * A type with no subtypes. - */ - if (bitset(typ, frst_bit)) - fprintf(file, "%s%s", ChkSep(n), abrv); - } - } - - for (k = 0; k < num_cmpnts; ++k) { - if (typecompnt[k].var) { - /* - * Structure component that is a variable. - */ - frst_bit = compnt_array[k].frst_bit; - num_bits = compnt_array[k].num_bits; - abrv = typecompnt[k].abrv; - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s%d", ChkSep(n), abrv, i); - } - } - - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(typ, frst_fld + i)) - fprintf(file, "%sfld%d", ChkSep(n), i); - - /* - * global variables - */ - for (i = 0; i < n_nmgbl; ++i) - if (bitset(typ, frst_gbl + i)) { - name = NULL; - for (j = 0; j < GHSize && name == NULL; j++) - for (gptr = ghash[j]; gptr != NULL && name == NULL; - gptr = gptr->blink) - if (gptr->index == i) - name = gptr->name; - for (lptr = cur_proc->statics; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - /* - * Static variables may be returned and dereferenced in a procedure - * they don't belong to. - */ - if (name == NULL) - name = "?static?"; - fprintf(file, "%svar:%s", ChkSep(n), name); - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(typ, frst_loc + i)) { - name = NULL; - for (lptr = cur_proc->args; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - for (lptr = cur_proc->dynams; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - /* - * Local variables types may appear in the wrong procedure due to - * substring trapped variables and the inference of impossible - * execution paths. Make sure we don't end up with a NULL name. - */ - if (name == NULL) - name = "?"; - fprintf(file, "%svar:%s", ChkSep(n), name); - } - - fprintf(trcfile, "}"); - } - -/* - * prt_d_typ - dereference a type and print it. - */ -static void prt_d_typ(file, typ) -FILE *file; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -{ - struct type *wktyp; - - wktyp = get_wktyp(); - typ_deref(typ, wktyp->bits, 0); - prt_typ(file, wktyp->bits); - free_wktyp(wktyp); -} -#endif /* TypTrc */ - -/* - * get_argtyp - get an array of pointers to type bit vectors for use - * in constructing an argument list. The array is large enough for the - * largest argument list. - */ -static struct argtyps *get_argtyp() - { - struct argtyps *argtyps; - - if ((argtyps = argtyp_pool) == NULL) -#ifdef OptimizeType - argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + - ((max_prm - 1) * sizeof(struct typinfo *)))); -#else /* OptimizeType */ - argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + - ((max_prm - 1) * sizeof(unsigned int *)))); -#endif /* OptimizeType */ - else - argtyp_pool = argtyp_pool->next; - return argtyps; - } - -/* - * free_argtyp - free array of pointers to type bitvectors. - */ -static void free_argtyp(argtyps) -struct argtyps *argtyps; - { - argtyps->next = argtyp_pool; - argtyp_pool = argtyps; - } - -/* - * varsubtyp - examine a type and determine what kinds of variable - * subtypes it has and whether it has any non-variable subtypes. - * If the type consists of a single named variable, return its symbol - * table entry through the parameter "singl". - */ -int varsubtyp(typ, singl) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -struct lentry **singl; - { - struct store *stv_stor; - int subtypes; - int n_types; - int var_indx; - int frst_bit; - int num_bits; - int i, j; - - - subtypes = 0; - n_types = 0; - var_indx = -1; - - /* - * check for non-variables. - */ - for (i = 0; i < n_icntyp; ++i) - if (bitset(typ, i)) { - subtypes |= HasVal; - ++n_types; - } - - /* - * Predefined variable types. - */ - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].deref != DrfNone) { - frst_bit = type_array[i].frst_bit; - num_bits = type_array[i].num_bits; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ, frst_bit + j)) { - if (i == stv_typ) { - /* - * We have found substring trapped variable j, see whether it - * references locals or globals. - */ - if (do_typinfer) { - stv_stor = compnt_array[str_var].store; - subtypes |= varsubtyp(stv_stor->types[j], NULL); - } - else - subtypes |= HasLcl | HasPrm | HasGlb; - } - else - subtypes |= HasGlb; - ++n_types; - } - } - } - } - - /* - * Aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (typecompnt[i].var) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ, frst_bit + j)) { - subtypes |= HasGlb; - ++n_types; - } - } - } - } - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(typ, frst_fld + i)) { - subtypes |= HasGlb; - ++n_types; - } - - /* - * global variables, including statics - */ - for (i = 0; i < n_gbl; ++i) { - if (bitset(typ, frst_gbl + i)) { - subtypes |= HasGlb; - var_indx = i; - ++n_types; - } - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) { - if (bitset(typ, frst_loc + i)) { - if (i < Abs(cur_proc->nargs)) - subtypes |= HasPrm; - else - subtypes |= HasLcl; - var_indx = n_gbl + i; - ++n_types; - } - } - - if (singl != NULL) { - /* - * See if the type consists of a single named variable. - */ - if (n_types == 1 && var_indx != -1) - *singl = cur_proc->vartypmap[var_indx]; - else - *singl = NULL; - } - - return subtypes; - } - -/* - * mark_recs - go through the list of parent records for this field - * and mark those that are in the type. Also gather information - * to help generate better code. - */ -void mark_recs(fp, typ, num_offsets, offset, bad_recs) -struct fentry *fp; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int *num_offsets; -int *offset; -int *bad_recs; - { - struct par_rec *rp; - struct type *wktyp; - int frst_rec; - - *num_offsets = 0; - *offset = -1; - *bad_recs = 0; - - wktyp = get_wktyp(); - CpyTyp(n_icntyp, typ, wktyp->bits); - - /* - * For each record containing this field, see if the record is - * in the type. - */ - frst_rec = type_array[rec_typ].frst_bit; - for (rp = fp->rlist; rp != NULL; rp = rp->next) { - if (bitset(wktyp->bits, frst_rec + rp->rec->rec_num)) { - /* - * This record is in the type. - */ - rp->mark = 1; - clr_typ(wktyp->bits, frst_rec + rp->rec->rec_num); - if (*offset != rp->offset) { - *offset = rp->offset; - *num_offsets += 1; - } - } - } - - /* - * Are there any records that do not contain this field? - */ - *bad_recs = has_type(wktyp->bits, rec_typ, 0); - free_wktyp(wktyp); - } - -/* - * past_prms - return true if execution might continue past the parameter - * evaluation. If a parameter has no type, this will not happen. - */ -int past_prms(n) -nodeptr n; - { - struct implement *impl; - struct symtyps *symtyps; - int nparms; - int nargs; - int flag; - int i, j; - - nargs = Val0(n); - impl = Impl1(n); - symtyps = n->symtyps; - nparms = impl->nargs; - - if (symtyps == NULL) - return 1; - - j = 0; - for (i = 0; i < nparms; ++i) { - flag = impl->arg_flgs[i]; - if (flag & VarPrm && i >= nargs) - break; /* no parameters for variable part of arg list */ - if (flag & RtParm) { - if (is_empty(symtyps->types[j])) - return 0; - ++j; - } - if (flag & DrfPrm) { - if (is_empty(symtyps->types[j])) - return 0; - ++j; - } - } - return 1; - } diff --git a/src/icont/Makefile b/src/icont/Makefile index 8f15f9d..db0927f 100644 --- a/src/icont/Makefile +++ b/src/icont/Makefile @@ -22,7 +22,7 @@ icont: $(OBJS) $(COBJS) $(CC) $(CFLAGS) $(LDFLAGS) -o icont $(OBJS) $(COBJS) cp icont ../../bin strip ../../bin/icont$(EXE) - (cd ../../bin; rm -f icon; ln -s icont icon) + (cd ../../bin; rm -f icon icon.exe; ln -s icont icon) $(OBJS): $(HFILES) tproto.h @@ -45,7 +45,7 @@ tree.o: tree.h tsym.o: tglobals.h tsym.h ttoken.h lfile.h keyword.h ../h/kdefs.h # linker files -$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h ../h/monitor.h \ +$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h \ ../h/rstructs.h ../h/rmacros.h ../h/rexterns.h link.o: tglobals.h hdr.h ../h/header.h diff --git a/src/icont/lcode.c b/src/icont/lcode.c index a1481f1..a1c7a57 100644 --- a/src/icont/lcode.c +++ b/src/icont/lcode.c @@ -38,15 +38,6 @@ static void outblock (char *addr,int count); static void setfile (void); static void wordout (word oword); -#ifdef FieldTableCompression - static void charout (unsigned char oint); - static void shortout (short oint); -#endif /* FieldTableCompression */ - -#ifdef DeBugLinker - static void dumpblock (char *addr,int count); -#endif /* DeBugLinker */ - word pc = 0; /* simulated program counter */ #define outword(n) wordout((word)(n)) @@ -243,71 +234,22 @@ void gencode() case Op_Lab: lab = getlab(); newline(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "L%d:\n", lab); - #endif /* DeBugLinker */ backpatch(lab); break; case Op_Line: - /* - * Line number change. - * All the interesting stuff happens in Op_Colm now. - */ lineno = getdec(); - - #ifndef SrcColumnInfo - /* - * Enter the value in the line number table - * that is stored in the icode file and used during error - * handling and execution monitoring. One can generate a VM - * instruction for these changes, but since the numbers are not - * saved and restored during backtracking, it is more accurate - * to check for line number changes in-line in the interpreter. - * Fortunately, the in-line check is about as fast as executing - * Op_Line instructions. All of this is complicated by the use - * of Op_Line to generate Noop instructions when enabled by the - * LineCodes #define. - * - * If SrcColumnInfo is required, this code is duplicated, - * with changes, in the Op_Colm case below. - */ - if (lnfree >= &lntable[nsize]) - lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, - sizeof(struct ipc_line), 1, "line number table"); - lnfree->ipc = pc; - lnfree->line = lineno; - lnfree++; - #endif /* SrcColumnInfo */ - - /* - * Could generate an Op_Line for monitoring, but don't anymore: - * - * lemitn(op, (word)lineno, name); - */ - newline(); - - #ifdef LineCodes - #ifndef EventMon - lemit(Op_Noop,"noop"); - #endif /* EventMon */ - #endif /* LineCodes */ - break; case Op_Colm: /* always recognize, maybe ignore */ - colmno = getdec(); - #ifdef SrcColumnInfo - if (lnfree >= &lntable[nsize]) - lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, - sizeof(struct ipc_line), 1, "line number table"); - lnfree->ipc = pc; - lnfree->line = lineno + (colmno << 16); - lnfree++; - #endif /* SrcColumnInfo */ + if (lnfree >= &lntable[nsize]) + lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, + sizeof(struct ipc_line), 1, "line number table"); + lnfree->ipc = pc; + lnfree->line = lineno + (colmno << 16); + lnfree++; break; case Op_Mark: @@ -368,10 +310,6 @@ void gencode() implicit = gp->g_flag & F_ImpError; nargs = gp->g_nargs; align(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\n# procedure %s\n", &lsspace[lsfree]); - #endif /* DeBugLinker */ } else { /* @@ -488,12 +426,6 @@ static void lemit(op, name) int op; char *name; { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name); - #endif /* DeBugLinker */ - outop(op); } @@ -503,11 +435,6 @@ char *name; { misalign(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name); - #endif /* DeBugLinker */ - if (lab >= maxlabels) labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word), lab - maxlabels + 1, "labels"); @@ -526,13 +453,6 @@ word n; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n, - name); - #endif /* DeBugLinker */ - outop(op); outword(n); } @@ -544,20 +464,7 @@ word loc; char *name; { misalign(); - loc -= pc + ((IntBits/ByteBits) + WordSize); - - #ifdef DeBugLinker - if (Dflag) { - if (loc >= 0) - fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op, - (long)loc, name); - else - fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op, - (long)-loc, name); - } - #endif /* DeBugLinker */ - outop(op); outword(loc); } @@ -568,13 +475,6 @@ word offset; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t%d,S+%ld\t\t\t# %s\n", (long)pc, op, n, - (long)offset, name); - #endif /* DeBugLinker */ - outop(op); outword(n); outword(offset); @@ -593,12 +493,6 @@ long i; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name); - #endif /* DeBugLinker */ - outop(op); outword(i); } @@ -628,23 +522,12 @@ register int k; x.f = lctable[k].c_val.rval; #endif /* Double */ - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile,"%ld:\t%d\t\t\t\t# real(%g)",(long)pc,T_Real, x.f); - dumpblock(x.ovly,sizeof(double)); - } - #endif /* DeBugLinker */ - outword(T_Real); #ifdef Double #if WordBits != 64 /* fill out real block with an empty word */ outword(0); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"\t0\t\t\t\t\t# padding\n"); - #endif /* DeBugLinker */ #endif /* WordBits != 64 */ #endif /* Double */ @@ -664,23 +547,9 @@ register int k; if (Testb(i, csbuf)) j++; } - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset); - fprintf(dbgfile, "\t%d\n",j); - } - #endif /* DeBugLinker */ - outword(T_Cset); outword(j); /* cset size */ outblock((char *)csbuf,sizeof(csbuf)); - - #ifdef DeBugLinker - if (Dflag) - dumpblock((char *)csbuf,CsetSize); - #endif /* DeBugLinker */ - } } @@ -699,19 +568,6 @@ int nargs, ndyn, nstat, fstat; size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat); p = &lsspace[name]; - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */ - fprintf(dbgfile, "\t%d\n", size); /* size of block */ - fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */ - fprintf(dbgfile, "\t%d\n", nargs); /* # arguments */ - fprintf(dbgfile, "\t%d\n", ndyn); /* # dynamic locals */ - fprintf(dbgfile, "\t%d\n", nstat); /* # static locals */ - fprintf(dbgfile, "\t%d\n", fstat); /* first static */ - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", /* name of procedure */ - (int)strlen(p), (long)(name), p); - } - #endif /* DeBugLinker */ outword(T_Proc); outword(size); @@ -732,13 +588,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Argument) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -751,13 +600,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Dynamic) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -770,13 +612,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Static) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -802,36 +637,11 @@ void gentables() */ align(); hdr.Records = pc; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "\n\n# global tables\n"); - fprintf(dbgfile, "\n%ld:\t%d\t\t\t\t# record blocks\n", - (long)pc, nrecords); - } - #endif /* DeBugLinker */ - outword(nrecords); for (gp = lgfirst; gp != NULL; gp = gp->g_next) { if ((gp->g_flag & F_Record) && gp->g_procid > 0) { s = &lsspace[gp->g_name]; gp->g_pc = pc; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\n", pc); - fprintf(dbgfile, "\t%d\n", T_Proc); - fprintf(dbgfile, "\t%d\n", RkBlkSize(gp)); - fprintf(dbgfile, "\t_mkrec\n"); - fprintf(dbgfile, "\t%d\n", gp->g_nargs); - fprintf(dbgfile, "\t-2\n"); - fprintf(dbgfile, "\t%d\n", gp->g_procid); - fprintf(dbgfile, "\t1\n"); - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(s), - (long)gp->g_name, s); - } - #endif /* DeBugLinker */ - outword(T_Proc); /* type code */ outword(RkBlkSize(gp)); outword(0); /* entry point (filled in by interp)*/ @@ -860,12 +670,6 @@ void gentables() fflush(stderr); exit(1); } - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", - (int)strlen(&lsspace[fp->f_name]), - fp->f_name, &lsspace[fp->f_name]); - #endif /* DeBugLinker */ outword(strlen(&lsspace[fp->f_name])); outword(fp->f_name); foundit++; @@ -885,265 +689,25 @@ void gentables() } } - #ifndef FieldTableCompression - /* * Output record/field table (not compressed). */ hdr.Ftab = pc; - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"\n%ld:\t\t\t\t\t# record/field table\n",(long)pc); - #endif /* DeBugLinker */ - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t\t\t\t\t# %s\n", (long)pc, - &lsspace[fp->f_name]); - #endif /* DeBugLinker */ rp = fp->f_rlist; for (i = 1; i <= nrecords; i++) { while (rp != NULL && rp->r_gp->g_procid < 0) rp = rp->r_link; /* skip unreferenced constructor */ if (rp != NULL && rp->r_gp->g_procid == i) { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\n", rp->r_fnum); - #endif /* DeBugLinker */ outop(rp->r_fnum); rp = rp->r_link; } else { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t-1\n"); - #endif /* DeBugLinker */ outop(-1); } - #ifdef DeBugLinker - if (Dflag && (i == nrecords || (i & 03) == 0)) - putc('\n', dbgfile); - #endif /* DeBugLinker */ } } - #else /* FieldTableCompression */ - - /* - * Output record/field table (compressed). - * This code has not been tested recently. - */ - { - int counter = 0, f_num, first, begin, end, entries; - int *f_fo, *f_row, *f_tabp; - char *f_bm; - int pointer, first_avail = 0, inserted, bytes; - hdr.Fo = pc; - - /* - * Compute the field width required for this binary; - * it is determined by the maximum # of fields in any one record. - */ - long ct = 0; - for (gp = lgfirst; gp != NULL; gp = gp->g_next) - if ((gp->g_flag & F_Record) && gp->g_procid > 0) - if (gp->g_nargs > ct) ct=gp->g_nargs; - if (ct > 65535L) hdr.FtabWidth = 4; - else if (ct > 254) hdr.FtabWidth = 2; /* 255 is (not present) */ - else hdr.FtabWidth = 1; - - /* Find out how many field names there are. */ - hdr.Nfields = 0; - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) - hdr.Nfields++; - - entries = hdr.Nfields * nrecords / 4 + 1; - f_tabp = malloc (entries * sizeof (int)); - for (i = 0; i < entries; i++) - f_tabp[i] = -1; - f_fo = malloc (hdr.Nfields * sizeof (int)); - - bytes = nrecords / 8; - if (nrecords % 8 != 0) - bytes++; - f_bm = calloc (hdr.Nfields, bytes); - f_row = malloc (nrecords * sizeof (int)); - f_num = 0; - - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { - rp = fp->f_rlist; - first = 1; - for (i = 0; i < nrecords; i++) { - while (rp != NULL && rp->r_gp->g_procid < 0) - rp = rp->r_link; /* skip unreferenced constructor */ - if (rp != NULL && rp->r_gp->g_procid == i + 1) { - if (first) { - first = 0; - begin = end = i; - } - else - end = i; - f_row[i] = rp->r_fnum; - rp = rp->r_link; - } - else { - f_row[i] = -1; - } - } - - inserted = 0; - pointer = first_avail; - while (!inserted) { - inserted = 1; - for (i = begin; i <= end; i++) { - if (pointer + (end - begin) >= entries) { - int j; - int old_entries = entries; - entries *= 2; - f_tabp = realloc (f_tabp, entries * sizeof (int)); - for (j = old_entries; j < entries; j++) - f_tabp[j] = -1; - } - if (f_row[i] != -1) - if (f_tabp[pointer + (i - begin)] != -1) { - inserted = 0; - break; - } - } - pointer++; - } - pointer--; - - /* Create bitmap */ - for (i = 0; i < nrecords; i++) { - int index = f_num * bytes + i / 8; - /* Picks out byte within bitmap row */ - if (f_row[i] != -1) { - f_bm[index] |= 01; - } - if (i % 8 != 7) - f_bm [index] <<= 1; - } - - if (nrecords%8) - f_bm[(f_num + 1) * bytes - 1] <<= 7 - (nrecords % 8); - - f_fo[f_num++] = pointer - begin; - /* So that f_fo[] points to the first bit */ - - for (i = begin; i <= end; i++) - if (f_row[i] != -1) - f_tabp[pointer + (i - begin)] = f_row[i]; - if (pointer + (end - begin) >= counter) - counter = pointer + (end - begin + 1); - while ((f_tabp[first_avail] != -1) && (first_avail <= counter)) - first_avail++; - } - - /* Write out the arrays. */ - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# field offset array\n", - (long)pc); - #endif /* DeBugLinker */ - - /* - * Compute largest value stored in fo array - */ - { - word maxfo = 0; - for (i = 0; i < hdr.Nfields; i++) { - if (f_fo[i] > maxfo) maxfo = f_fo[i]; - } - if (maxfo < 254) - hdr.FoffWidth = 1; - else if (maxfo < 65535L) - hdr.FoffWidth = 2; - else - hdr.FoffWidth = 4; - } - - for (i = 0; i < hdr.Nfields; i++) { - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\t%d\n", f_fo[i]); - #endif /* DeBugLinker */ - if (hdr.FoffWidth == 1) { - outchar(f_fo[i]); - } - else if (hdr.FoffWidth == 2) - outshort(f_fo[i]); - else - outop (f_fo[i]); - } - - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# Bit maps array\n", - (long)pc); - #endif /* DeBugLinker */ - - for (i = 0; i < hdr.Nfields; i++) { - #ifdef DeBugLinker - if (Dflag) { - int ct, index = i * bytes; - unsigned char this_bit = 0200; - - fprintf (dbgfile, "\t"); - for (ct = 0; ct < nrecords; ct++) { - if ((f_bm[index] | this_bit) == f_bm[index]) - fprintf (dbgfile, "1"); - else - fprintf (dbgfile, "0"); - - if (ct % 8 == 7) { - fprintf (dbgfile, " "); - index++; - this_bit = 0200; - } - else - this_bit >>= 1; - } - fprintf (dbgfile, "\n"); - } - #endif /* DeBugLinker */ - for (pointer = i * bytes; pointer < (i + 1) * bytes; pointer++) { - outchar (f_bm[pointer]); - } - } - - align(); - - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# record/field array\n", - (long)pc); - #endif /* DeBugLinker */ - - hdr.Ftab = pc; - for (i = 0; i < counter; i++) { - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\t%d\t%d\n", i, f_tabp[i]); - #endif /* DeBugLinker */ - if (hdr.FtabWidth == 1) - outchar(f_tabp[i]); - else if (hdr.FtabWidth == 2) - outshort(f_tabp[i]); - else - outop (f_tabp[i]); - } - - /* Free memory allocated by Jigsaw. */ - free (f_fo); - free (f_bm); - free (f_tabp); - free (f_row); - } - - #endif /* FieldTableCompression */ - /* * Output descriptors for field names. */ @@ -1151,13 +715,6 @@ void gentables() hdr.Fnames = pc; for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { s = &lsspace[fp->f_name]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", - (long)pc, (int)strlen(s), (long)fp->f_name, s); - #endif /* DeBugLinker */ - outword(strlen(s)); /* name of field: length & offset */ outword(fp->f_name); } @@ -1168,38 +725,18 @@ void gentables() hdr.Globals = pc; for (gp = lgfirst; gp != NULL; gp = gp->g_next) { if (gp->g_flag & F_Builtin) { /* function */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n", - (long)pc, (long)D_Proc, -gp->g_procid, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(-gp->g_procid); } else if (gp->g_flag & F_Proc) { /* Icon procedure */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", - (long)pc,(long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else if (gp->g_flag & F_Record) { /* record constructor */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long) pc, - (long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else { /* simple global variable */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc, - (long)D_Null, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Null); outword(0); } @@ -1210,14 +747,6 @@ void gentables() */ hdr.Gnames = pc; for (gp = lgfirst; gp != NULL; gp = gp->g_next) { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", - (long)pc, (int)strlen(&lsspace[gp->g_name]), (long)(gp->g_name), - &lsspace[gp->g_name]); - #endif /* DeBugLinker */ - outword(strlen(&lsspace[gp->g_name])); outword(gp->g_name); } @@ -1227,12 +756,6 @@ void gentables() */ hdr.Statics = pc; for (i = lstatics; i > 0; i--) { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc); - #endif /* DeBugLinker */ - outword(D_Null); outword(0); } @@ -1249,20 +772,6 @@ void gentables() outfile) < 0) quit("cannot write icode file"); - #ifdef DeBugLinker - if (Dflag) { - int k = 0; - struct ipc_fname *ptr; - for (ptr = fnmtbl; ptr < fnmfree; ptr++) { - fprintf(dbgfile, "%ld:\t%03d\tS+%03d\t\t\t# %s\n", - (long)(pc + k), ptr->ipc, ptr->fname, &lsspace[ptr->fname]); - k = k + 8; - } - putc('\n', dbgfile); - } - - #endif /* DeBugLinker */ - pc += (char *)fnmfree - (char *)fnmtbl; hdr.linenums = pc; @@ -1270,47 +779,8 @@ void gentables() outfile) < 0) quit("cannot write icode file"); - #ifdef DeBugLinker - if (Dflag) { - int k = 0; - struct ipc_line *ptr; - for (ptr = lntable; ptr < lnfree; ptr++) { - fprintf(dbgfile, "%ld:\t%03d\t%03d\n", (long)(pc + k), - ptr->ipc, ptr->line); - k = k + 8; - } - putc('\n', dbgfile); - } - - #endif /* DeBugLinker */ - pc += (char *)lnfree - (char *)lntable; - hdr.Strcons = pc; - #ifdef DeBugLinker - if (Dflag) { - int c, j, k; - j = k = 0; - for (s = lsspace; s < &lsspace[lsfree]; ) { - fprintf(dbgfile, "%ld:\t%03o", (long)(pc + k), *s++ & 0377); - k = k + 8; - for (i = 7; i > 0; i--) { - if (s >= &lsspace[lsfree]) - fprintf(dbgfile," "); - else - fprintf(dbgfile, " %03o", *s++ & 0377); - } - fprintf(dbgfile, " "); - for (i = 0; i < 8; i++) - if (j < lsfree) { - c = lsspace[j++]; - putc(isprint(c & 0377) ? c : ' ', dbgfile); - } - putc('\n', dbgfile); - } - } - - #endif /* DeBugLinker */ if (longwrite(lsspace, (long)lsfree, outfile) < 0) quit("cannot write icode file"); @@ -1324,25 +794,6 @@ void gentables() strcpy((char *)hdr.config,IVersion); hdr.trace = trace; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "\n"); - fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize); - fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace); - fprintf(dbgfile, "records: %ld\n", (long)hdr.Records); - fprintf(dbgfile, "ftab: %ld\n", (long)hdr.Ftab); - fprintf(dbgfile, "fnames: %ld\n", (long)hdr.Fnames); - fprintf(dbgfile, "globals: %ld\n", (long)hdr.Globals); - fprintf(dbgfile, "gnames: %ld\n", (long)hdr.Gnames); - fprintf(dbgfile, "statics: %ld\n", (long)hdr.Statics); - fprintf(dbgfile, "strcons: %ld\n", (long)hdr.Strcons); - fprintf(dbgfile, "filenms: %ld\n", (long)hdr.Filenms); - fprintf(dbgfile, "linenums: %ld\n", (long)hdr.linenums); - fprintf(dbgfile, "config: %s\n", hdr.config); - } - #endif /* DeBugLinker */ - fseek(outfile, hdrsize, 0); if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0) quit("cannot write icode file"); @@ -1407,40 +858,6 @@ int oint; codep += IntBits/ByteBits; pc += IntBits/ByteBits; } - -#ifdef FieldTableCompression -/* - * charout(i) outputs i as an unsigned char that is used by the runtime system - */ -static void charout(unsigned char ochar) - { - CodeCheck(1); - *codep++ = (unsigned char)ochar; - pc++; - } -/* - * shortout(i) outputs i as a short that is used by the runtime system - * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0]. - */ -static void shortout(short oint) - { - int i; - union { - short i; - char c[2]; - } u; - - CodeCheck(2); - u.i = oint; - - for (i = 0; i < 2; i++) - codep[i] = u.c[i]; - - codep += 2; - pc += 2; - } -#endif /* FieldTableCompression */ - /* * wordout(i) outputs i as a word that is used by the runtime system @@ -1478,25 +895,6 @@ int count; *codep++ = *addr++; } -#ifdef DeBugLinker - /* - * dumpblock(a,i) dump contents of i bytes at address a, used only - * in conjunction with -L. - */ - static void dumpblock(addr, count) - char *addr; - int count; - { - int i; - for (i = 0; i < count; i++) { - if ((i & 7) == 0) - fprintf(dbgfile,"\n\t"); - fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i])); - } - putc('\n',dbgfile); - } - #endif /* DeBugLinker */ - /* * flushcode - write buffered code to the output file. */ @@ -1549,16 +947,3 @@ int lab; } labels[lab] = pc; } - -#ifdef DeBugLinker - void idump(s) /* dump code region */ - char *s; - { - int *c; - - fprintf(stderr,"\ndump of code region %s:\n",s); - for (c = (int *)codeb; c < (int *)codep; c++) - fprintf(stderr,"%ld: %d\n",(long)c, (int)*c); - fflush(stderr); - } - #endif /* DeBugLinker */ diff --git a/src/icont/lglob.c b/src/icont/lglob.c index 6583b8a..281b8d5 100644 --- a/src/icont/lglob.c +++ b/src/icont/lglob.c @@ -25,7 +25,7 @@ void readglob() { register word id; register int n, op; - int k; + int i, k; int implicit; char *name; struct gentry *gp; @@ -111,7 +111,8 @@ void readglob() break; case Op_Link: /* link the named file */ - name = &lsspace[getrest()]; /* get the name and */ + i = getrest(); /* get name offset -- can move lsspace */ + name = &lsspace[i]; /* get pointer to name string */ alsolink(name); /* put it on the list of files to link */ newline(); break; diff --git a/src/icont/link.c b/src/icont/link.c index 362b257..c68ffae 100644 --- a/src/icont/link.c +++ b/src/icont/link.c @@ -19,11 +19,6 @@ static void setexe (char *fname); FILE *infile; /* input file (.u1 or .u2) */ FILE *outfile; /* interpreter code output file */ -#ifdef DeBugLinker - FILE *dbgfile; /* debug file */ - static char dbgname[MaxPath]; /* debug file name */ -#endif /* DeBugLinker */ - struct lfile *llfiles = NULL; /* List of files to link */ char inname[MaxPath]; /* input file name */ @@ -140,18 +135,6 @@ char *outname; if (ferror(outfile) != 0) quit("unable to write to icode file"); - #ifdef DeBugLinker - /* - * Open the .ux file if debugging is on. - */ - if (Dflag) { - makename(dbgname, TargetDir, llfiles->lf_name, ".ux"); - dbgfile = fopen(dbgname, "w"); - if (dbgfile == NULL) - quitf("cannot create %s", dbgname); - } - #endif /* DeBugLinker */ - /* * Loop through input files and generate code for each. */ diff --git a/src/icont/lmem.c b/src/icont/lmem.c index 8e091a5..034c4c8 100644 --- a/src/icont/lmem.c +++ b/src/icont/lmem.c @@ -96,22 +96,6 @@ void linit() putglobal(instid("main"), F_Global, 0, 0); } -#ifdef DeBugLinker - /* - * dumplfiles - print the list of files to link. Used for debugging only. - */ - void dumplfiles() - { - struct lfile *p,*lfls; - - fprintf(stderr,"lfiles:\n"); - lfls = llfiles; - while (p = getlfile(&lfls)) - fprintf(stderr,"'%s'\n",p->lf_name); - fflush(stderr); - } -#endif /* DeBugLinker */ - /* * alsolink - create an lfile structure for the named file and add it to the * end of the list of files (llfiles) to generate link instructions for. diff --git a/src/icont/tcode.c b/src/icont/tcode.c index 9a9787c..44839b6 100644 --- a/src/icont/tcode.c +++ b/src/icont/tcode.c @@ -118,9 +118,6 @@ register nodeptr t; loopsp->markcount++; traverse(Tree0(t)); /* evaluate first alternative */ loopsp->markcount--; - #ifdef EventMon - setloc(t); - #endif /* EventMon */ emit("esusp"); /* and suspend with its result */ emitl("goto", lab+1); emitlab(lab); @@ -1020,24 +1017,14 @@ nodeptr n; static void emitline(n) nodeptr n; { - #ifdef SrcColumnInfo - /* - * if either line or column has changed, emit location information - */ - if (((Col(n) << 16) + Line(n)) != lastlin) { - lastlin = (Col(n) << 16) + Line(n); - emitn("line",Line(n)); - emitn("colm",Col(n)); - } - #else /* SrcColumnInfo */ - /* - * if line has changed, emit line information - */ - if (Line(n) != lastlin) { - lastlin = Line(n); - emitn("line", lastlin); - } - #endif /* SrcColumnInfo */ + /* + * if either line or column has changed, emit location information + */ + if (((Col(n) << 16) + Line(n)) != lastlin) { + lastlin = (Col(n) << 16) + Line(n); + emitn("line",Line(n)); + emitn("colm",Col(n)); + } } /* diff --git a/src/icont/tglobals.h b/src/icont/tglobals.h index 5568293..5a45ea6 100644 --- a/src/icont/tglobals.h +++ b/src/icont/tglobals.h @@ -48,10 +48,6 @@ Global int pponly Init(0); /* -E: preprocess only */ Global int strinv Init(0); /* -f s: allow full string invocation */ Global int verbose Init(1); /* -v n: verbosity of commentary */ -#ifdef DeBugLinker - Global int Dflag Init(0); /* -L: linker debug (write .ux file) */ -#endif /* DeBugLinker */ - /* * Files and related globals. */ diff --git a/src/icont/tproto.h b/src/icont/tproto.h index aaea6c4..e88d426 100644 --- a/src/icont/tproto.h +++ b/src/icont/tproto.h @@ -94,13 +94,3 @@ void writecheck (int rc); void yyerror (int tok,struct node *lval,int state); int yylex (void); int yyparse (void); - -#ifdef DeBugTrans - void cdump (void); - void gdump (void); - void ldump (void); -#endif /* DeBugTrans */ - -#ifdef DeBugLinker - void idump (char *c); -#endif /* DeBugLinker */ diff --git a/src/icont/tsym.c b/src/icont/tsym.c index 1d0f16c..6f9b2a3 100644 --- a/src/icont/tsym.c +++ b/src/icont/tsym.c @@ -25,13 +25,6 @@ static struct tgentry *glookup (char *id); static struct tlentry *llookup (char *id); static void putglob (char *id,int id_type, int n_args); - -#ifdef DeBugTrans - void cdump (void); - void gdump (void); - void ldump (void); -#endif /* DeBugTrans */ - /* * Keyword table. @@ -257,79 +250,6 @@ register char *id; return 0; } -#ifdef DeBugTrans -/* - * ldump displays local symbol table to stdout. - */ - -void ldump() - { - register int i; - register struct tlentry *lptr; - int n; - - if (llast == NULL) - n = 0; - else - n = llast->l_index + 1; - fprintf(stderr,"Dump of local symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags\n"); - for (i = 0; i < lhsize; i++) - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->l_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o\n", lptr->l_index, - lptr->l_blink, lptr->l_name, lptr->l_name, lptr->l_flag); - fflush(stderr); - - } - -/* - * gdump displays global symbol table to stdout. - */ - -void gdump() - { - register int i; - register struct tgentry *gptr; - int n; - - if (glast == NULL) - n = 0; - else - n = glast->g_index + 1; - fprintf(stderr,"Dump of global symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags nargs\n"); - for (i = 0; i < ghsize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->g_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o %8d\n", gptr->g_index, - gptr->g_blink, gptr->g_name, gptr->g_name, - gptr->g_flag, gptr->g_nargs); - fflush(stderr); - } - -/* - * cdump displays constant symbol table to stdout. - */ - -void cdump() - { - register int i; - register struct tcentry *cptr; - int n; - - if (clast == NULL) - n = 0; - else - n = clast->c_index + 1; - fprintf(stderr,"Dump of constant symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags\n"); - for (i = 0; i < lchsize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->c_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o\n", cptr->c_index, - cptr->c_blink, cptr->c_name, cptr->c_name, cptr->c_flag); - fflush(stderr); - } -#endif /* DeBugTrans */ - /* * alcloc allocates a local symbol table entry, fills in fields with * specified values and returns the new entry. diff --git a/src/icont/tunix.c b/src/icont/tunix.c index 9478403..e0388c1 100644 --- a/src/icont/tunix.c +++ b/src/icont/tunix.c @@ -103,20 +103,14 @@ int main(int argc, char *argv[]) { iconxloc = ""; break; case 'V': /* -V: print version information */ - fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + fprintf(stderr, "%s (%s %d/%d, %s)\n", + Version, Config, IntBits, WordBits, __DATE__); if (optind == argc) exit(0); break; case 'X': /* -X srcfile: execute single srcfile */ txrun(copyfile, optarg, &argv[optind]); break; /*NOTREACHED*/ - - #ifdef DeBugLinker - case 'L': /* -L: enable linker debugging */ - Dflag = 1; - break; - #endif /* DeBugLinker */ - default: case 'x': /* -x illegal until after file list */ usage(); @@ -249,8 +243,10 @@ static void execute(char *ofile, char *efile, char *args[]) { */ if (efile != NULL) { close(fileno(stderr)); - if (strcmp(efile, "-") == 0) - dup(fileno(stdout)); + if (strcmp(efile, "-") == 0) { + if (dup(fileno(stdout)) < 0) + quit("could not merge standard output with standard error\n"); + } else if (freopen(efile, "w", stderr) == NULL) quitf("could not redirect stderr to %s\n", efile); } @@ -293,11 +289,7 @@ static char *libpath(char *prog, char *envname) { s = getenv(envname); if (s != NULL) - #if CYGWIN - cygwin_win32_to_posix_path_list(s, buf); - #else /* CYGWIN */ - strcpy(buf, s); - #endif /* CYGWIN */ + strcpy(buf, s); else strcpy(buf, "."); strcat(buf, ":"); @@ -323,21 +315,15 @@ static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) { omask = umask(0077); /* remember umask; keep /tmp files private */ /* - * Invent a file named /tmp/innnnnxx.icn. + * Create a temporary file named /tmp/innnnnxx.icn. */ srand(time(NULL)); c1 = abet[rand() % (sizeof(abet) - 1)]; c2 = abet[rand() % (sizeof(abet) - 1)]; sprintf(srcfile, "/tmp/i%d%c%c.icn", getpid(), c1, c2); - - /* - * Copy the source code to the temporary file. - */ f = fopen(srcfile, "w"); if (f == NULL) quitf("cannot open for writing: %s", srcfile); - progname = func(f, source); - fclose(f); /* * Derive other names and arrange for cleanup on exit. @@ -351,8 +337,10 @@ static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) { atexit(cleanup); /* - * Translate to produce .u1 and .u2 files. + * Copy the source file, then translate to produce .u1 and .u2 files. */ + progname = func(f, source); + fclose(f); flist[0] = srcfile; flist[1] = NULL; if (trans(flist, SourceDir) > 0) diff --git a/src/preproc/Makefile b/src/preproc/Makefile deleted file mode 100644 index c3d17ed..0000000 --- a/src/preproc/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -include ../../Makedefs - -POBJS = pout.o pchars.o perr.o pmem.o bldtok.o macro.o preproc.o evaluate.o\ - files.o gettok.o pinit.o - -COBJS= ../common/getopt.o ../common/time.o ../common/strtbl.o ../common/alloc.o - -ICOBJS= getopt.o time.o strtbl.o alloc.o - -OBJS= $(POBJS) $(COBJS) - -DOT_H = preproc.h pproto.h ptoken.h ../h/define.h ../h/config.h\ - ../h/typedefs.h ../h/mproto.h - -common: - cd ../common; $(MAKE) $(ICOBJS) - $(MAKE) pp - -pp: pmain.o $(OBJS) - $(CC) -o pp pmain.o $(OBJS) - -pmain.o: $(DOT_H) -p_out.o: $(DOT_H) -pchars.o: $(DOT_H) -p_err.o: $(DOT_H) -pmem.o: $(DOT_H) -pstring.o: $(DOT_H) -bldtok.o: $(DOT_H) -macro.o: $(DOT_H) -preproc.o: $(DOT_H) -evaluate.o: $(DOT_H) -files.o: $(DOT_H) -gettok.o: $(DOT_H) -p_init.o: $(DOT_H) diff --git a/src/preproc/README b/src/preproc/README deleted file mode 100644 index 35d6a23..0000000 --- a/src/preproc/README +++ /dev/null @@ -1,7 +0,0 @@ -This directory contains files for building pp, a ANSI-C preprocessor for -C (with some extensions). pp itself is not needed to build the Icon -compiler system -- the files here are automatically incorporated in -rtt. - -However, if you want to build a stand-alone version of pp for -some other use, the Makefile here will do it. diff --git a/src/preproc/files.c b/src/preproc/files.c index 07abf60..016d04d 100644 --- a/src/preproc/files.c +++ b/src/preproc/files.c @@ -5,12 +5,6 @@ #include "../preproc/preproc.h" #include "../preproc/pproto.h" -#if CYGWIN - #include <limits.h> - #include <string.h> - #include <sys/cygwin.h> -#endif /* CYGWIN */ - #define IsRelPath(fname) (fname[0] != '/') static void file_src (char *fname, FILE *f); @@ -27,12 +21,6 @@ FILE *f; { union src_ref ref; - #if CYGWIN - char posix_path[ _POSIX_PATH_MAX + 1 ]; - cygwin_conv_to_posix_path( fname, posix_path ); - fname = strdup( posix_path ); - #endif /* CYGWIN */ - ref.cs = new_cs(fname, f, CBufSize); push_src(CharSrc, &ref); next_char = NULL; @@ -154,31 +142,8 @@ char **opt_args; * that establishes these search locations. */ - #if CYGWIN - char *incl_var; - static char *sysdir = "/usr/include"; - static char *windir = "/usr/include/w32api"; - n_paths = 2; - - incl_var = getenv("C_INCLUDE_PATH"); - if (incl_var != NULL) { - /* - * Add one entry for evry non-empty, colon-separated string in incl_var. - */ - char *dir_start, *dir_end; - - dir_start = incl_var; - while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { - if (dir_end > dir_start) ++n_paths; - dir_start = dir_end + 1; - } - if ( *dir_start != '\0' ) - ++n_paths; /* One path after the final ':' */ - } - #else /* CYGWIN */ - static char *sysdir = "/usr/include/"; - n_paths = 1; - #endif /* CYGWIN */ + static char *sysdir = "/usr/include/"; + n_paths = 1; /* * Count the number of -I options to the preprocessor. @@ -201,22 +166,6 @@ char **opt_args; s = opt_args[i]; s1 = alloc(strlen(s) + 1); strcpy(s1, s); - - #if CYGWIN - /* - * Run s1 through cygwin_conv_to_posix_path; if the posix path - * differs from s1, reset s1 to a copy of the posix path. - */ - { - char posix_path[ _POSIX_PATH_MAX ]; - cygwin_conv_to_posix_path( s1, posix_path ); - if (strcmp( s1, posix_path ) != 0) { - free( s1 ); - s1 = salloc( posix_path ); - } - } - #endif /* CYGWIN */ - incl_search[j++] = s1; } @@ -224,34 +173,7 @@ char **opt_args; * Establish the standard locations to search after the -I options * on the preprocessor. */ - #if CYGWIN - if (incl_var != NULL) { - /* - * The C_INCLUDE_PATH components are carved out of a copy of incl_var. - * The colons after non-empty directory names are replaced by null - * chars, and the pointers to the start of these names are stored - * in inc_search. - */ - char *dir_start, *dir_end; - - dir_start = salloc( incl_var ); - while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { - if (dir_end > dir_start) { - incl_search[j++] = dir_start; - *dir_end = '\0'; - } - dir_start = dir_end + 1; - } - if ( *dir_start != '\0' ) - incl_search[j++] = dir_start; - } - - /* Finally, add the system dir(s) */ - incl_search[j++] = sysdir; - incl_search[j++] = windir; - #else - incl_search[n_paths - 1] = sysdir; - #endif /* CYGWIN */ + incl_search[n_paths - 1] = sysdir; incl_search[n_paths] = NULL; } diff --git a/src/preproc/pinit.c b/src/preproc/pinit.c index 9f64cb0..219735e 100644 --- a/src/preproc/pinit.c +++ b/src/preproc/pinit.c @@ -47,22 +47,6 @@ char **opt_args; int i; /* - * Establish predefined macros. - */ - #if CYGWIN - do_directive("#define __CYGWIN32__\n"); - do_directive("#define __CYGWIN__\n"); - do_directive("#define __unix__\n"); - do_directive("#define __unix\n"); - do_directive("#define _WIN32\n"); - do_directive("#define __WIN32\n"); - do_directive("#define __WIN32__\n"); - #else /* CYGWIN */ - do_directive("#define unix 1\n"); - do_directive(PPInit); /* defines that vary between Unix systems */ - #endif /* CYGWIN*/ - - /* * look for options that affect macro definitions (-U, -D, etc). */ for (i = 0; opt_lst[i] != '\0'; ++i) diff --git a/src/preproc/pmain.c b/src/preproc/pmain.c deleted file mode 100644 index 9cc721a..0000000 --- a/src/preproc/pmain.c +++ /dev/null @@ -1,109 +0,0 @@ -#include "../preproc/preproc.h" -#include "../preproc/pproto.h" - -char *progname = "pp"; - -/* - * Establish command-line options. - */ -static char *ostr = "+CPD:I:U:o:"; -static char *options = - "[-C] [-P] [-Dname[=[text]]] [-Uname] [-Ipath] [-ofile] [files]"; - -extern line_cntrl; - -/* - * getopt() variables - */ -extern int optind; /* index into parent argv vector */ -extern int optopt; /* character checked for validity */ -extern char *optarg; /* argument associated with option */ - -int main(argc, argv) -int argc; -char **argv; - { - int c; - char *opt_lst; - char **opt_args; - int nopts; - FILE *out_file; - - /* - * By default, keep the image of white space, but replace each comment - * by a space. By default, output #line directives. - */ - whsp_image = NoComment; - line_cntrl = 1; - - /* - * The number of options that must be passed on to other phases - * of the preprocessor are at most as large as the entire option - * list. - */ - opt_lst = alloc(argc); - opt_args = alloc(argc * sizeof (char *)); - nopts = 0; - out_file = stdout; - - /* - * Process options. - */ - while ((c = getopt(argc, argv, ostr)) != EOF) - switch (c) { - - case 'C': /* -C - retan comments */ - whsp_image = FullImage; - break; - - case 'P': /* -P - do not output #line directives */ - line_cntrl = 0; - break; - - case 'D': /* -D<id><definition> - predefine an identifier */ - case 'I': /* -I<path> - location to search for standard header files */ - case 'U': /* -U<id> - undefine predefined identifier */ - opt_lst[nopts] = c; - opt_args[nopts] = optarg; - ++nopts; - break; - - case 'o': /* -o<file> - write output to this file */ - out_file = fopen(optarg, "w"); - if (out_file == NULL) - err2("cannot open output file ", optarg); - break; - - default: - show_usage(); - } - - opt_lst[nopts] = '\0'; - - /* - * Scan file name arguments. If there are none, process standard input, - * indicated by the name "-". - */ - if (optind == argc) { - init_preproc("-", opt_lst, opt_args); - output(out_file); - } - else { - while (optind < argc) { - init_preproc(argv[optind], opt_lst, opt_args); - output(out_file); - optind++; - } - } - - return EXIT_SUCCESS; - } - -/* - * Print an error message if called incorrectly. - */ -void show_usage() - { - fprintf(stderr, "usage: %s %s\n", progname, options); - exit(EXIT_FAILURE); - } diff --git a/src/rtt/Makefile b/src/rtt/Makefile index db6445e..7122ca1 100644 --- a/src/rtt/Makefile +++ b/src/rtt/Makefile @@ -23,8 +23,6 @@ OBJ = $(ROBJS) $(POBJS) $(COBJS) rtt: $(OBJ) $(CC) $(LDFLAGS) -o rtt $(OBJ) - cp rtt ../../bin - strip ../../bin/rtt$(EXE) library: $(OBJ) rm -rf rtt.a diff --git a/src/rtt/rttdb.c b/src/rtt/rttdb.c index 22368fe..e38dd5f 100644 --- a/src/rtt/rttdb.c +++ b/src/rtt/rttdb.c @@ -542,7 +542,7 @@ struct il_code *il; fprintf(db, "%d ", num_cases); indx = 1; for (i = 0; i < num_cases; ++i) { - fprintf(db, "\n%d ", il->u[indx++].n); /* selection number */ + fprintf(db, "\n%ld ", (long)il->u[indx++].n);/* selection number */ put_inlin(db, il->u[indx++].fld); /* action */ } fprintf(db, "\n"); @@ -567,14 +567,14 @@ struct il_code *il; * runerr with no value argument. */ fprintf(db, "runerr1 "); - fprintf(db, "%d ", il->u[0].n); /* error number */ + fprintf(db, "%ld ", (long)il->u[0].n); /* error number */ break; case IL_Err2: /* * runerr with a value argument. */ fprintf(db, "runerr2 "); - fprintf(db, "%d ", il->u[0].n); /* error number */ + fprintf(db, "%ld ", (long)il->u[0].n); /* error number */ put_inlin(db, il->u[1].fld); /* variable */ break; case IL_Lst: @@ -649,15 +649,15 @@ struct il_code *il; /* * A variable. */ - fprintf(db, "%d ", il->u[0].n); /* symbol table index */ + fprintf(db, "%ld ", (long)il->u[0].n); /* symbol table index */ break; case IL_Subscr: /* * A subscripted variable. */ fprintf(db, "[ "); - fprintf(db, "%d ", il->u[0].n); /* symbol table index */ - fprintf(db, "%d ", il->u[1].n); /* subscripting index */ + fprintf(db, "%ld ", (long)il->u[0].n); /* symbol table index */ + fprintf(db, "%ld ", (long)il->u[1].n); /* subscripting index */ break; case IL_Block: /* @@ -671,7 +671,7 @@ struct il_code *il; /* * Output a symbol table of tended variables. */ - fprintf(db, "%d ", il->u[1].n); /* number of local tended */ + fprintf(db, "%ld ", (long)il->u[1].n); /* number of local tended */ for (i = 2; i - 2 < il->u[1].n; ++i) switch (il->u[i].n) { case TndDesc: @@ -733,8 +733,8 @@ struct il_code *il; else fprintf(db, "f "); - fprintf(db, "%d ", il->u[5].n); /* num string bufs */ - fprintf(db, "%d ", il->u[6].n); /* num cset bufs */ + fprintf(db, "%ld ", (long)il->u[5].n); /* num string bufs */ + fprintf(db, "%ld ", (long)il->u[6].n); /* num cset bufs */ i = il->u[7].n; fprintf(db, "%d ", i); /* num args */ indx = 8; @@ -961,15 +961,15 @@ struct il_c *ilc; fprintf(db, "$efail "); /* errorfail statement */ break; case ILC_Goto: - fprintf(db, "$goto %d ", ilc->n); /* goto label */ + fprintf(db, "$goto %ld ", (long)ilc->n); /* goto label */ break; case ILC_CGto: fprintf(db, "$cgoto "); /* conditional goto */ put_ilc(db, ilc->code[0]); /* condition (with $c $e) */ - fprintf(db, "%d ", ilc->n); /* label */ + fprintf(db, "%ld ", (long)ilc->n); /* label */ break; case ILC_Lbl: - fprintf(db, "$lbl %d ", ilc->n); /* label */ + fprintf(db, "$lbl %ld ", (long)ilc->n); /* label */ break; case ILC_LBrc: fprintf(db, "${ "); /* start of C block with dcls */ @@ -1000,7 +1000,7 @@ struct il_c *ilc; if (ilc->n == RsltIndx) fprintf(db, "r "); /* this is "result" */ else - fprintf(db, "%d ", ilc->n); /* offset into a symbol table */ + fprintf(db, "%ld ", (long)ilc->n); /* offset into a symbol table */ } /* diff --git a/src/rtt/rttilc.c b/src/rtt/rttilc.c index 70839ef..a660829 100644 --- a/src/rtt/rttilc.c +++ b/src/rtt/rttilc.c @@ -847,25 +847,11 @@ int const_cast; } else if (typcd == int_typ) { ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); - ilc_str("((("); ilc_walk(n1, 0, 0); ilc_str(").dword == D_Integer) || (("); ilc_walk(n1, 0, 0); ilc_str(").dword == D_Lrgint))"); - - ForceNl(); - prt_str("#else /* LargeInts */", 0); - ForceNl(); - - ilc_str("(("); - ilc_walk(n1, 0, 0); - ilc_str(").dword == D_Integer)"); - - ForceNl(); - prt_str("#endif /* LargeInts */", 0); ForceNl(); } else { diff --git a/src/rtt/rttmain.c b/src/rtt/rttmain.c index 2099c2f..bfdf643 100644 --- a/src/rtt/rttmain.c +++ b/src/rtt/rttmain.c @@ -24,8 +24,8 @@ static char *options = * interpreted as relative to where rtt.exe is or where rtt.exe is * invoked. */ - char *grttin_path = "../src/h/grttin.h"; - char *rt_path = "../src/h/rt.h"; + char *grttin_path = "../h/grttin.h"; + char *rt_path = "../h/rt.h"; /* * Note: rtt presently does not process system include files. If this @@ -39,7 +39,7 @@ char *compiler_def; FILE *out_file; char *inclname; int def_fnd; -char *largeints = NULL; +char *largeints = "LargeInts"; int iconx_flg = 0; int enable_out = 0; @@ -245,12 +245,9 @@ char *src_file; char *cname; char buf[MaxPath]; /* file name construction buffer */ char *buf_ptr; - char *s; struct fileparts *fp; struct tdefnm *td; struct token *t; - static char *test_largeints = "#ifdef LargeInts\nyes\n#endif\n"; - static int first_time = 1; cur_src = src_file; @@ -266,24 +263,6 @@ char *src_file; sym_add(TypeDefName, td->name, OtherDcl, 1); init_lex(); yyparse(); - if (first_time) { - first_time = 0; - /* - * Now that the standard include files have been processed, see if - * Largeints is defined and make sure it matches what's in the data base. - */ - s = "NoLargeInts"; - str_src("<rtt initialization>", test_largeints, - (int)strlen(test_largeints)); - while ((t = preproc()) != NULL) - if (strcmp(t->image, "yes")) - s = "LargeInts"; - if (largeints == NULL) - largeints = s; - else if (strcmp(largeints, s) != 0) - err2("header file definition of LargeInts/NoLargeInts does not match ", - dbname); - } enable_out = 1; /* diff --git a/src/rtt/rttout.c b/src/rtt/rttout.c index 14c71b7..c2fa8b0 100644 --- a/src/rtt/rttout.c +++ b/src/rtt/rttout.c @@ -566,22 +566,12 @@ int indent; * an ordinary integer or a large integer. */ ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); prt_str("(((", indent); c_walk(desc, indent, 0); prt_str(").dword == D_Integer) || ((", indent); c_walk(desc, indent, 0); prt_str(").dword == D_Lrgint))", indent); ForceNl(); - prt_str("#else\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); - prt_str("((", indent); - c_walk(desc, indent, 0); - prt_str(").dword == D_Integer)", indent); - ForceNl(); - prt_str("#endif\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); } else { /* @@ -1393,29 +1383,9 @@ int brace; * is returned. */ if (iconx_flg) { - #ifdef EventMon - switch (op_type) { - case TokFunction: - prt_str( - "if ((signal = interp(G_Fsusp, r_args)) != A_Resume) {", - indent); - break; - case Operator: - case Keyword: - prt_str( - "if ((signal = interp(G_Osusp, r_args)) != A_Resume) {", - indent); - break; - default: - prt_str( - "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", - indent); - } - #else /* EventMon */ - prt_str( - "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", - indent); - #endif /* EventMon */ + prt_str( + "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", + indent); } else { prt_str("if (r_s_cont == (continuation)NULL) {", indent); @@ -2153,12 +2123,8 @@ int indent; if (typcd == int_typ) { ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); prt_str("case T_Lrgint: ", indent + IndentInc); ForceNl(); - prt_str("#endif /* LargeInts */", 0); - ForceNl(); } prt_str("case T_", indent + IndentInc); @@ -2681,8 +2647,6 @@ int brace; /* * Try converting both arguments to an integer. */ - prt_str("#ifdef LargeInts", 0); - ForceNl(); ld_prmloc(strt_prms); tok_line(t, indent); prt_str("else if (", indent); @@ -2696,8 +2660,6 @@ int brace; mrg_prmloc(end_prms); } ForceNl(); - prt_str("#endif\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); /* * Try converting both arguments to a C_double diff --git a/src/runtime/Makefile b/src/runtime/Makefile index ffa63e8..c47c14e 100644 --- a/src/runtime/Makefile +++ b/src/runtime/Makefile @@ -3,512 +3,55 @@ include ../../Makedefs -HDRS = ../h/define.h ../h/config.h ../h/typedefs.h ../h/monitor.h\ +HDRS = ../h/define.h ../h/arch.h ../h/config.h ../h/typedefs.h \ ../h/cstructs.h ../h/cpuconf.h ../h/grttin.h\ ../h/rmacros.h ../h/rexterns.h ../h/rstructs.h \ ../h/rproto.h ../h/mproto.h ../h/sys.h -GRAPHICSHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h +GHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h COBJS = ../common/long.o ../common/time.o \ ../common/rswitch.o ../common/xwindow.o \ ../common/alloc.o ../common/filepart.o ../common/munix.o +XOBJS = cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o\ + fmisc.o fscan.o fstr.o fstranl.o fstruct.o fsys.o\ + fwindow.o imain.o imisc.o init.o interp.o invoke.o\ + keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o\ + omisc.o oref.o oset.o ovalue.o ralc.o rcoexpr.o rcomp.o\ + rdebug.o rexternal.o rlrgint.o rmemmgt.o rmisc.o rstruct.o \ + rsys.o rwinrsc.o rwinsys.o rwindow.o rcolor.o rimage.o -default: iconx -all: iconx comp_all +RTT = ../rtt/rtt +SUFFIXES = .r .c .o +.r.o: ; $(RTT) -x $*.r && $(CC) -o $*.o -c $(CFLAGS) x$*.c && rm x$*.c +.r.c: ; $(RTT) -x $*.r -$(COBJS): - cd ../common; $(MAKE) - - -#################################################################### -# -# Make entries for iconx -# - -XOBJS = xcnv.o xdata.o xdef.o xerrmsg.o xextcall.o xfconv.o xfload.o xfmath.o\ - xfmisc.o xfmonitr.o xfscan.o xfstr.o xfstranl.o xfstruct.o xfsys.o\ - xfwindow.o ximain.o ximisc.o xinit.o xinterp.o xinvoke.o\ - xkeyword.o xlmisc.o xoarith.o xoasgn.o xocat.o xocomp.o\ - xomisc.o xoref.o xoset.o xovalue.o xralc.o xrcoexpr.o xrcomp.o\ - xrdebug.o xrlrgint.o xrmemmgt.o xrmisc.o xrstruct.o xrsys.o\ - xrwinrsc.o xrwinsys.o xrwindow.o xrcolor.o xrimage.o - -OBJS = $(XOBJS) $(COBJS) -iconx: $(OBJS) +iconx: $(COBJS) $(XOBJS) cd ../common; $(MAKE) - $(CC) $(RLINK) -o iconx $(OBJS) $(XL) $(RLIBS) $(TL) + $(CC) $(RLINK) -o iconx $(XOBJS) $(COBJS) $(XL) $(RLIBS) $(TLIBS) cp iconx ../../bin strip $(SFLAGS) ../../bin/iconx$(EXE) -xcnv.o: cnv.r $(HDRS) - ../../bin/rtt -x cnv.r - $(CC) -c $(CFLAGS) xcnv.c - rm xcnv.c - -xdata.o: data.r $(HDRS) ../h/kdefs.h ../h/fdefs.h ../h/odefs.h - ../../bin/rtt -x data.r - $(CC) -c $(CFLAGS) xdata.c - rm xdata.c - -xdef.o: def.r $(HDRS) - ../../bin/rtt -x def.r - $(CC) -c $(CFLAGS) xdef.c - rm xdef.c - -xerrmsg.o: errmsg.r $(HDRS) - ../../bin/rtt -x errmsg.r - $(CC) -c $(CFLAGS) xerrmsg.c - rm xerrmsg.c - -xextcall.o: extcall.r $(HDRS) - ../../bin/rtt -x extcall.r - $(CC) -c $(CFLAGS) xextcall.c - rm xextcall.c - -xfconv.o: fconv.r $(HDRS) - ../../bin/rtt -x fconv.r - $(CC) -c $(CFLAGS) xfconv.c - rm xfconv.c - -xfload.o: fload.r $(HDRS) - ../../bin/rtt -x fload.r - $(CC) -c $(CFLAGS) xfload.c - rm xfload.c - -xfmath.o: fmath.r $(HDRS) - ../../bin/rtt -x fmath.r - $(CC) -c $(CFLAGS) xfmath.c - rm xfmath.c - -xfmisc.o: fmisc.r $(HDRS) - ../../bin/rtt -x fmisc.r - $(CC) -c $(CFLAGS) xfmisc.c - rm xfmisc.c - -xfmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt -x fmonitr.r - $(CC) -c $(CFLAGS) xfmonitr.c - rm xfmonitr.c - -xfscan.o: fscan.r $(HDRS) - ../../bin/rtt -x fscan.r - $(CC) -c $(CFLAGS) xfscan.c - rm xfscan.c - -xfstr.o: fstr.r $(HDRS) - ../../bin/rtt -x fstr.r - $(CC) -c $(CFLAGS) xfstr.c - rm xfstr.c - -xfstranl.o: fstranl.r $(HDRS) - ../../bin/rtt -x fstranl.r - $(CC) -c $(CFLAGS) xfstranl.c - rm xfstranl.c - -xfstruct.o: fstruct.r $(HDRS) - ../../bin/rtt -x fstruct.r - $(CC) -c $(CFLAGS) xfstruct.c - rm xfstruct.c - -xfsys.o: fsys.r $(HDRS) - ../../bin/rtt -x fsys.r - $(CC) -c $(CFLAGS) xfsys.c - rm xfsys.c - -xfwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x fwindow.r - $(CC) -c $(CFLAGS) xfwindow.c - rm xfwindow.c - -ximain.o: imain.r $(HDRS) ../h/version.h - ../../bin/rtt -x imain.r - $(CC) -c $(CFLAGS) ximain.c - rm ximain.c - -ximisc.o: imisc.r $(HDRS) - ../../bin/rtt -x imisc.r - $(CC) -c $(CFLAGS) ximisc.c - rm ximisc.c - -xinit.o: init.r $(HDRS) ../h/odefs.h ../h/version.h - ../../bin/rtt -x init.r - $(CC) -c $(CFLAGS) xinit.c - rm xinit.c - -xinterp.o: interp.r $(HDRS) - ../../bin/rtt -x interp.r - $(CC) -c $(CFLAGS) xinterp.c - rm xinterp.c - -xinvoke.o: invoke.r $(HDRS) - ../../bin/rtt -x invoke.r - $(CC) -c $(CFLAGS) xinvoke.c - rm xinvoke.c - -xkeyword.o: keyword.r $(HDRS) ../h/features.h ../h/version.h - ../../bin/rtt -x keyword.r - $(CC) -c $(CFLAGS) xkeyword.c - rm xkeyword.c - -xlmisc.o: lmisc.r $(HDRS) - ../../bin/rtt -x lmisc.r - $(CC) -c $(CFLAGS) xlmisc.c - rm xlmisc.c - -xoarith.o: oarith.r $(HDRS) - ../../bin/rtt -x oarith.r - $(CC) -c $(CFLAGS) xoarith.c - rm xoarith.c - -xoasgn.o: oasgn.r $(HDRS) - ../../bin/rtt -x oasgn.r - $(CC) -c $(CFLAGS) xoasgn.c - rm xoasgn.c - -xocat.o: ocat.r $(HDRS) - ../../bin/rtt -x ocat.r - $(CC) -c $(CFLAGS) xocat.c - rm xocat.c - -xocomp.o: ocomp.r $(HDRS) - ../../bin/rtt -x ocomp.r - $(CC) -c $(CFLAGS) xocomp.c - rm xocomp.c - -xomisc.o: omisc.r $(HDRS) - ../../bin/rtt -x omisc.r - $(CC) -c $(CFLAGS) xomisc.c - rm xomisc.c - -xoref.o: oref.r $(HDRS) - ../../bin/rtt -x oref.r - $(CC) -c $(CFLAGS) xoref.c - rm xoref.c - -xoset.o: oset.r $(HDRS) - ../../bin/rtt -x oset.r - $(CC) -c $(CFLAGS) xoset.c - rm xoset.c - -xovalue.o: ovalue.r $(HDRS) - ../../bin/rtt -x ovalue.r - $(CC) -c $(CFLAGS) xovalue.c - rm xovalue.c - -xralc.o: ralc.r $(HDRS) - ../../bin/rtt -x ralc.r - $(CC) -c $(CFLAGS) xralc.c - rm xralc.c - -xrcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt -x rcoexpr.r - $(CC) -c $(CFLAGS) xrcoexpr.c - rm xrcoexpr.c - -xrcomp.o: rcomp.r $(HDRS) - ../../bin/rtt -x rcomp.r - $(CC) -c $(CFLAGS) xrcomp.c - rm xrcomp.c - -xrdebug.o: rdebug.r $(HDRS) - ../../bin/rtt -x rdebug.r - $(CC) -c $(CFLAGS) xrdebug.c - rm xrdebug.c - -xrlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt -x rlrgint.r - $(CC) -c $(CFLAGS) xrlrgint.c - rm xrlrgint.c - -xrmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt -x rmemmgt.r - $(CC) -c $(CFLAGS) xrmemmgt.c - rm xrmemmgt.c - -xrmisc.o: rmisc.r $(HDRS) - ../../bin/rtt -x rmisc.r - $(CC) -c $(CFLAGS) xrmisc.c - rm xrmisc.c - -xrstruct.o: rstruct.r $(HDRS) - ../../bin/rtt -x rstruct.r - $(CC) -c $(CFLAGS) xrstruct.c - rm xrstruct.c - -xrsys.o: rsys.r $(HDRS) - ../../bin/rtt -x rsys.r - $(CC) -c $(CFLAGS) xrsys.c - rm xrsys.c - -xrwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) rxrsc.ri - ../../bin/rtt -x rwinrsc.r - $(CC) -c $(CFLAGS) xrwinrsc.c - rm xrwinrsc.c - -xrwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) rxwin.ri - ../../bin/rtt -x rwinsys.r - $(CC) -c $(CFLAGS) xrwinsys.c - rm xrwinsys.c - -xrwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rwindow.r - $(CC) -c $(CFLAGS) xrwindow.c - rm xrwindow.c - -xrcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rcolor.r - $(CC) -c $(CFLAGS) xrcolor.c - rm xrcolor.c - -xrimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rimage.r - $(CC) -c $(CFLAGS) xrimage.c - rm xrimage.c - - -#################################################################### -# -# Make entries for the compiler library -# - -comp_all: $(COBJS) db_lib - -db_lib: rt.db rt.a - -# -# if rt.db is missing or any header files have been updated, recreate -# rt.db from scratch along with the .o files. -# -rt.db: $(HDRS) - rm -f rt.db rt.a - ../../bin/rtt cnv.r data.r def.r errmsg.r fconv.r fload.r fmath.r\ - fmisc.r fmonitr.r fscan.r fstr.r fstranl.r fstruct.r\ - fsys.r fwindow.r init.r invoke.r keyword.r\ - lmisc.r oarith.r oasgn.r ocat.r ocomp.r omisc.r\ - oref.r oset.r ovalue.r ralc.r rcoexpr.r rcomp.r\ - rdebug.r rlrgint.r rmemmgt.r rmisc.r rstruct.r\ - rsys.r rwinrsc.r rwinsys.r rwindow.r rcolor.r rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rt.a: ../common/rswitch.o ../common/long.o ../common/time.o\ - cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o fmisc.o fmonitr.o \ - fscan.o fstr.o fstranl.o fstruct.o fsys.o fwindow.o init.o invoke.o\ - keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o omisc.o oref.o oset.o\ - ovalue.o ralc.o rcoexpr.o rcomp.o rdebug.o rlrgint.o rmemmgt.o\ - rmisc.o rstruct.o rsys.o rwinrsc.o rwinsys.o\ - rwindow.o rcolor.o rimage.o ../common/xwindow.o ../common/alloc.o - rm -f rt.a - ar qc rt.a `sed 's/$$/.o/' rttcur.lst` ../common/rswitch.o\ - ../common/long.o ../common/time.o\ - ../common/xwindow.o ../common/alloc.o - ranlib rt.a 2>/dev/null || : - cp -p rt.a rt.db ../common/dlrgint.o ../../bin - -cnv.o: cnv.r $(HDRS) - ../../bin/rtt cnv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -data.o: data.r $(HDRS) - ../../bin/rtt data.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -def.o: def.r $(HDRS) - ../../bin/rtt def.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -errmsg.o: errmsg.r $(HDRS) - ../../bin/rtt errmsg.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fconv.o: fconv.r $(HDRS) - ../../bin/rtt fconv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fload.o: fload.r $(HDRS) - ../../bin/rtt fload.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmath.o: fmath.r $(HDRS) - ../../bin/rtt fmath.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmisc.o: fmisc.r $(HDRS) - ../../bin/rtt fmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt fmonitr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fscan.o: fscan.r $(HDRS) - ../../bin/rtt fscan.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstr.o: fstr.r $(HDRS) - ../../bin/rtt fstr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstranl.o: fstranl.r $(HDRS) - ../../bin/rtt fstranl.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstruct.o: fstruct.r $(HDRS) - ../../bin/rtt fstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fsys.o: fsys.r $(HDRS) - ../../bin/rtt fsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt fwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -init.o: init.r $(HDRS) - ../../bin/rtt init.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -invoke.o: invoke.r $(HDRS) - ../../bin/rtt invoke.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -keyword.o: keyword.r $(HDRS) - ../../bin/rtt keyword.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -lmisc.o: lmisc.r $(HDRS) - ../../bin/rtt lmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oarith.o: oarith.r $(HDRS) - ../../bin/rtt oarith.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oasgn.o: oasgn.r $(HDRS) - ../../bin/rtt oasgn.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocat.o: ocat.r $(HDRS) - ../../bin/rtt ocat.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocomp.o: ocomp.r $(HDRS) - ../../bin/rtt ocomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -omisc.o: omisc.r $(HDRS) - ../../bin/rtt omisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oref.o: oref.r $(HDRS) - ../../bin/rtt oref.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oset.o: oset.r $(HDRS) - ../../bin/rtt oset.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ovalue.o: ovalue.r $(HDRS) - ../../bin/rtt ovalue.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ralc.o: ralc.r $(HDRS) - ../../bin/rtt ralc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt rcoexpr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcomp.o: rcomp.r $(HDRS) - ../../bin/rtt rcomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rdebug.o: rdebug.r $(HDRS) - ../../bin/rtt rdebug.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(COBJS): + cd ../common; $(MAKE) -rlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt rlrgint.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` -rmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt rmemmgt.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(XOBJS): $(HDRS) $(GHDRS) -rmisc.o: rmisc.r $(HDRS) - ../../bin/rtt rmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +data.o: ../h/fdefs.h ../h/odefs.h ../h/kdefs.h -rstruct.o: rstruct.r $(HDRS) - ../../bin/rtt rstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +fmisc.o: ../h/opdefs.h -rsys.o: rsys.r $(HDRS) - ../../bin/rtt rsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +imain.o: ../h/version.h ../h/header.h ../h/opdefs.h ../h/version.h -rwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinrsc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +init.o: ../h/header.h ../h/odefs.h ../h/version.h -rwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +keyword.o: ../h/kdefs.h ../h/features.h ../h/version.h -rwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rdebug.o: ../h/opdefs.h -rcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rcolor.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinrsc.o: rxrsc.ri -rimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinsys.o: rxwin.ri rmswin.ri diff --git a/src/runtime/cnv.r b/src/runtime/cnv.r index 23e1767..5661deb 100644 --- a/src/runtime/cnv.r +++ b/src/runtime/cnv.r @@ -14,9 +14,6 @@ * Assumed: the C compiler must handle assignments of C integers to * C double variables and vice-versa. Hopefully production C compilers * have managed to eliminate bugs related to these assignments. - * - * Note: calls beginning with EV are empty macros unless EventMon - * is defined. */ #define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a')) @@ -46,15 +43,10 @@ double *d; return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) *d = bigtoreal(s); else -#endif /* LargeInts */ - *d = IntVal(*s); - return 1; } string: { @@ -76,15 +68,11 @@ double *d; case T_Integer: *d = numrc.integer; return 1; - -#ifdef LargeInts case T_Lrgint: result.dword = D_Lrgint; BlkLoc(result) = (union block *)numrc.big; *d = bigtoreal(&result); return 1; -#endif /* LargeInts */ - case T_Real: *d = numrc.real; return 1; @@ -106,13 +94,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ - *d = IntVal(*s); return 1; } @@ -212,12 +196,8 @@ dptr s, d; register C_integer l; register char *s1; /* does not need to be tended */ - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } /* @@ -232,11 +212,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -254,12 +232,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ *d = IntVal(*s); return 1; } @@ -321,14 +296,10 @@ dptr s, d; case T_Integer: MakeInt(numrc.integer, d); return 1; - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; return 1; -#endif /* LargeInts */ - default: return 0; } @@ -344,36 +315,23 @@ dptr s, d; char sbuf[MaxCvtLen]; union numeric numrc; - EVValD(s, E_Aconv); - EVValD(&zerodesc, E_Tconv); - type_case *s of { integer: { *d = *s; - EVValD(s, E_Nconv); return 1; } real: { double dbl; GetReal(s,dbl); if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } string: { @@ -384,7 +342,6 @@ dptr s, d; s = &cnvstr; } default: { - EVValD(s, E_Fconv); return 0; } } @@ -393,43 +350,25 @@ dptr s, d; * s is now a string. */ switch( ston(s, &numrc) ) { - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; - EVValD(d, E_Sconv); return 1; -#endif /* LargeInts */ - case T_Integer: MakeInt(numrc.integer,d); - EVValD(d, E_Sconv); return 1; case T_Real: { double dbl = numrc.real; if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts - if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); + if (realtobig(s, d) == Succeeded) return 1; - } - else { - EVValD(s, E_Fconv); + else return 0; - } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ - } + } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } default: - EVValD(s, E_Fconv); return 0; } } @@ -442,17 +381,12 @@ dptr s, d; { double dbl; - EVValD(s, E_Aconv); - EVValD(&rzerodesc, E_Tconv); - if (cnv_c_dbl(s, &dbl)) { Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL)); d->dword = D_Real; - EVValD(d, E_Sconv); return 1; } else - EVValD(s, E_Fconv); return 0; } @@ -464,31 +398,23 @@ dptr s, d; { char sbuf[MaxCvtLen]; - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - type_case *s of { string: { *d = *s; - EVValD(s, E_Nconv); return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -497,12 +423,10 @@ dptr s, d; cset: cstos(BlkLoc(*s)->cset.bits, d, sbuf); default: { - EVValD(s, E_Fconv); return 0; } } Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL)); - EVValD(d, E_Sconv); return 1; } @@ -518,12 +442,8 @@ dptr s, d; register char *s1; C_integer l; - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } if (tmp_str(sbuf, s, &tmpstr)) { @@ -537,11 +457,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -554,20 +472,14 @@ char *sbuf; dptr s; dptr d; { - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - if (is:string(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } else if (tmp_str(sbuf, s, d)) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -661,21 +573,17 @@ dptr d; string: *d = *s; integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -731,16 +639,10 @@ C_integer arity; /* * See if the string represents a built-in function. */ -#if COMPILER - for (i = 0; i < n_globals; ++i) - if (eq(s, &gnames[i])) - return builtins[i]; /* may be null */ -#else /* COMPILER */ pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize, sizeof(struct pstrnm),dp_pnmcmp); if (pp!=NULL) return (struct b_proc *)pp->pblock; -#endif /* !COMPILER */ return NULL; } @@ -887,13 +789,9 @@ union numeric *result; */ if (c == 'r' || c == 'R') { int rv; -#ifdef LargeInts rv = bigradix((int)msign, (int)mantissa, s, end_s, result); if (rv == Error) fatalerr(0, NULL); -#else /* LargeInts */ - rv = radix((int)msign, (int)mantissa, s, end_s, result); -#endif /* LargeInts */ return rv; } @@ -959,21 +857,16 @@ union numeric *result; return T_Integer; } -#ifdef LargeInts /* * Test for bignum. */ -#if COMPILER - if (largeints) -#endif /* COMPILER */ - if (!realflag) { - int rv; - rv = bigradix((int)msign, 10, ssave, end_s, result); - if (rv == Error) - fatalerr(0, NULL); - return rv; - } -#endif /* LargeInts */ + if (!realflag) { + int rv; + rv = bigradix((int)msign, 10, ssave, end_s, result); + if (rv == Error) + fatalerr(0, NULL); + return rv; + } if (!realflag) return CvtFail; /* don't promote to real if integer format */ @@ -1023,50 +916,6 @@ union numeric *result; result->real = mantissa; return T_Real; } - -#if COMPILER || !(defined LargeInts) -/* - * radix - convert string s in radix r into an integer in *result. sign - * will be either '+' or '-'. - */ -int radix(sign, r, s, end_s, result) -int sign; -register int r; -register char *s; -register char *end_s; -union numeric *result; - { - register int c; - long num; - - if (r < 2 || r > 36) - return CvtFail; - c = (s < end_s) ? *s++ : ' '; - num = 0L; - while (isalnum(c)) { - c = tonum(c); - if (c >= r) - return CvtFail; - num = num * r + c; - c = (s < end_s) ? *s++ : ' '; - } - - /* - * Skip trailing white space and make sure there is nothing else left - * in the string. Note, if we have already reached end-of-string, - * c has been set to a space. - */ - while (isspace(c) && s < end_s) - c = *s++; - if (!isspace(c)) - return CvtFail; - - result->integer = (sign == '+' ? num : -num); - - return T_Integer; - } -#endif /* COMPILER || !(defined LargeInts) */ - /* * cvpos - convert position to strictly positive position diff --git a/src/runtime/data.r b/src/runtime/data.r index 1a276bd..be8c169 100644 --- a/src/runtime/data.r +++ b/src/runtime/data.r @@ -2,16 +2,8 @@ * data.r -- Various interpreter data tables. */ -#if !COMPILER - struct b_proc Bnoproc; -#ifdef EventMon -struct b_iproc mt_llist = { - 6, (sizeof(struct b_proc) - sizeof(struct descrip)), Ollist, - 0, -1, 0, 0, {sizeof( "[...]")-1, "[...]"}}; -#endif /* EventMon */ - /* * External declarations for function blocks. @@ -87,7 +79,6 @@ struct pstrnm pntab[] = { int pnsize = (sizeof(pntab) / sizeof(struct pstrnm)) - 1; -#endif /* COMPILER */ /* * Structures for built-in values. Parts of some of these structures are @@ -132,8 +123,6 @@ struct b_cset fullcs = { ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0) }; -#if !COMPILER - /* * Built-in csets */ @@ -181,29 +170,17 @@ struct b_cset k_letters = { cset_display(0, 0, 0, 0, ~01, 03777, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0) }; -#endif /* COMPILER */ /* * Built-in files. */ - -#ifndef MultiThread struct b_file k_errout = {T_File, NULL, Fs_Write}; /* &errout */ struct b_file k_input = {T_File, NULL, Fs_Read}; /* &input */ struct b_file k_output = {T_File, NULL, Fs_Write}; /* &output */ -#endif /* MultiThread */ - -#ifdef EventMon -/* - * Real block needed for event monitoring. - */ -struct b_real realzero = {T_Real, 0.0}; -#endif /* EventMon */ /* * Keyword variables. */ -#ifndef MultiThread struct descrip kywd_err = {D_Integer}; /* &error */ struct descrip kywd_pos = {D_Integer}; /* &pos */ struct descrip kywd_prog; /* &progname */ @@ -213,13 +190,6 @@ struct descrip kywd_trc = {D_Integer}; /* &trace */ struct descrip k_eventcode = {D_Null}; /* &eventcode */ struct descrip k_eventsource = {D_Null};/* &eventsource */ struct descrip k_eventvalue = {D_Null}; /* &eventvalue */ - -#endif /* MultiThread */ - -#ifdef FncTrace -struct descrip kywd_ftrc = {D_Integer}; /* &ftrace */ -#endif /* FncTrace */ - struct descrip kywd_dmp = {D_Integer}; /* &dump */ struct descrip nullptr = @@ -239,15 +209,6 @@ struct descrip onedesc = {D_Integer}; /* integer 1 */ struct descrip ucase; /* string of uppercase letters */ struct descrip zerodesc = {D_Integer}; /* integer 0 */ -#ifdef EventMon -/* - * Descriptors used by event monitoring. - */ -struct descrip csetdesc = {D_Cset}; -struct descrip eventdesc; -struct descrip rzerodesc = {D_Real}; -#endif /* EventMon */ - /* * An array of all characters for use in making one-character strings. */ @@ -303,6 +264,12 @@ struct errtab errtab[] = { 125, "list, record, or set expected", 126, "list or record expected", + /* general messages for use by code dealing with external data */ + 131, "external expected", /* not an external */ + 132, "incorrect external type", /* external of wrong flavor */ + 133, "invalid external value", /* right flavor in wrong context */ + 134, "malformed external value", /* data bogus, not just inappropriate */ + #ifdef Graphics 140, "window expected", 141, "program terminated by window manager", @@ -344,9 +311,6 @@ struct errtab errtab[] = { 307, "inadequate space in block region", 308, "system stack overflow in co-expression", -#ifndef Coexpr - 401, "co-expressions not implemented", -#endif /* Coexpr */ 402, "program not compiled with debugging option", 500, "program malfunction", /* for use by runerr() */ @@ -355,7 +319,6 @@ struct errtab errtab[] = { 0, "" }; -#if !COMPILER #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); #include "../h/odefs.h" #undef OpDef @@ -398,4 +361,3 @@ int (*keytab[])() = { #define KDef(p,n) Cat(K,p), #include "../h/kdefs.h" }; -#endif /* !COMPILER */ diff --git a/src/runtime/errmsg.r b/src/runtime/errmsg.r index 7095781..03d558a 100644 --- a/src/runtime/errmsg.r +++ b/src/runtime/errmsg.r @@ -38,18 +38,11 @@ dptr v; break; } - EVVal((word)k_errornumber,E_Error); - if (pfp != NULL) { if (IntVal(kywd_err) == 0 || !err_conv) { fprintf(stderr, "\nRun-time error %d\n", k_errornumber); -#if COMPILER - if (line_info) - fprintf(stderr, "File %s; Line %d\n", file_name, line_num); -#else /* COMPILER */ fprintf(stderr, "File %s; Line %ld\n", findfile(ipc.opnd), (long)findline(ipc.opnd)); -#endif /* COMPILER */ } else { IntVal(kywd_err)--; diff --git a/src/runtime/extcall.r b/src/runtime/extcall.r deleted file mode 100644 index 5652416..0000000 --- a/src/runtime/extcall.r +++ /dev/null @@ -1,21 +0,0 @@ -/* - * extcall.r - */ - -#if !COMPILER -#ifdef ExternalFunctions - -/* - * extcall - stub procedure for external call interface. - */ -dptr extcall(dargv, argc, ip) -dptr dargv; -int argc; -int *ip; - { - *ip = 216; /* no external function to find */ - return (dptr)NULL; - } - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ diff --git a/src/runtime/fconv.r b/src/runtime/fconv.r index 7c3a3ff..d458062 100644 --- a/src/runtime/fconv.r +++ b/src/runtime/fconv.r @@ -22,24 +22,17 @@ function{1} abs(n) else { i = neg(n); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(n,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,n); - errorfail; -#endif /* LargeInts */ } } return C_integer i; } } - -#ifdef LargeInts else if cnv:(exact)integer(n) then { abstract { return integer @@ -54,7 +47,6 @@ function{1} abs(n) return result; } } -#endif /* LargeInts */ else if cnv:C_double(n) then { abstract { @@ -140,55 +132,13 @@ end "proc(x,i) - convert x to a procedure if possible; use i to resolve " "ambiguous string names." -#ifdef MultiThread -function{0,1} proc(x,i,c) -#else /* MultiThread */ function{0,1} proc(x,i) -#endif /* MultiThread */ - -#ifdef MultiThread - if is:coexpr(x) then { - abstract { - return proc - } - inline { - struct b_coexpr *ce = NULL; - struct b_proc *bp = NULL; - struct pf_marker *fp; - dptr dp=NULL; - if (BlkLoc(x) != BlkLoc(k_current)) { - ce = (struct b_coexpr *)BlkLoc(x); - dp = ce->es_argp; - if (dp == NULL) fail; - bp = (struct b_proc *)BlkLoc(*(dp)); - } - else - bp = (struct b_proc *)BlkLoc(*(glbl_argp)); - return proc(bp); - } - } -#endif /* MultiThread */ if is:proc(x) then { abstract { return proc } inline { - -#ifdef MultiThread - if (!is:null(c)) { - struct progstate *p; - if (!is:coexpr(c)) runerr(118,c); - /* - * Test to see whether a given procedure belongs to a given - * program. Currently this is a sleazy pointer arithmetic check. - */ - p = BlkLoc(c)->coexpr.program; - if (! InRange(p, BlkLoc(x)->proc.entryp.icode, - (char *)p + p->hsize)) - fail; - } -#endif /* MultiThread */ return x; } } @@ -212,23 +162,6 @@ function{0,1} proc(x,i) inline { struct b_proc *prc; -#ifdef MultiThread - struct progstate *prog, *savedprog; - - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ - /* * Attempt to convert Arg0 to a procedure descriptor using i to * discriminate between procedures with the same names. If i @@ -240,9 +173,6 @@ function{0,1} proc(x,i) else prc = strprc(&x, i); -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ if (prc == NULL) fail; else diff --git a/src/runtime/fload.r b/src/runtime/fload.r index dfb9fcc..e972002 100644 --- a/src/runtime/fload.r +++ b/src/runtime/fload.r @@ -22,24 +22,6 @@ #define RTLD_LAZY 1 #endif /* RTLD_LAZY */ -#ifdef FreeBSD - /* - * If DL_GETERRNO exists, this is an FreeBSD 1.1.5 or 2.0 - * which lacks dlerror(); supply a substitute. - */ - #passthru #ifdef DL_GETERRNO - char *dlerror(void) - { - int no; - - if (0 == dlctl(NULL, DL_GETERRNO, &no)) - return(strerror(no)); - else - return(NULL); - } - #passthru #endif -#endif /* __FreeBSD__ */ - int glue(); int makefunc (dptr d, char *name, int (*func)()); @@ -69,7 +51,7 @@ function{0,1} loadfunc(filename,funcname) if (curfile) free((pointer)curfile); /* free the old file name */ curfile = salloc(filename); /* save the new name */ - handle = dlopen(filename, RTLD_LAZY); /* get the handle */ + handle = dlopen(filename, RTLD_LAZY | RTLD_GLOBAL); /* get handle */ } /* * Load the function. Diagnose both library and function errors here. @@ -121,12 +103,7 @@ int (*func)(); return 0; blk->title = T_Proc; blk->blksize = sizeof(struct b_proc); - -#if COMPILER - blk->ccode = glue; /* set code addr to glue routine */ -#else /* COMPILER */ blk->entryp.ccode = glue; /* set code addr to glue routine */ -#endif /* COMPILER */ blk->nparam = -1; /* varargs flag */ blk->ndynam = -1; /* treat as built-in function */ @@ -147,47 +124,6 @@ int (*func)(); * It digs the actual C code address out of the proc block, and calls that. */ -#if COMPILER - -int glue(argc, dargv, rslt, succ_cont) -int argc; -dptr dargv; -dptr rslt; -continuation succ_cont; - { - int i, status, (*func)(); - struct b_proc *blk; - struct descrip r; - tended struct descrip p; - - dargv--; /* reset pointer to proc entry */ - for (i = 0; i <= argc; i++) - deref(&dargv[i], &dargv[i]); /* dereference args including proc */ - - blk = (struct b_proc *)dargv[0].vword.bptr; /* proc block address */ - func = (int (*)())blk->lnames[0].vword.sptr; /* entry point address */ - - p = dargv[0]; /* save proc for traceback */ - dargv[0] = nulldesc; /* set default return value */ - status = (*func)(argc, dargv); /* call func */ - - if (status == 0) { - *rslt = dargv[0]; - Return; /* success */ - } - - if (status < 0) - Fail; /* failure */ - - r = dargv[0]; /* save result value */ - dargv[0] = p; /* restore proc for traceback */ - if (is:null(r)) - RunErr(status, NULL); /* error, no value */ - RunErr(status, &r); /* error, with value */ - } - -#else /* COMPILER */ - int glue(argc, dargv) int argc; dptr dargv; @@ -216,6 +152,4 @@ dptr dargv; RunErr(status, &r); /* error, with value */ } -#endif /* COMPILER */ - #endif /* LoadFunc */ diff --git a/src/runtime/fmisc.r b/src/runtime/fmisc.r index 6691241..2c4474d 100644 --- a/src/runtime/fmisc.r +++ b/src/runtime/fmisc.r @@ -5,9 +5,7 @@ * ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf, * type, variable */ -#if !COMPILER #include "../h/opdefs.h" -#endif /* !COMPILER */ "args(p) - produce number of arguments for procedure p." @@ -24,53 +22,6 @@ function{1} args(x) } end -#if !COMPILER -#ifdef ExternalFunctions - -/* - * callout - call a C library routine (or any C routine that doesn't call Icon) - * with an argument count and a list of descriptors. This routine - * doesn't build a procedure frame to prepare for calling Icon back. - */ -function{1} callout(x[nargs]) - body { - dptr retval; - int signal; - - /* - * Little cheat here. Although this is a var-arg procedure, we need - * at least one argument to get started: pretend there is a null on - * the stack. NOTE: Actually, at present, varargs functions always - * have at least one argument, so this doesn't plug the hole. - */ - if (nargs < 1) - runerr(103, nulldesc); - - /* - * Call the 'C routine caller' with a pointer to an array of descriptors. - * Note that these are being left on the stack. We are passing - * the name of the routine as part of the convention of calling - * routines with an argc/argv technique. - */ - signal = -1; /* presume successful completiong */ - retval = extcall(x, nargs, &signal); - if (signal >= 0) { - if (retval == NULL) - runerr(signal); - else - runerr(signal, *retval); - } - if (retval != NULL) { - return *retval; - } - else - fail; - } -end - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ - "char(i) - produce a string consisting of character i." @@ -174,11 +125,6 @@ function{1} copy(x) } table: { body { -#ifdef TableFix - if (cptable(&x, &result, BlkLoc(x)->table.size) == Error) - runerr(0); - return result; -#else /* TableFix */ register int i; register word slotnum; tended union block *src; @@ -195,7 +141,10 @@ function{1} copy(x) runerr(0); dst->table.size = src->table.size; dst->table.mask = src->table.mask; - dst->table.defvalue = src->table.defvalue; + /* dst->table.defvalue = src->table.defvalue; */ + /* to avoid gcc 4.2.2 bug on Sparc, do instead: */ + memcpy(&dst->table.defvalue, &src->table.defvalue, + sizeof(struct descrip)); for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++) memcpy((char *)dst->table.hdir[i], (char *)src->table.hdir[i], src->table.hdir[i]->blksize); @@ -221,9 +170,7 @@ function{1} copy(x) if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Tcreate, D_Table); return table(dst); -#endif /* TableFix */ } } @@ -262,14 +209,17 @@ function{1} copy(x) d2 = old_rec->fields; while (i--) *d1++ = *d2++; - Desc_EVValD(new_rec, E_Rcreate, D_Record); return record(new_rec); } } - default: body { - runerr(123,x); - } + default: + body { + if (Type(x) == T_External) + return callextfunc(&extlcopy, &x, NULL); + else + runerr(123,x); + } } end @@ -278,15 +228,7 @@ end " procedure activations, plus global variables." " Output to file f (default &errout)." -#ifdef MultiThread -function{1} display(i,f,c) - declare { - struct b_coexpr *ce = NULL; - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} display(i,f) -#endif /* MultiThread */ if !def:C_integer(i,(C_integer)k_level) then runerr(101, i) @@ -299,15 +241,6 @@ function{1} display(i,f) else if !is:file(f) then runerr(105, f) -#ifdef MultiThread - if !is:null(c) then inline { - if (!is:coexpr(c)) runerr(118,c); - else if (BlkLoc(c) != BlkLoc(k_current)) - ce = (struct b_coexpr *)BlkLoc(c); - savedprog = curpstate; - } -#endif /* MultiThread */ - abstract { return null } @@ -340,16 +273,7 @@ function{1} display(i,f) (long)BlkLoc(k_current)->coexpr.id, (long)BlkLoc(k_current)->coexpr.size); fflush(std_f); -#ifdef MultiThread - if (ce) { - if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail; - ENTERPSTATE(ce->program); - r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f); - ENTERPSTATE(savedprog); - } - else -#endif /* MultiThread */ - r = xdisp(pfp, glbl_argp, (int)i, std_f); + r = xdisp(pfp, glbl_argp, (int)i, std_f); if (r == Failed) runerr(305); return nulldesc; @@ -372,7 +296,6 @@ function{1} errorclear() } end -#if !COMPILER "function() - generate the names of the functions." @@ -389,7 +312,6 @@ function{*} function() fail; } end -#endif /* !COMPILER */ /* @@ -412,13 +334,11 @@ function{1} func_name(i,j) return integer } inline { -#ifdef LargeInts if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) { big_ ## c_op(i,j); } else -#endif /* LargeInts */ - return C_integer IntVal(i) c_op IntVal(j); + return C_integer IntVal(i) c_op IntVal(j); } end #enddef @@ -466,7 +386,6 @@ function{1} icom(i) return integer } inline { -#ifdef LargeInts if (Type(i) == T_Lrgint) { struct descrip td; @@ -477,8 +396,7 @@ function{1} icom(i) return result; } else -#endif /* LargeInts */ - return C_integer ~IntVal(i); + return C_integer ~IntVal(i); } end @@ -514,7 +432,6 @@ function{1} ishift(i,j) body { uword ci; /* shift in 0s, even if negative */ C_integer cj; -#ifdef LargeInts if (Type(j) == T_Lrgint) runerr(101,j); cj = IntVal(j); @@ -524,10 +441,6 @@ function{1} ishift(i,j) runerr(0); return result; } -#else /* LargeInts */ - ci = (uword)IntVal(i); - cj = IntVal(j); -#endif /* LargeInts */ /* * Check for a shift of WordSize or greater; handle specially because * this is beyond C's defined behavior. Otherwise shift as requested. @@ -564,14 +477,7 @@ end "name(v) - return the name of a variable." -#ifdef MultiThread -function{1} name(underef v, c) - declare { - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} name(underef v) -#endif /* MultiThread */ /* * v must be a variable */ @@ -586,27 +492,7 @@ function{1} name(underef v) C_integer i; if (!debug_info) runerr(402); - -#ifdef MultiThread - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ i = get_name(&v, &result); /* return val ? #%#% */ - -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ - if (i == Error) runerr(0); return result; @@ -672,7 +558,6 @@ function{1,*} seq(from, by) } while (from >= seq_lb && from <= seq_ub); -#if !COMPILER { /* * Suspending wipes out some things needed by the trace back code to @@ -684,7 +569,6 @@ function{1,*} seq(from, by) r_args[0].dword = D_Proc; r_args[0].vword.bptr = (union block *)&Bseq; } -#endif /* COMPILER */ runerr(203); } @@ -724,8 +608,12 @@ function {0,1} serial(x) } } #endif /* Graphics */ - default: - inline { fail; } + default: inline { + if (Type(x) == T_External) + return C_integer BlkLoc(x)->externl.id; + else + fail; + } } end @@ -750,7 +638,6 @@ function{1} sort(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) anycmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -775,9 +662,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -788,7 +672,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -814,9 +697,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -829,7 +709,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -883,9 +762,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0)); lp->listtail = lp->listhead = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ /* * If the table is empty, there is no need to sort anything. */ @@ -904,20 +780,12 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep= seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink){ Protect(tp = alclist((word)2), runerr(0)); Protect(ev = (union block *)alclstb((word)2, (word)0, (word)2), runerr(0)); tp->listhead = tp->listtail = ev; -#ifdef ListFix - ev->lelem.listprev = ev->lelem.listnext = - (union block *)tp; -#endif /* ListFix */ tp->listhead->lelem.lslots[0] = ep->telem.tref; tp->listhead->lelem.lslots[1] = ep->telem.tval; d1 = &lp->listhead->lelem.lslots[n++]; @@ -958,9 +826,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ /* * If the table is empty there's no need to sort anything. */ @@ -983,11 +848,7 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep = seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) { *d1++ = ep->telem.tref; *d1++ = ep->telem.tval; @@ -1016,7 +877,6 @@ function{1} sort(t, i) * Make result point at the sorted list. */ - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1033,12 +893,6 @@ end int trefcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("trefcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); } @@ -1050,12 +904,6 @@ dptr d1, d2; int tvalcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("tvalcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); } @@ -1113,7 +961,6 @@ function{1} sortf(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) nthcmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -1146,9 +993,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -1160,7 +1004,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1194,9 +1037,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -1210,7 +1050,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1337,12 +1176,9 @@ function{1} type(x) coexpr: inline { return C_string "co-expression"; } default: inline { -#if !COMPILER - if (!Qual(x) && (Type(x)==T_External)) { - return C_string "external"; - } + if (!Qual(x) && (Type(x) == T_External)) + return callextfunc(&extlname, &x, NULL); else -#endif /* !COMPILER */ runerr(123,x); } } @@ -1352,853 +1188,20 @@ end "variable(s) - find the variable with name s and return a" " variable descriptor which points to its value." -#ifdef MultiThread -function{0,1} variable(s,c,i) -#else /* MultiThread */ function{0,1} variable(s) -#endif /* MultiThread */ - if !cnv:C_string(s) then runerr(103, s) -#ifdef MultiThread - if !def:C_integer(i,0) then - runerr(101,i) -#endif /* MultiThread */ - abstract { return variable } body { register int rv; - -#ifdef MultiThread - struct progstate *prog, *savedprog; - struct pf_marker *tmp_pfp = pfp; - dptr tmp_argp = glbl_argp; - - savedprog = curpstate; - if (!is:null(c)) { - if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - pfp = BlkLoc(c)->coexpr.es_pfp; - glbl_argp = BlkLoc(c)->coexpr.es_argp; - ENTERPSTATE(prog); - } - else { - runerr(118, c); - } - } - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - if (pfp == NULL) fail; - glbl_argp = pfp->pf_argp; - pfp = pfp->pf_pfp; - } -#endif /* MultiThread */ - rv = getvar(s, &result); - -#ifdef MultiThread - if (is:coexpr(c)) { - ENTERPSTATE(savedprog); - pfp = tmp_pfp; - glbl_argp = tmp_argp; - - if ((rv == LocalName) || (rv == StaticName)) { - Deref(result); - } - } -#endif /* MultiThread */ - if (rv != Failed) return result; else fail; } end - -#ifdef MultiThread - -"cofail(CE) - transmit a co-expression failure to CE" - -function{0,1} cofail(CE) - abstract { - return any_value - } - if is:null(CE) then - body { - struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current)); - if (ce != NULL) { - CE.dword = D_Coexpr; - BlkLoc(CE) = (union block *)ce; - } - else runerr(118,CE); - } - else if !is:coexpr(CE) then - runerr(118,CE) - body { - struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE); - if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail; - return result; - } -end - - -"fieldnames(r) - generate the fieldnames of record r" - -function{*} fieldnames(r) - abstract { - return string - } - if !is:record(r) then runerr(107,r) - body { - int i; - for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) { - suspend BlkLoc(r)->record.recdesc->proc.lnames[i]; - } - fail; - } -end - - -"localnames(ce,i) - produce the names of local variables" -" in the procedure activation i levels up in ce" -function{*} localnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118, ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - - -"staticnames(ce,i) - produce the names of static variables" -" in the current procedure activation in ce" - -function{*} staticnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j=0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - -"paramnames(ce,i) - produce the names of the parameters" -" in the current procedure activation in ce" - -function{1,*} paramnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_main; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - -"load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load" -" an icode file corresponding to string s as a co-expression." - -function{1} load(s,arglist,infile,outfile,errfile, - blocksize, stringsize, stacksize) - declare { - tended char *loadstring; - C_integer _bs_, _ss_, _stk_; - } - if !cnv:C_string(s,loadstring) then - runerr(103,s) - if !def:C_integer(blocksize,abrsize,_bs_) then - runerr(101,blocksize) - if !def:C_integer(stringsize,ssize,_ss_) then - runerr(101,stringsize) - if !def:C_integer(stacksize,mstksize,_stk_) then - runerr(101,stacksize) - abstract { - return coexpr - } - body { - word *stack; - struct progstate *pstate; - char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; - register struct b_coexpr *sblkp; - register struct b_refresh *rblkp; - struct ef_marker *newefp; - register dptr dp, ndp, dsp; - register word *newsp, *savedsp; - int na, nl, i, j, num_fileargs = 0; - struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL; - struct b_proc *cproc; - extern char *prog_name; - - /* - * Fragments of pseudo-icode to get loaded programs started, - * and to handle termination. - */ - static word pstart[7]; - static word *lterm; - - inst tipc; - - tipc.opnd = pstart; - *tipc.op++ = Op_Noop; /* aligns Invokes operand */ /* ?cj? */ - *tipc.op++ = Op_Invoke; - *tipc.opnd++ = 1; - *tipc.op++ = Op_Coret; - *tipc.op++ = Op_Efail; - - lterm = (word *)(tipc.op); - - *tipc.op++ = Op_Cofail; - *tipc.op++ = Op_Agoto; - *tipc.opnd = (word)lterm; - - prog_name = loadstring; /* set up for &progname */ - - /* - * arglist must be a list - */ - if (!is:null(arglist) && !is:list(arglist)) - runerr(108,arglist); - - /* - * input, output, and error must be files - */ - if (is:null(infile)) - theInput = &(curpstate->K_input); - else { - if (!is:file(infile)) - runerr(105,infile); - else theInput = &(BlkLoc(infile)->file); - } - if (is:null(outfile)) - theOutput = &(curpstate->K_output); - else { - if (!is:file(outfile)) - runerr(105,outfile); - else theOutput = &(BlkLoc(outfile)->file); - } - if (is:null(errfile)) - theError = &(curpstate->K_errout); - else { - if (!is:file(errfile)) - runerr(105,errfile); - else theError = &(BlkLoc(errfile)->file); - } - - stack = - (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError, - _bs_,_ss_,_stk_)); - if(!stack) { - fail; - } - pstate = sblkp->program; - pstate->parent = curpstate; - pstate->parentdesc = k_main; - - savedsp = sp; - sp = stack + Wsizeof(struct b_coexpr) - + Wsizeof(struct progstate) + pstate->hsize/WordSize; - if (pstate->hsize % WordSize) sp++; - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = NULL; - sblkp->es_gfp = NULL; - pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */ - /* This really is a bug. */ - - /* - * Set up expression frame marker to contain execution of the - * main procedure. If failure occurs in this context, control - * is transferred to lterm, the address of an ... - */ - newefp = (struct ef_marker *)(sp+1); -#if IntBits != WordBits - newefp->ef_failure.op = (int *)lterm; -#else /* IntBits != WordBits */ - newefp->ef_failure.op = lterm; -#endif /* IntBits != WordBits */ - - newefp->ef_gfp = 0; - newefp->ef_efp = 0; - newefp->ef_ilevel = ilevel/*1*/; - sp += Wsizeof(*newefp) - 1; - sblkp->es_efp = newefp; - - /* - * The first global variable holds the value of "main". If it - * is not of type procedure, this is noted as run-time error 117. - * Otherwise, this value is pushed on the stack. - */ - if (pstate->Globals[0].dword != D_Proc) - fatalerr(117, NULL); - - PushDesc(pstate->Globals[0]); - - /* - * Create a list from arguments using Ollist and push a descriptor - * onto new stack. Then create procedure frame on new stack. Push - * two new null descriptors, and set sblkp->es_sp when all finished. - */ - if (!is:null(arglist)) { - PushDesc(arglist); - pstate->Glbl_argp = (dptr)(sp - 1); - } - else { - PushNull; - pstate->Glbl_argp = (dptr)(sp - 1); - { - dptr tmpargp = (dptr) (sp - 1); - Ollist(0, tmpargp); - sp = (word *)tmpargp + 1; - } - } - sblkp->es_sp = (word *)sp; - sblkp->es_ipc.opnd = pstart; - - result.dword = D_Coexpr; - BlkLoc(result) = (union block *)sblkp; - sp = savedsp; - return result; - } -end - - -"parent(ce) - given a ce, return &main for that ce's parent" - -function{1} parent(ce) - if is:null(ce) then inline { ce = k_current; } - else if !is:coexpr(ce) then runerr(118,ce) - abstract { - return coexpr - } - body { - if (BlkLoc(ce)->coexpr.program->parent == NULL) fail; - - result.dword = D_Coexpr; - BlkLoc(result) = - (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead); - return result; - } -end - -#ifdef EventMon - -"eventmask(ce,cs) - given a ce, get or set that program's event mask" - -function{1} eventmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->eventmask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"globalnames(ce) - produce the names of identifiers global to ce" - -function{*} globalnames(ce) - declare { - struct progstate *ps; - } - abstract { - return string - } - if is:null(ce) then inline { ps = curpstate; } - else if is:coexpr(ce) then - inline { ps = BlkLoc(ce)->coexpr.program; } - else runerr(118,ce) - body { - struct descrip *dp; - for (dp = ps->Gnames; dp != ps->Egnames; dp++) { - suspend *dp; - } - fail; - } -end - -"keyword(kname,ce) - produce a keyword in ce's thread" -function{*} keyword(keyname,ce) - declare { - tended struct descrip d; - tended char *kyname; - } - abstract { - return any_value - } - if !cnv:C_string(keyname,kyname) then runerr(103,keyname) - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd; - } - else if is:coexpr(ce) then - inline { d = ce; } - else runerr(118, ce) - body { - struct progstate *p = BlkLoc(d)->coexpr.program; - char *kname = kyname; - if (kname[0] == '&') kname++; - if (strcmp(kname,"allocated") == 0) { - suspend C_integer stattotal + p->stringtotal + p->blocktotal; - suspend C_integer stattotal; - suspend C_integer p->stringtotal; - return C_integer p->blocktotal; - } - else if (strcmp(kname,"collections") == 0) { - suspend C_integer p->colltot; - suspend C_integer p->collstat; - suspend C_integer p->collstr; - return C_integer p->collblk; - } - else if (strcmp(kname,"column") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"current") == 0) { - return p->K_current; - } - else if (strcmp(kname,"error") == 0) { - return kywdint(&(p->Kywd_err)); - } - else if (strcmp(kname,"errornumber") == 0) { - return C_integer p->K_errornumber; - } - else if (strcmp(kname,"errortext") == 0) { - return C_string p->K_errortext; - } - else if (strcmp(kname,"errorvalue") == 0) { - return p->K_errorvalue; - } - else if (strcmp(kname,"errout") == 0) { - return file(&(p->K_errout)); - } - else if (strcmp(kname,"eventcode") == 0) { - return kywdevent(&(p->eventcode)); - } - else if (strcmp(kname,"eventsource") == 0) { - return kywdevent(&(p->eventsource)); - } - else if (strcmp(kname,"eventvalue") == 0) { - return kywdevent(&(p->eventval)); - } - else if (strcmp(kname,"file") == 0) { - struct progstate *savedp = curpstate; - struct descrip s; - ENTERPSTATE(p); - StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd); - StrLen(s) = strlen(StrLoc(s)); - ENTERPSTATE(savedp); - if (!strcmp(StrLoc(s),"?")) fail; - return s; - } - else if (strcmp(kname,"input") == 0) { - return file(&(p->K_input)); - } - else if (strcmp(kname,"level") == 0) { - /* - * Bug; levels aren't maintained per program yet. - * But shouldn't they be per co-expression, not per program? - */ - } - else if (strcmp(kname,"line") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findline(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"main") == 0) { - return p->K_main; - } - else if (strcmp(kname,"output") == 0) { - return file(&(p->K_output)); - } - else if (strcmp(kname,"pos") == 0) { - return kywdpos(&(p->Kywd_pos)); - } - else if (strcmp(kname,"progname") == 0) { - return kywdstr(&(p->Kywd_prog)); - } - else if (strcmp(kname,"random") == 0) { - return kywdint(&(p->Kywd_ran)); - } - else if (strcmp(kname,"regions") == 0) { - word allRegions = 0; - struct region *rp; - - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"source") == 0) { - return coexpr(topact((struct b_coexpr *)BlkLoc(BlkLoc(d)->coexpr.program->K_current))); -/* - if (BlkLoc(d)->coexpr.es_actstk) - return coexpr(topact((struct b_coexpr *)BlkLoc(d))); - else return BlkLoc(d)->coexpr.program->parent->K_main; -*/ - } - else if (strcmp(kname,"storage") == 0) { - word allRegions = 0; - struct region *rp; - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"subject") == 0) { - return kywdsubj(&(p->ksub)); - } - else if (strcmp(kname,"trace") == 0) { - return kywdint(&(p->Kywd_trc)); - } -#ifdef Graphics - else if (strcmp(kname,"window") == 0) { - return kywdwin(&(p->Kywd_xwin[XKey_Window])); - } - else if (strcmp(kname,"col") == 0) { - return kywdint(&(p->AmperCol)); - } - else if (strcmp(kname,"row") == 0) { - return kywdint(&(p->AmperRow)); - } - else if (strcmp(kname,"x") == 0) { - return kywdint(&(p->AmperX)); - } - else if (strcmp(kname,"y") == 0) { - return kywdint(&(p->AmperY)); - } - else if (strcmp(kname,"interval") == 0) { - return kywdint(&(p->AmperInterval)); - } - else if (strcmp(kname,"control") == 0) { - if (p->Xmod_Control) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"shift") == 0) { - if (p->Xmod_Shift) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"meta") == 0) { - if (p->Xmod_Meta) - return nulldesc; - else - fail; - } -#endif /* Graphics */ - runerr(205, keyname); - } -end -#ifdef EventMon - -"opmask(ce,cs) - get or set ce's program's opcode mask" - -function{1} opmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->opcodemask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"structure(x) -- generate all structures allocated in program x" -function {*} structure(x) - - if !is:coexpr(x) then - runerr(118, x) - - abstract { - return list ++ set ++ table ++ record - } - - body { - tended char *bp; - char *free; - tended struct descrip descr; - word type; - struct region *theregion, *rp; - -#ifdef MultiThread - theregion = ((struct b_coexpr *)BlkLoc(x))->program->blockregion; -#else - theregion = curblock; -#endif - for(rp = theregion; rp; rp = rp->next) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - for(rp = theregion->prev; rp; rp = rp->prev) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - fail; - } -end - - -#endif /* MultiThread */ diff --git a/src/runtime/fmonitr.r b/src/runtime/fmonitr.r deleted file mode 100644 index 8eeb95e..0000000 --- a/src/runtime/fmonitr.r +++ /dev/null @@ -1,273 +0,0 @@ -/* - * fmonitr.r -- event, EvGet - * - * This file contains event monitoring code, used only if EventMon - * (event monitoring) is defined. Event monitoring is normally is - * not enabled. - */ - -#ifdef EventMon - -/* - * Prototypes. - */ - -void mmrefresh (void); - -#define evforget() - - -char typech[MaxType+1]; /* output character for each type */ - -int noMTevents; /* don't produce events in EVAsgn */ - -#ifdef MultiThread - -static char scopechars[] = "+:^-"; - -/* - * Special event function for E_Assign; allocates out of monitor's heap. - */ -void EVAsgn(dx) -dptr dx; -{ - int i; - dptr procname; - struct progstate *parent = curpstate->parent; - struct region *rp = curpstate->stringregion; - -#if COMPILER - procname = &(PFDebug(*pfp)->proc->pname); -#else /* COMPILER */ - procname = &((&BlkLoc(*glbl_argp)->proc)->pname); -#endif /* COMPILER */ - /* - * call get_name, allocating out of the monitor if necessary. - */ - curpstate->stringregion = parent->stringregion; - parent->stringregion = rp; - noMTevents++; - i = get_name(dx,&(parent->eventval)); - - if (i == GlobalName) { - if (reserve(Strings, StrLen(parent->eventval) + 1) == NULL) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr("+",1); - StrLen(parent->eventval)++; - } - else if (i == StaticName || i == LocalName || i == ParamName) { - if (!reserve(Strings, StrLen(parent->eventval) + StrLen(*procname) + 1)) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr(scopechars+i,1); - alcstr(StrLoc(*procname), StrLen(*procname)); - StrLen(parent->eventval) += StrLen(*procname) + 1; - } - else if (i == Error) { - noMTevents--; - return; /* should be more violent than this */ - } - - parent->stringregion = curpstate->stringregion; - curpstate->stringregion = rp; - noMTevents--; - actparent(E_Assign); -} - - -/* - * event(x, y, C) -- generate an event at the program level. - */ - -"event(x, y, C) - create event with event code x and event value y." - -function{0,1} event(x,y,ce) - body { - struct progstate *dest; - - if (is:null(x)) { - x = curpstate->eventcode; - if (is:null(y)) y = curpstate->eventval; - } - if (is:null(ce) && is:coexpr(curpstate->parentdesc)) - ce = curpstate->parentdesc; - else if (!is:coexpr(ce)) runerr(118,ce); - dest = BlkLoc(ce)->coexpr.program; - dest->eventcode = x; - dest->eventval = y; - if (mt_activate(&(dest->eventcode),&result, - (struct b_coexpr *)BlkLoc(ce)) == A_Cofail) { - fail; - } - return result; - } -end - -/* - * EvGet(c) - user function for reading event streams. - */ - -"EvGet(c,flag) - read through the next event token having a code matched " -" by cset c." - -/* - * EvGet returns the code of the matched token. These keywords are also set: - * &eventcode token code - * &eventvalue token value - */ -function{0,1} EvGet(cs,flag) - if !def:cset(cs,fullcs) then - runerr(104,cs) - - body { - register int c; - tended struct descrip dummy; - struct progstate *p; - - /* - * Be sure an eventsource is available - */ - if (!is:coexpr(curpstate->eventsource)) - runerr(118,curpstate->eventsource); - - /* - * If our event source is a child of ours, assign its event mask. - */ - p = BlkLoc(curpstate->eventsource)->coexpr.program; - if (p->parent == curpstate) - p->eventmask = cs; - -#ifdef Graphics - if (Testb((word)E_MXevent, cs) && - is:file(kywd_xwin[XKey_Window])) { - wbp _w_ = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; - pollctr = pollevent(); - if (pollctr == -1) - fatalerr(141, NULL); - if (BlkLoc(_w_->window->listp)->list.size > 0) { - c = wgetevent(_w_, &curpstate->eventval); - if (c == 0) { - StrLen(curpstate->eventcode) = 1; - StrLoc(curpstate->eventcode) = - (char *)&allchars[E_MXevent & 0xFF]; - return curpstate->eventcode; - } - else if (c == -1) - runerr(141); - else - runerr(143); - } - } -#endif /* Graphics */ - - /* - * Loop until we read an event allowed. - */ - while (1) { - /* - * Activate the event source to produce the next event. - */ - dummy = cs; - if (mt_activate(&dummy, &curpstate->eventcode, - (struct b_coexpr *)BlkLoc(curpstate->eventsource)) == - A_Cofail) fail; - deref(&curpstate->eventcode, &curpstate->eventcode); - if (!is:string(curpstate->eventcode) || - StrLen(curpstate->eventcode) != 1) { - /* - * this event is out-of-band data; return or reject it - * depending on whether flag is null. - */ - if (!is:null(flag)) - return curpstate->eventcode; - else continue; - } - - switch(*StrLoc(curpstate->eventcode)) { - case E_Cofail: case E_Coret: { - if (BlkLoc(curpstate->eventsource)->coexpr.id == 1) { - fail; - } - } - } - - return curpstate->eventcode; - } - } -end - -#endif /* MultiThread */ - -/* - * EVInit() - initialization. - */ - -void EVInit() - { - int i; - - /* - * Initialize the typech array, which is used if either file-based - * or MT-based event monitoring is enabled. - */ - - for (i = 0; i <= MaxType; i++) - typech[i] = '?'; /* initialize with error character */ - -#ifdef LargeInts - typech[T_Lrgint] = E_Lrgint; /* long integer */ -#endif /* LargeInts */ - - typech[T_Real] = E_Real; /* real number */ - typech[T_Cset] = E_Cset; /* cset */ - typech[T_File] = E_File; /* file block */ - typech[T_Record] = E_Record; /* record block */ - typech[T_Tvsubs] = E_Tvsubs; /* substring trapped variable */ - typech[T_External]= E_External; /* external block */ - typech[T_List] = E_List; /* list header block */ - typech[T_Lelem] = E_Lelem; /* list element block */ - typech[T_Table] = E_Table; /* table header block */ - typech[T_Telem] = E_Telem; /* table element block */ - typech[T_Tvtbl] = E_Tvtbl; /* table elem trapped variable*/ - typech[T_Set] = E_Set; /* set header block */ - typech[T_Selem] = E_Selem; /* set element block */ - typech[T_Slots] = E_Slots; /* set/table hash slots */ - typech[T_Coexpr] = E_Coexpr; /* co-expression block (static) */ - typech[T_Refresh] = E_Refresh; /* co-expression refresh block */ - - - /* - * codes used elsewhere but not shown here: - * in the static region: E_Alien = alien (malloc block) - * in the static region: E_Free = free - * in the string region: E_String = string - */ - } - -/* - * mmrefresh() - redraw screen, initially or after garbage collection. - */ - -void mmrefresh() - { - char *p; - word n; - - /* - * If the monitor is asking for E_EndCollect events, then it - * can handle these memory allocation "redraw" events. - */ - if (!is:null(curpstate->eventmask) && - Testb((word)E_EndCollect, curpstate->eventmask)) { - for (p = blkbase; p < blkfree; p += n) { - n = BlkSize(p); - EVVal(n, typech[(int)BlkType(p)]); /* block region */ - } - EVVal(DiffPtrs(strfree, strbase), E_String); /* string region */ - } - } - -#endif /* EventMon */ diff --git a/src/runtime/fscan.r b/src/runtime/fscan.r index 8cba731..9e974d8 100644 --- a/src/runtime/fscan.r +++ b/src/runtime/fscan.r @@ -34,7 +34,6 @@ function{0,1+} move(i) * Set new &pos. */ k_pos += i; - EVVal(k_pos, E_Spos); /* * Make sure i >= 0. @@ -56,7 +55,6 @@ function{0,1+} move(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; @@ -116,7 +114,6 @@ function{0,1+} tab(i) * Set new &pos. */ k_pos = i; - EVVal(k_pos, E_Spos); /* * Make i the length of the substring &subject[i:j] @@ -141,7 +138,6 @@ function{0,1+} tab(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; diff --git a/src/runtime/fstr.r b/src/runtime/fstr.r index 08d9f10..974aa56 100644 --- a/src/runtime/fstr.r +++ b/src/runtime/fstr.r @@ -214,10 +214,6 @@ function{1} detab(s,i[n]) return result; else { long n = DiffPtrs(StrLoc(result),strfree); /* note deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset the free pointer */ return s; /* return original string */ @@ -337,20 +333,12 @@ function{1} entab(s,i[n]) long n; StrLen(result) = DiffPtrs(out,StrLoc(result)); n = DiffPtrs(out,strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(out,strfree); strfree = out; /* give back unused space */ return result; /* return new string */ } else { long n = DiffPtrs(StrLoc(result),strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset free pointer */ return s; /* return original string */ @@ -445,12 +433,6 @@ function{1} map(s1,s2,s3) */ if !cnv:string(s1) then runerr(103,s1) -#if COMPILER - if !def:string(s2, ucase) then - runerr(103,s2) - if !def:string(s3, lcase) then - runerr(103,s3) -#endif /* COMPILER */ abstract { return string @@ -461,12 +443,11 @@ function{1} map(s1,s2,s3) register char *str1, *str2, *str3; static char maptab[256]; -#if !COMPILER if (is:null(s2)) s2 = ucase; if (is:null(s3)) s3 = lcase; -#endif /* !COMPILER */ + /* * If s2 and s3 are the same as for the last call of map, * the current values in maptab can be used. Otherwise, the @@ -475,13 +456,11 @@ function{1} map(s1,s2,s3) if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) { maps2 = s2; maps3 = s3; - -#if !COMPILER if (!cnv:string(s2,s2)) runerr(103,s2); if (!cnv:string(s3,s3)) runerr(103,s3); -#endif /* !COMPILER */ + /* * s2 and s3 must be of the same length */ diff --git a/src/runtime/fstruct.r b/src/runtime/fstruct.r index 469c3c5..3e5972a 100644 --- a/src/runtime/fstruct.r +++ b/src/runtime/fstruct.r @@ -34,8 +34,6 @@ function{1} delete(s,x) (BlkLoc(s)->set.size)--; } - EVValD(&s, E_Sdelete); - EVValD(&x, E_Sval); return s; } table: @@ -54,8 +52,6 @@ function{1} delete(s,x) (BlkLoc(s)->table.size)--; } - EVValD(&s, E_Tdelete); - EVValD(&x, E_Tsub); return s; } default: @@ -89,11 +85,7 @@ struct descrip *res; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listnext; hp->listhead = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#else /* ListFix */ bp->listprev = NULL; -#endif /* ListFix */ } /* @@ -131,7 +123,6 @@ function{0,1} get_or_pop(x) } body { - EVValD(&x, E_Lget); if (!c_get((struct b_list *)BlkLoc(x), &result)) fail; return result; } @@ -156,10 +147,8 @@ function{*} key(t) tended union block *ep; struct hgstate state; - EVValD(&t, E_Tkey); for (ep = hgfirst(BlkLoc(t), &state); ep != 0; ep = hgnext(BlkLoc(t), &state, ep)) { - EVValD(&ep->telem.tref, E_Tsub); suspend ep->telem.tref; } fail; @@ -215,8 +204,6 @@ function{1} insert(s, x, y) else deallocate((union block *)se); - EVValD(&s, E_Sinsert); - EVValD(&x, E_Sval); return s; } } @@ -264,8 +251,6 @@ function{1} insert(s, x, y) te->tval = y; } - EVValD(&s, E_Tinsert); - EVValD(&x, E_Tsub); return s; } } @@ -313,9 +298,6 @@ function{1} list(n, x) Protect(hp = alclist(size), runerr(0)); Protect(bp = alclstb(nslots, (word)0, size), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * Initialize each slot. @@ -323,8 +305,6 @@ function{1} list(n, x) for (i = 0; i < size; i++) bp->lslots[i] = x; - Desc_EVValD(hp, E_Lcreate, D_List); - /* * Return the new list. */ @@ -347,9 +327,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Smember); - EVValD(&x, E_Sval); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res==1) @@ -366,9 +343,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Tmember); - EVValD(&x, E_Tsub); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res == 1) @@ -400,8 +374,6 @@ function{0,1} pull(x) register struct b_list *hp; register struct b_lelem *bp; - EVValD(&x, E_Lpull); - /* * Point at list header block and fail if the list is empty. */ @@ -417,11 +389,7 @@ function{0,1} pull(x) if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listprev; hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listnext = (union block *) hp; -#else /* ListFix */ bp->listnext = NULL; -#endif /* ListFix */ } /* @@ -456,10 +424,6 @@ dptr val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -489,9 +453,6 @@ dptr val; } BlkLoc(*l)->list.listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = BlkLoc(*l); -#endif /* ListFix */ bp->listnext = BlkLoc(*l)->list.listhead; BlkLoc(*l)->list.listhead = (union block *) bp; } @@ -553,10 +514,6 @@ function{1} push(x, vals[n]) hp = (struct b_list *) BlkLoc(x); bp = (struct b_lelem *) hp->listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -586,9 +543,6 @@ function{1} push(x, vals[n]) } hp->listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#endif /* ListFix */ bp->listnext = hp->listhead; hp->listhead = (union block *) bp; } @@ -610,8 +564,6 @@ function{1} push(x, vals[n]) hp->size++; } - EVValD(&x, E_Lpush); - /* * Return the list. */ @@ -637,10 +589,6 @@ struct descrip *val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -672,9 +620,6 @@ struct descrip *val; ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext = (union block *) bp; bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail; -#ifdef ListFix - bp->listnext = BlkLoc(*l); -#endif /* ListFix */ ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp; } @@ -733,10 +678,6 @@ function{1} put(x, vals[n]) hp = (struct b_list *)BlkLoc(x); bp = (struct b_lelem *) hp->listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -766,9 +707,6 @@ function{1} put(x, vals[n]) hp->listtail->lelem.listnext = (union block *) bp; bp->listprev = hp->listtail; -#ifdef ListFix - bp->listnext = (union block *)hp; -#endif /* ListFix */ hp->listtail = (union block *) bp; } @@ -789,8 +727,6 @@ function{1} put(x, vals[n]) } - EVValD(&x, E_Lput); - /* * Return the list. */ @@ -815,7 +751,6 @@ function{1} set(l) ps = hmake(T_Set, (word)0, (word)0); if (ps == NULL) runerr(0); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -854,11 +789,7 @@ function{1} set(l) Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0)); for (pb = pb->list.listhead; -#ifdef ListFix - BlkType(pb) == T_Lelem; -#else /* ListFix */ pb != NULL; -#endif /* ListFix */ pb = pb->lelem.listnext) { for (i = 0; i < pb->lelem.nused; i++) { j = pb->lelem.first + i; @@ -876,7 +807,6 @@ function{1} set(l) } } deallocate((union block *)ne); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -900,7 +830,6 @@ function{1} table(x) if (bp == NULL) runerr(0); bp->table.defvalue = x; - Desc_EVValD(bp, E_Tcreate, D_Table); return table(bp); } end diff --git a/src/runtime/fsys.r b/src/runtime/fsys.r index 6b70b65..6889515 100644 --- a/src/runtime/fsys.r +++ b/src/runtime/fsys.r @@ -262,9 +262,6 @@ function{0,1} open(fname, spec) Protect(hp = alclist(0), runerr(0)); Protect(bp = alclstb(MinListSlots, (word)0, 0), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * loop through attributes, checking validity @@ -537,10 +534,6 @@ function{0,1} reads(f,i) * We may not have used the entire amount of storage we reserved. */ nbytes = DiffPtrs(StrLoc(s) + tally, strfree); - if (nbytes < 0) - EVVal(-nbytes, E_StrDeAlc); - else - EVVal(nbytes, E_String); strtotal += nbytes; strfree = StrLoc(s) + tally; return s; diff --git a/src/runtime/fwindow.r b/src/runtime/fwindow.r index 010286f..cc1b9c7 100644 --- a/src/runtime/fwindow.r +++ b/src/runtime/fwindow.r @@ -1624,29 +1624,18 @@ function{3} Pixel(argv[argc]) Protect((StrLoc(lastval) = alcstr(strout, slen)), runerr(0)); StrLen(lastval) = slen; } -#if COMPILER - suspend lastval; /* memory leak on vanquish */ -#else /* COMPILER */ /* * suspend, but free up imem if vanquished; RTL workaround * Needs implementing under the compiler. */ r_args[0] = lastval; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } else { -#if COMPILER - suspend C_integer rv; /* memory leak on vanquish */ -#else /* COMPILER */ int signal; /* * suspend, but free up imem if vanquished; RTL workaround @@ -1654,16 +1643,11 @@ function{3} Pixel(argv[argc]) */ r_args[0].dword = D_Integer; r_args[0].vword.integr = rv; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } } } diff --git a/src/runtime/imain.r b/src/runtime/imain.r index 424a4f6..7286666 100644 --- a/src/runtime/imain.r +++ b/src/runtime/imain.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imain.r * Interpreter main program, argument handling, and such. @@ -28,36 +27,6 @@ int iconx(int argc, char *argv[]) { static word istart[4]; static int mterm = Op_Quit; - #ifdef MultiThread - /* - * Look for MultiThread programming environment in which to execute - * this program, specified by MTENV environment variable. - */ - { - char *p; - char **new_argv; - int i, j = 1, k = 1; - if ((p = getenv("MTENV")) != NULL) { - for(i=0;p[i];i++) - if (p[i] == ' ') - j++; - new_argv = malloc((argc + j) * sizeof(char *)); - new_argv[0] = argv[0]; - for (i=0; p[i]; ) { - new_argv[k++] = p+i; - while (p[i] && (p[i] != ' ')) - i++; - if (p[i] == ' ') - p[i++] = '\0'; - } - for(i=1;i<argc;i++) - new_argv[k++] = argv[i]; - argc += j; - argv = new_argv; - } - } - #endif /* MultiThread */ - ipc.opnd = NULL; #ifdef LoadFunc @@ -69,7 +38,7 @@ int iconx(int argc, char *argv[]) { p = getenv("FPATH"); q = relfile(argv[0], "/.."); sprintf(buf, "FPATH=%s %s", (p ? p : "."), (q ? q : ".")); - putenv(buf); + putenv(salloc(buf)); } #endif /* LoadFunc */ @@ -191,54 +160,8 @@ int argc; char **argv; int *ip; { - - #ifdef TallyOpt - extern int tallyopt; - #endif /* TallyOpt */ - *ip = 0; /* number of arguments processed */ - #if MSWIN - /* - * if we didn't start with iconx.exe, backup one - * so that our icode filename is argv[1]. - */ - { - char tmp[256], *t2, *basename, *ext; - int len = 0; - strcpy(tmp, argv[0]); - for (t2 = tmp; *t2; t2++) { - switch (*t2) { - case ':': - case '/': - case '\\': - basename = t2 + 1; - ext = NULL; - break; - case '.': - ext = t2; - break; - default: - *t2 = tolower(*t2); - break; - } - } - /* If present, cut the ".exe" extension. */ - if (ext != NULL && !strcmp(ext, ".exe")) - *ext = 0; - - /* - * if argv[0] is not a reference to our interpreter, take it as the - * name of the icode file, and back up for it. - */ - if (strcmp(basename, "iconx")) { - argv--; - argc++; - (*ip)--; - } - } - #endif /* MSWIN */ - /* * Handle command line options. */ @@ -246,20 +169,12 @@ int *ip; switch ( *(argv[1]+1) ) { - #ifdef TallyOpt - /* - * Set tallying flag if -T option given - */ - case 'T': - tallyopt = 1; - break; - #endif /* TallyOpt */ - /* * Announce version on stderr if -V is given. */ case 'V': - fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + fprintf(stderr, "%s (%s %d/%d, %s)\n", + Version, Config, IntBits, WordBits, __DATE__); if (!argv[2]) exit(0); break; @@ -276,26 +191,13 @@ int *ip; * resolve - perform various fix-ups on the data read from the icode * file. */ -#ifdef MultiThread - void resolve(pstate) - struct progstate *pstate; -#else /* MultiThread */ - void resolve() -#endif /* MultiThread */ +void resolve() { register word i, j; register struct b_proc *pp; register dptr dp; extern int Omkrec(); - #ifdef MultiThread - register struct progstate *savedstate; - #endif /* MultiThread */ - - #ifdef MultiThread - savedstate = curpstate; - if (pstate) curpstate = pstate; - #endif /* MultiThread */ /* * Relocate the names of the global variables. @@ -372,13 +274,6 @@ int *ip; /* * Relocate the names of the fields. */ - for (dp = fnames; dp < efnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); - - #ifdef MultiThread - curpstate = savedstate; - #endif /* MultiThread */ } - -#endif /* !COMPILER */ diff --git a/src/runtime/imisc.r b/src/runtime/imisc.r index cde8a90..758a0ab 100644 --- a/src/runtime/imisc.r +++ b/src/runtime/imisc.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imisc.r * Contents: field, mkrec, limit, llist, bscan, escan @@ -14,18 +13,8 @@ LibDcl(field,2,".") register struct b_record *rp; register dptr dp; -#ifdef MultiThread - register union block *bptr; -#else /* MultiThread */ extern int *ftabp; - #ifdef FieldTableCompression - extern int *fo; - extern unsigned char *focp; - extern short *fosp; - extern char *bm; - #endif /* FieldTableCompression */ extern word *records; -#endif /* MultiThread */ Deref(Arg1); @@ -41,74 +30,14 @@ LibDcl(field,2,".") * Map the field number into a field number for the record x. */ rp = (struct b_record *) BlkLoc(Arg1); - -#ifdef MultiThread - bptr = rp->recdesc; - if (!InRange(curpstate->Records, bptr, curpstate->Ftabp)) { - int i; - int nfields = bptr->proc.nfields; - /* - * Look up the field number by a brute force search through - * the record constructor's field names. - */ - Arg0 = fnames[IntVal(Arg2)]; - fprintf(stderr,"looking up interprogram field %.*s\n", StrLen(Arg0), - StrLoc(Arg0)); - for (i=0;i<nfields;i++){ - if ((StrLen(Arg0) == StrLen(bptr->proc.lnames[i])) && - !strncmp(StrLoc(Arg0), StrLoc(bptr->proc.lnames[i]),StrLen(Arg0))) - break; - } - if (i<nfields) fnum = i; - else fnum = -1; - } - else -#endif /* MultiThread */ - -#ifdef FieldTableCompression -#define FO(i) ((foffwidth==1)?focp[i]:((foffwidth==2)?fosp[i]:fo[i])) -#define FTAB(i) ((ftabwidth==1)?ftabcp[i]:((ftabwidth==2)?ftabsp[i]:ftabp[i])) -#else /* FieldTableCompression */ -#define FO(i) fo[i] -#define FTAB(i) ftabp[i] -#endif /* FieldTableCompression */ - -#ifdef FieldTableCompression - fnum = FTAB(FO(IntVal(Arg2)) + (rp->recdesc->proc.recnum - 1)); -#else /* FieldTableCompression */ - fnum = FTAB(IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1); -#endif /* FieldTableCompression */ + fnum = ftabp[IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1]; /* * If fnum < 0, x doesn't contain the specified field. */ - -#ifdef FieldTableCompression -{ - int bytes, index; - unsigned char this_bit = 0200; - - bytes = *records >> 3; - if ((*records & 07) != 0) - bytes++; - index = IntVal(Arg2) * bytes + (rp->recdesc->proc.recnum - 1) / 8; - this_bit = this_bit >> (rp->recdesc->proc.recnum - 1) % 8; - if ((bm[index] | this_bit) != bm[index]) - RunErr(207, &Arg1); -} - - if (ftabwidth == 1) { - if (fnum == 255) - RunErr(207, &Arg1); - } - else -#endif /* FieldTableCompression */ if (fnum < 0) RunErr(207, &Arg1); - EVValD(&Arg1, E_Rref); - EVVal(fnum + 1, E_Rsub); - /* * Return a pointer to the descriptor for the appropriate field. */ @@ -156,7 +85,6 @@ LibDcl(mkrec,-1,"mkrec") ArgType(0) = D_Record; Arg0.vword.bptr = (union block *)rp; - EVValD(&Arg0, E_Rcreate); Return; } @@ -215,8 +143,6 @@ LibDcl(bscan,2,"?") if (!cnv:string(Arg0,Arg0)) RunErr(103, &Arg0); - EVValD(&Arg0, E_Snew); - /* * Establish a new &subject value and set &pos to 1. */ @@ -238,13 +164,6 @@ LibDcl(bscan,2,"?") rc = interp(G_Csusp,cargp); -#ifdef EventMon - if (rc != A_Resume) - EVValD(&Arg1, E_Srem); - else - EVValD(&Arg1, E_Sfail); -#endif /* EventMon */ - if (pfp != cur_pfp) return rc; @@ -326,8 +245,6 @@ LibDcl(escan,1,"escan") * Suspend with the value of the scanning expression. */ - EVValD(&k_subject, E_Ssusp); - rc = interp(G_Csusp,cargp); if (pfp != cur_pfp) return rc; @@ -340,11 +257,6 @@ LibDcl(escan,1,"escan") k_subject = *VarLoc(Arg1); *VarLoc(Arg1) = tmp; -#ifdef EventMon - if (rc == A_Resume) - EVValD(&k_subject, E_Sresum); -#endif /* EventMon */ - tmp = *(VarLoc(Arg1) + 1); IntVal(*(VarLoc(Arg1) + 1)) = k_pos; k_pos = IntVal(tmp); @@ -354,4 +266,3 @@ LibDcl(escan,1,"escan") return rc; } -#endif /* !COMPILER */ diff --git a/src/runtime/init.r b/src/runtime/init.r index 248bda8..d0bc00b 100644 --- a/src/runtime/init.r +++ b/src/runtime/init.r @@ -9,19 +9,18 @@ static void env_err (char *msg, char *name, char *val); FILE *pathOpen (char *fname, char *mode); -#if !COMPILER - #include "../h/header.h" - static FILE *readhdr(char *name, struct header *hdr); +#include "../h/header.h" +static FILE *readhdr(char *name, struct header *hdr); - #passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); - #passthru #include "../h/odefs.h" - #passthru #undef OpDef +#passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); +#passthru #include "../h/odefs.h" +#passthru #undef OpDef - /* - * External declarations for operator blocks. - */ +/* + * External declarations for operator blocks. + */ - #passthru #define OpDef(f,nargs,sname,underef)\ +#passthru #define OpDef(f,nargs,sname,underef)\ {\ T_Proc,\ Vsizeof(struct b_proc),\ @@ -31,11 +30,10 @@ FILE *pathOpen (char *fname, char *mode); underef,\ 0,\ {{sizeof(sname)-1,sname}}}, - #passthru static B_IProc(2) init_op_tbl[] = { - #passthru #include "../h/odefs.h" - #passthru }; - #undef OpDef -#endif /* !COMPILER */ +#passthru static B_IProc(2) init_op_tbl[] = { +#passthru #include "../h/odefs.h" +#passthru }; +#undef OpDef #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance); @@ -58,10 +56,7 @@ word mstksize = MStackSize; /* initial size of main stack */ word stksize = StackSize; /* co-expression stack size */ int k_level = 0; /* &level */ - -#ifndef MultiThread - struct descrip k_main; /* &main */ -#endif /* MultiThread */ +struct descrip k_main; /* &main */ int ixinited = 0; /* set-up switch */ @@ -74,10 +69,8 @@ word memcushion = RegionCushion; /* memory region cushion factor */ word memgrowth = RegionGrowth; /* memory region growth factor */ uword stattotal = 0; /* cumulative total static allocation */ -#ifndef MultiThread - uword strtotal = 0; /* cumulative total string allocation */ - uword blktotal = 0; /* cumulative total block allocation */ -#endif /* MultiThread */ +uword strtotal = 0; /* cumulative total string allocation */ +uword blktotal = 0; /* cumulative total block allocation */ int dodump; /* if nonzero, core dump on error */ int noerrbuf; /* if nonzero, do not buffer stderr */ @@ -85,16 +78,14 @@ int noerrbuf; /* if nonzero, do not buffer stderr */ struct descrip maps2; /* second cached argument of map */ struct descrip maps3; /* third cached argument of map */ -#ifndef MultiThread - struct descrip k_current; /* current expression stack pointer */ - int k_errornumber = 0; /* &errornumber */ - char *k_errortext = ""; /* &errortext */ - struct descrip k_errorvalue; /* &errorvalue */ - int have_errval = 0; /* &errorvalue has legal value */ - int t_errornumber = 0; /* tentative k_errornumber value */ - int t_have_val = 0; /* tentative have_errval flag */ - struct descrip t_errorvalue; /* tentative k_errorvalue value */ -#endif /* MultiThread */ +struct descrip k_current; /* current expression stack pointer */ +int k_errornumber = 0; /* &errornumber */ +char *k_errortext = ""; /* &errortext */ +struct descrip k_errorvalue; /* &errorvalue */ +int have_errval = 0; /* &errorvalue has legal value */ +int t_errornumber = 0; /* tentative k_errornumber value */ +int t_have_val = 0; /* tentative have_errval flag */ +struct descrip t_errorvalue; /* tentative k_errorvalue value */ struct b_coexpr *stklist; /* base of co-expression block list */ @@ -102,80 +93,38 @@ struct tend_desc *tend = NULL; /* chain of tended descriptors */ struct region rootstring, rootblock; -#ifndef MultiThread - dptr glbl_argp = NULL; /* argument pointer */ - dptr globals, eglobals; /* pointer to global variables */ - dptr gnames, egnames; /* pointer to global variable names */ - dptr estatics; /* pointer to end of static variables */ - struct region *curstring, *curblock; - #if !COMPILER - int n_globals = 0; /* number of globals */ - int n_statics = 0; /* number of statics */ - #endif /* !COMPILER */ -#endif /* MultiThread */ - -#if COMPILER - struct p_frame *pfp = NULL; /* procedure frame pointer */ - - int debug_info; /* flag: is debugging information available */ - int err_conv; /* flag: is error conversion supported */ - int largeints; /* flag: large integers are supported */ - - struct b_coexpr *mainhead; /* &main */ - -#else /* COMPILER */ - - int debug_info=1; /* flag: debugging information IS available */ - int err_conv=1; /* flag: error conversion IS supported */ - - int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); - struct pf_marker *pfp = NULL; /* Procedure frame pointer */ - - #ifdef MultiThread - struct progstate *curpstate; /* lastop accessed in program state */ - struct progstate rootpstate; - #else /* MultiThread */ - - struct b_coexpr *mainhead; /* &main */ - - char *code; /* interpreter code buffer */ - char *ecode; /* end of interpreter code buffer */ - word *records; /* pointer to record procedure blocks */ - - int *ftabp; /* pointer to record/field table */ - - #ifdef FieldTableCompression - word ftabwidth; /* field table entry width */ - word foffwidth; /* field offset entry width */ - unsigned char *ftabcp, *focp; /* pointers to record/field table */ - short *ftabsp, *fosp; /* pointers to record/field table */ - - int *fo; /* field offset (row in field table) */ - char *bm; /* bitmap array of valid field bits */ - #endif /* FieldTableCompression */ - - dptr fnames, efnames; /* pointer to field names */ - dptr statics; /* pointer to static variables */ - char *strcons; /* pointer to string constant table */ - struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ - struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ - #endif /* MultiThread */ - - #ifdef TallyOpt - word tallybin[16]; /* counters for tallying */ - int tallyopt = 0; /* want tally results output? */ - #endif /* TallyOpt */ - - word *stack; /* Interpreter stack */ - word *stackend; /* End of interpreter stack */ - -#endif /* COMPILER */ +dptr glbl_argp = NULL; /* argument pointer */ +dptr globals, eglobals; /* pointer to global variables */ +dptr gnames, egnames; /* pointer to global variable names */ +dptr estatics; /* pointer to end of static variables */ +struct region *curstring, *curblock; +int n_globals = 0; /* number of globals */ +int n_statics = 0; /* number of statics */ + +int debug_info=1; /* flag: debugging information IS available */ +int err_conv=1; /* flag: error conversion IS supported */ + +int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); +struct pf_marker *pfp = NULL; /* Procedure frame pointer */ + + struct b_coexpr *mainhead; /* &main */ + + char *code; /* interpreter code buffer */ + char *ecode; /* end of interpreter code buffer */ + word *records; /* pointer to record procedure blocks */ + int *ftabp; /* pointer to record/field table */ + dptr fnames, efnames; /* pointer to field names */ + dptr statics; /* pointer to static variables */ + char *strcons; /* pointer to string constant table */ + struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ + struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ + +word *stack; /* Interpreter stack */ +word *stackend; /* End of interpreter stack */ -#if !COMPILER - /* * Open the icode file and read the header. - * Used by icon_init() as well as MultiThread's loadicode() + * Used by icon_init(). */ static FILE *readhdr(name,hdr) char *name; @@ -249,35 +198,21 @@ struct header *hdr; return fname; } - -#endif /* !COMPILER */ /* * init/icon_init - initialize memory and prepare for Icon execution. */ -#if !COMPILER - struct header hdr; -#endif /* !COMPILER */ - -#if COMPILER - void init(name, argcp, argv, trc_init) - char *name; - int *argcp; - char *argv[]; - int trc_init; -#else /* COMPILER */ - void icon_init(name, argcp, argv) - char *name; - int *argcp; - char *argv[]; -#endif /* COMPILER */ +struct header hdr; +void icon_init(name, argcp, argv) +char *name; +int *argcp; +char *argv[]; { + char *itval; int delete_icode = 0; -#if !COMPILER FILE *fname = NULL; word cbread, longread(); -#endif /* COMPILER */ prog_name = name; /* Set icode file name */ @@ -303,80 +238,18 @@ struct header *hdr; * from icont to delete icode file xxxxx and to use yyyyy for &progname. * (This is used with Unix "#!" script files written in Icon.) */ - { - char *itval = getenv("ICODE_TEMP"); - int nlen = strlen(name); - if (itval != NULL && itval[nlen] == ':' && strncmp(name,itval,nlen)==0) { - delete_icode = 1; - prog_name = itval + nlen + 1; - } + itval = getenv("ICODE_TEMP"); + if (itval != NULL && strncmp(name, itval, strlen(name)) == 0) { + delete_icode = 1; + prog_name = strchr(itval, ':') + 1; + prog_name[-1] = '\0'; } -#if COMPILER curstring = &rootstring; curblock = &rootblock; rootstring.size = MaxStrSpace; rootblock.size = MaxAbrSize; -#else /* COMPILER */ - -#ifdef MultiThread - /* - * initialize root pstate - */ - curpstate = &rootpstate; - rootpstate.parentdesc = nulldesc; - rootpstate.eventmask= nulldesc; - rootpstate.opcodemask = nulldesc; - rootpstate.eventcode= nulldesc; - rootpstate.eventval = nulldesc; - rootpstate.eventsource = nulldesc; - rootpstate.Glbl_argp = NULL; - MakeInt(0, &(rootpstate.Kywd_err)); - MakeInt(1, &(rootpstate.Kywd_pos)); - StrLen(rootpstate.ksub) = 0; - StrLoc(rootpstate.ksub) = ""; - MakeInt(hdr.trace, &(rootpstate.Kywd_trc)); - StrLen(rootpstate.Kywd_prog) = strlen(prog_name); - StrLoc(rootpstate.Kywd_prog) = prog_name; - MakeInt(0, &(rootpstate.Kywd_ran)); - rootpstate.K_errornumber = 0; - rootpstate.T_errornumber = 0; - rootpstate.Have_errval = 0; - rootpstate.T_have_val = 0; - rootpstate.K_errortext = ""; - rootpstate.K_errorvalue = nulldesc; - rootpstate.T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0,&(rootpstate.AmperX)); - MakeInt(0,&(rootpstate.AmperY)); - MakeInt(0,&(rootpstate.AmperRow)); - MakeInt(0,&(rootpstate.AmperCol)); - MakeInt(0,&(rootpstate.AmperInterval)); - rootpstate.LastEventWin = nulldesc; - rootpstate.Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - rootpstate.Coexp_ser = 2; - rootpstate.List_ser = 1; - rootpstate.Set_ser = 1; - rootpstate.Table_ser = 1; - rootpstate.stringregion = &rootstring; - rootpstate.blockregion = &rootblock; - -#else /* MultiThread */ - - curstring = &rootstring; - curblock = &rootblock; -#endif /* MultiThread */ - - rootstring.size = MaxStrSpace; - rootblock.size = MaxAbrSize; -#endif /* COMPILER */ - -#if !COMPILER op_tbl = (struct b_proc*)init_op_tbl; -#endif /* !COMPILER */ #ifdef Double if (sizeof(struct size_dbl) != sizeof(double)) @@ -395,14 +268,10 @@ struct header *hdr; datainit(); - #if COMPILER - IntVal(kywd_trc) = trc_init; - #else /* COMPILER */ - fname = readhdr(name,&hdr); - if (fname == NULL) - error(name, "cannot open interpreter file"); - k_trace = hdr.trace; - #endif /* COMPILER */ + fname = readhdr(name,&hdr); + if (fname == NULL) + error(name, "cannot open interpreter file"); + k_trace = hdr.trace; /* * Examine the environment and make appropriate settings. [[I?]] @@ -418,41 +287,14 @@ struct header *hdr; /* * Allocate memory for various regions. */ -#if COMPILER - initalloc(); -#else /* COMPILER */ -#ifdef MultiThread - initalloc(hdr.hsize,&rootpstate); -#else /* MultiThread */ initalloc(hdr.hsize); -#endif /* MultiThread */ -#endif /* COMPILER */ -#if !COMPILER /* * Establish pointers to icode data regions. [[I?]] */ ecode = code + hdr.Records; records = (word *)ecode; ftabp = (int *)(code + hdr.Ftab); -#ifdef FieldTableCompression - fo = (int *)(code + hdr.Fo); - focp = (unsigned char *)(fo); - fosp = (short *)(fo); - if (hdr.FoffWidth == 1) { - bm = (char *)(focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - bm = (char *)(fosp + hdr.Nfields); - } - else - bm = (char *)(fo + hdr.Nfields); - - ftabwidth = hdr.FtabWidth; - foffwidth = hdr.FoffWidth; - ftabcp = (unsigned char *)(code + hdr.Ftab); - ftabsp = (short *)(code + hdr.Ftab); -#endif /* FieldTableCompression */ fnames = (dptr)(code + hdr.Fnames); globals = efnames = (dptr)(code + hdr.Globals); gnames = eglobals = (dptr)(code + hdr.Gnames); @@ -465,26 +307,14 @@ struct header *hdr; strcons = (char *)elines; n_globals = eglobals - globals; n_statics = estatics - statics; -#endif /* COMPILER */ /* * Allocate stack and initialize &main. */ - -#if COMPILER - mainhead = (struct b_coexpr *)malloc(sizeof(struct b_coexpr)); -#else /* COMPILER */ stack = (word *)malloc(mstksize); mainhead = (struct b_coexpr *)stack; - -#endif /* COMPILER */ - if (mainhead == NULL) -#if COMPILER - err_msg(305, NULL); -#else /* COMPILER */ fatalerr(303, NULL); -#endif /* COMPILER */ mainhead->title = T_Coexpr; mainhead->id = 1; @@ -493,18 +323,8 @@ struct header *hdr; mainhead->es_tend = NULL; mainhead->freshblk = nulldesc; /* &main has no refresh block. */ /* This really is a bug. */ -#ifdef MultiThread - mainhead->program = &rootpstate; -#endif /* MultiThread */ -#if COMPILER - mainhead->file_name = ""; - mainhead->line_num = 0; -#endif /* COMPILER */ - -#ifdef Coexpr Protect(mainhead->es_actstk = alcactiv(), fatalerr(0,NULL)); pushact(mainhead, mainhead); -#endif /* Coexpr */ /* * Point &main at the co-expression block for the main procedure and set @@ -514,7 +334,6 @@ struct header *hdr; BlkLoc(k_main) = (union block *) mainhead; k_current = k_main; -#if !COMPILER /* * Read the interpretable code and data into memory. */ @@ -526,37 +345,26 @@ struct header *hdr; } fclose(fname); if (delete_icode) /* delete icode file if flag set earlier */ - remove(name); + remove(itval); -/* - * Make sure the version number of the icode matches the interpreter version. - */ + /* + * Make sure the version number of the icode matches the interpreter version. + */ if (strcmp((char *)hdr.config,IVersion)) { fprintf(stderr,"icode version mismatch in %s\n", name); fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); fprintf(stderr,"\texpected version: %s\n",IVersion); error(name, "cannot run"); } -#endif /* !COMPILER */ /* * Initialize the event monitoring system, if configured. */ -#ifdef EventMon - EVInit(); -#endif /* EventMon */ - -#if !COMPILER /* * Resolve references from icode to run-time system. */ -#ifdef MultiThread - resolve(NULL); -#else /* MultiThread */ resolve(); -#endif /* MultiThread */ -#endif /* COMPILER */ /* * Allocate and assign a buffer to stderr if possible. @@ -723,17 +531,13 @@ char *s; { fprintf(stderr, "System error"); if (pfp == NULL) - fprintf(stderr, " in startup code"); + fprintf(stderr, " in startup code\n"); else { -#if COMPILER - if (line_info) - fprintf(stderr, " at line %d in %s", line_num, file_name); -#else /* COMPILER */ - fprintf(stderr, " at line %ld in %s", (long)findline(ipc.opnd), + fprintf(stderr, " at line %ld in %s\n", (long)findline(ipc.opnd), findfile(ipc.opnd)); -#endif /* COMPILER */ } - fprintf(stderr, "\n%s\n", s); + if (s != NULL) + fprintf(stderr, "%s\n", s); fflush(stderr); if (dodump) abort(); @@ -747,35 +551,6 @@ void c_exit(i) int i; { -#ifdef EventMon - if (curpstate != NULL) { - EVVal((word)i, E_Exit); - } -#endif /* EventMon */ - -#ifdef MultiThread - if (curpstate != NULL && curpstate->parent != NULL) { - /* might want to get to the lterm somehow, instead */ - while (1) { - struct descrip dummy; - co_chng(curpstate->parent->Mainhead, NULL, &dummy, A_Cofail, 1); - } - } -#endif /* MultiThread */ - -#ifdef TallyOpt - { - int j; - - if (tallyopt) { - fprintf(stderr,"tallies: "); - for (j=0; j<16; j++) - fprintf(stderr," %ld", (long)tallybin[j]); - fprintf(stderr,"\n"); - } - } -#endif /* TallyOpt */ - if (k_dump && ixinited) { fprintf(stderr,"\nTermination dump:\n\n"); fflush(stderr); @@ -832,12 +607,6 @@ void datainit() * some compilers). [[I?]] */ -#ifdef MultiThread - k_errout.title = T_File; - k_input.title = T_File; - k_output.title = T_File; -#endif /* MultiThread */ - k_errout.fd = stderr; StrLen(k_errout.fname) = 7; StrLoc(k_errout.fname) = "&errout"; @@ -888,214 +657,11 @@ void datainit() StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; IntVal(zerodesc) = 0; -#ifdef EventMon -/* - * Initialization needed for event monitoring - */ - - BlkLoc(csetdesc) = (union block *)&fullcs; - BlkLoc(rzerodesc) = (union block *)&realzero; - -#endif /* EventMon */ - maps2 = nulldesc; maps3 = nulldesc; - #if !COMPILER - qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); - #endif /* COMPILER */ - - } - -#ifdef MultiThread -/* - * loadicode - initialize memory particular to a given icode file - */ -struct b_coexpr * loadicode(name, theInput, theOutput, theError, bs, ss, stk) -char *name; -struct b_file *theInput, *theOutput, *theError; -C_integer bs, ss, stk; - { - struct b_coexpr *coexp; - struct progstate *pstate; - struct header hdr; - FILE *fname = NULL; - word cbread, longread(); - - /* - * open the icode file and read the header - */ - fname = readhdr(name,&hdr); - if (fname == NULL) - return NULL; - - /* - * Allocate memory for icode and the struct that describes it - */ - Protect(coexp = alccoexp(hdr.hsize, stk), - { fprintf(stderr,"can't malloc new icode region\n");c_exit(EXIT_FAILURE);}); - - pstate = coexp->program; - /* - * Initialize values. - */ - pstate->hsize = hdr.hsize; - pstate->parent= NULL; - pstate->parentdesc= nulldesc; - pstate->opcodemask= nulldesc; - pstate->eventmask= nulldesc; - pstate->eventcode= nulldesc; - pstate->eventval = nulldesc; - pstate->eventsource = nulldesc; - pstate->K_current.dword = D_Coexpr; - - MakeInt(0, &(pstate->Kywd_err)); - MakeInt(1, &(pstate->Kywd_pos)); - MakeInt(0, &(pstate->Kywd_ran)); - - StrLen(pstate->Kywd_prog) = strlen(prog_name); - StrLoc(pstate->Kywd_prog) = prog_name; - StrLen(pstate->ksub) = 0; - StrLoc(pstate->ksub) = ""; - MakeInt(hdr.trace, &(pstate->Kywd_trc)); - -#ifdef EventMon - pstate->Linenum = pstate->Column = pstate->Lastline = pstate->Lastcol = 0; -#endif /* EventMon */ - pstate->Lastop = 0; - /* - * might want to override from TRACE environment variable here. - */ - - /* - * Establish pointers to icode data regions. [[I?]] - */ - pstate->Mainhead= ((struct b_coexpr *)pstate)-1; - pstate->K_main.dword = D_Coexpr; - BlkLoc(pstate->K_main) = (union block *) pstate->Mainhead; - pstate->Code = (char *)(pstate + 1); - pstate->Ecode = (char *)(pstate->Code + hdr.Records); - pstate->Records = (word *)(pstate->Code + hdr.Records); - pstate->Ftabp = (int *)(pstate->Code + hdr.Ftab); -#ifdef FieldTableCompression - pstate->Fo = (int *)(pstate->Code + hdr.Fo); - pstate->Focp = (unsigned char *)(pstate->Fo); - pstate->Fosp = (short *)(pstate->Fo); - pstate->Foffwidth = hdr.FoffWidth; - if (hdr.FoffWidth == 1) { - pstate->Bm = (char *)(pstate->Focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - pstate->Bm = (char *)(pstate->Fosp + hdr.Nfields); - } - else - pstate->Bm = (char *)(pstate->Fo + hdr.Nfields); - pstate->Ftabwidth= hdr.FtabWidth; - pstate->Foffwidth = hdr.FoffWidth; - pstate->Ftabcp = (unsigned char *)(pstate->Code + hdr.Ftab); - pstate->Ftabsp = (short *)(pstate->Code + hdr.Ftab); -#endif /* FieldTableCompression */ - pstate->Fnames = (dptr)(pstate->Code + hdr.Fnames); - pstate->Globals = pstate->Efnames = (dptr)(pstate->Code + hdr.Globals); - pstate->Gnames = pstate->Eglobals = (dptr)(pstate->Code + hdr.Gnames); - pstate->NGlobals = pstate->Eglobals - pstate->Globals; - pstate->Statics = pstate->Egnames = (dptr)(pstate->Code + hdr.Statics); - pstate->Estatics = (dptr)(pstate->Code + hdr.Filenms); - pstate->NStatics = pstate->Estatics - pstate->Statics; - pstate->Filenms = (struct ipc_fname *)(pstate->Estatics); - pstate->Efilenms = (struct ipc_fname *)(pstate->Code + hdr.linenums); - pstate->Ilines = (struct ipc_line *)(pstate->Efilenms); - pstate->Elines = (struct ipc_line *)(pstate->Code + hdr.Strcons); - pstate->Strcons = (char *)(pstate->Elines); - pstate->K_errornumber = 0; - pstate->T_errornumber = 0; - pstate->Have_errval = 0; - pstate->T_have_val = 0; - pstate->K_errortext = ""; - pstate->K_errorvalue = nulldesc; - pstate->T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0, &(pstate->AmperX)); - MakeInt(0, &(pstate->AmperY)); - MakeInt(0, &(pstate->AmperRow)); - MakeInt(0, &(pstate->AmperCol)); - MakeInt(0, &(pstate->AmperInterval)); - pstate->LastEventWin = nulldesc; - pstate->Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - pstate->Coexp_ser = 2; - pstate->List_ser = 1; - pstate->Set_ser = 1; - pstate->Table_ser = 1; - - pstate->stringtotal = pstate->blocktotal = - pstate->colltot = pstate->collstat = - pstate->collstr = pstate->collblk = 0; - - pstate->stringregion = (struct region *)malloc(sizeof(struct region)); - pstate->blockregion = (struct region *)malloc(sizeof(struct region)); - pstate->stringregion->size = ss; - pstate->blockregion->size = bs; - - /* - * the local program region list starts out with this region only - */ - pstate->stringregion->prev = NULL; - pstate->blockregion->prev = NULL; - pstate->stringregion->next = NULL; - pstate->blockregion->next = NULL; - /* - * the global region list links this region with curpstate's - */ - pstate->stringregion->Gprev = curpstate->stringregion; - pstate->blockregion->Gprev = curpstate->blockregion; - pstate->stringregion->Gnext = curpstate->stringregion->Gnext; - pstate->blockregion->Gnext = curpstate->blockregion->Gnext; - if (curpstate->stringregion->Gnext) - curpstate->stringregion->Gnext->Gprev = pstate->stringregion; - curpstate->stringregion->Gnext = pstate->stringregion; - if (curpstate->blockregion->Gnext) - curpstate->blockregion->Gnext->Gprev = pstate->blockregion; - curpstate->blockregion->Gnext = pstate->blockregion; - initalloc(0, pstate); - - pstate->K_errout = *theError; - pstate->K_input = *theInput; - pstate->K_output = *theOutput; - - /* - * Read the interpretable code and data into memory. - */ - if ((cbread = longread(pstate->Code, sizeof(char), (long)hdr.hsize, fname)) - != hdr.hsize) { - fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", - (long)hdr.hsize,(long)cbread); - error(name, "can't read interpreter code"); - } - fclose(fname); - - /* - * Make sure the version number of the icode matches the interpreter version - */ - if (strcmp((char *)hdr.config,IVersion)) { - fprintf(stderr,"icode version mismatch in %s\n", name); - fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); - fprintf(stderr,"\texpected version: %s\n",IVersion); - error(name, "cannot run"); - } - - /* - * Resolve references from icode to run-time system. - * The first program has this done in icon_init after - * initializing the event monitoring system. - */ - resolve(pstate); - - return coexp; + qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); } -#endif /* MultiThread */ #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance) diff --git a/src/runtime/interp.r b/src/runtime/interp.r index c5fd713..6955b8f 100644 --- a/src/runtime/interp.r +++ b/src/runtime/interp.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: interp.r * The interpreter proper. @@ -8,20 +7,7 @@ extern fptr fncentry[]; - -/* - * Prototypes for static functions. - */ -#ifdef EventMon -static struct ef_marker *vanq_bound (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -static void vanq_proc (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -#endif /* EventMon */ - -#ifndef MultiThread word lastop; /* Last operator evaluated */ -#endif /* MultiThread */ /* * Istate variables. @@ -37,32 +23,17 @@ struct descrip eret_tmp; /* eret value during unwinding */ int coexp_act; /* last co-expression action */ -#ifndef MultiThread dptr xargp; word xnargs; -#endif /* MultiThread */ /* * Macros for use inside the main loop of the interpreter. */ -#ifdef EventMon -#define E_Misc -1 -#define E_Operator 0 -#define E_Function 1 -#endif /* EventMon */ - /* * Setup_Op sets things up for a call to the C function for an operator. - * InterpEVValD expands to nothing if EventMon is not defined. */ #begdef Setup_Op(nargs) -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&op_tbl[lastop - 1]; - InterpEVValD(&value_tmp, E_Ocall); -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -74,9 +45,6 @@ word xnargs; * operators. */ #begdef Setup_Arg(nargs) -#ifdef EventMon - lastev = E_Misc; -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -84,17 +52,10 @@ word xnargs; #begdef Call_Cond if ((*(optab[lastop]))(rargp) == A_Resume) { -#ifdef EventMon - InterpEVVal((word)-1, E_Ofail); -#endif /* EventMon */ goto efail_noev; } rsp = (word *) rargp + 1; -#ifdef EventMon - goto return_term; -#else /* EventMon */ break; -#endif /* EventMon */ #enddef /* Call_Cond */ /* @@ -169,20 +130,7 @@ dptr cargp; extern int (*optab[])(); extern int (*keytab[])(); struct b_proc *bproc; -#ifdef EventMon - int lastev = E_Misc; -#endif /* EventMon */ - -#ifdef TallyOpt - extern word tallybin[]; -#endif /* TallyOpt */ - -#ifdef EventMon - EVVal(fsig, E_Intcall); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -190,7 +138,6 @@ dptr cargp; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ #ifdef Polling if (!pollctr--) { @@ -203,18 +150,7 @@ dptr cargp; EntInterp; -#ifdef EventMon - switch (fsig) { - case G_Csusp: - case G_Fsusp: - case G_Osusp: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, - (fsig == G_Fsusp)?E_Fsusp:(fsig == G_Osusp?E_Osusp:E_Bsusp)); -#else /* EventMon */ if (fsig == G_Csusp) { -#endif /* EventMon */ oldsp = rsp; @@ -256,96 +192,7 @@ dptr cargp; */ for (;;) { - -#ifdef EventMon - - /* - * Location change events are generated by checking to see if the opcode - * has changed indices in the "line number" (now line + column) table; - * "straight line" forward code does not require a binary search to find - * the new location; instead, a pointer is simply incremented. - * Further optimization here is planned. - */ - if (!is:null(curpstate->eventmask) && ( - Testb((word)E_Loc, curpstate->eventmask) || - Testb((word)E_Line, curpstate->eventmask) - )) { - - if (InRange(code, ipc.opnd, ecode)) { - uword ipc_offset = DiffPtrs((char *)ipc.opnd, (char *)code); - uword size; - word temp_no; - if (!current_line_ptr || - current_line_ptr->ipc > ipc_offset || - current_line_ptr[1].ipc <= ipc_offset) { -#ifdef LineCodes -#ifdef Polling - if (!pollctr--) { - ExInterp; - pollctr = pollevent(); - EntInterp; - if (pollctr == -1) fatalerr(141, NULL); - } -#endif /* Polling */ -#endif /* LineCodes */ - - - if(current_line_ptr && - current_line_ptr + 2 < elines && - current_line_ptr[1].ipc < ipc_offset && - ipc_offset < current_line_ptr[2].ipc) { - current_line_ptr ++; - } - else { - current_line_ptr = ilines; - size = DiffPtrs((char *)elines, (char *)ilines) / - sizeof(struct ipc_line *); - while (size > 1) { - if (ipc_offset >= current_line_ptr[size>>1].ipc) { - current_line_ptr = ¤t_line_ptr[size>>1]; - size -= (size >> 1); - } - else { - size >>= 1; - } - } - } - linenum = current_line_ptr->line; - temp_no = linenum & 65535; - if ((lastline & 65535) != temp_no) { - if (Testb((word)E_Line, curpstate->eventmask)) - if (temp_no) - InterpEVVal(temp_no, E_Line); - } - if (lastline != linenum) { - lastline = linenum; - if (Testb((word)E_Loc, curpstate->eventmask) && - current_line_ptr->line >> 16) - InterpEVVal(current_line_ptr->line, E_Loc); - } - } - } - } -#endif /* EventMon */ - lastop = GetOp; /* Instruction fetch */ - -#ifdef EventMon - /* - * If we've asked for ALL opcode events, or specifically for this one - * generate an MT-style event. - */ - if ((!is:null(curpstate->eventmask) && - Testb((word)E_Opcode, curpstate->eventmask)) && - (is:null(curpstate->opcodemask) || - Testb((word)lastop, curpstate->opcodemask))) { - ExInterp; - MakeInt(lastop, &(curpstate->parent->eventval)); - actparent(E_Opcode); - EntInterp - } -#endif /* EventMon */ - switch ((int)lastop) { /* * Switch on opcode. The cases are * organized roughly by functionality @@ -564,23 +411,12 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ break; - case Op_Colm: /* source column number */ { -#ifdef EventMon - word loc; - column = GetWord; - loc = column; - loc <<= (WordBits >> 1); /* column in high-order part */ - loc += linenum; - InterpEVVal(loc, E_Loc); -#endif /* EventMon */ break; } @@ -595,15 +431,7 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ - -#ifdef EventMon - linenum = GetWord; - lastline = linenum; -#endif /* EventMon */ - break; /* ---String Scanning--- */ @@ -639,7 +467,6 @@ dptr cargp; bp = BlkLoc(value_tmp); args = (int)bp->list.size; -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. * This does nothing for invocation in a co-expression other @@ -649,14 +476,9 @@ dptr cargp; ((char *)sp + args * sizeof(struct descrip) > (char *)stackend)) fatalerr(301, NULL); -#endif /* MultiThread */ for (bp = bp->list.listhead; -#ifdef ListFix - BlkType(bp) == T_Lelem; -#else /* ListFix */ - bp != NULL; -#endif /* ListFix */ + bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; @@ -719,52 +541,20 @@ invokej: } #endif /* Polling */ -#ifdef EventMon - lastev = E_Function; - InterpEVValD(rargp, E_Fcall); -#endif /* EventMon */ - bproc = (struct b_proc *)BlkLoc(*rargp); -#ifdef FncTrace - typedef int (*bfunc2)(dptr, struct descrip *); -#endif /* FncTrace */ - - /* ExInterp not needed since no change since last EntInterp */ if (type == I_Vararg) { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*bfunc)(nargs, rargp, &(procs->pname)); -#else /* FncTrace */ signal = (*bfunc)(nargs,rargp); -#endif /* FncTrace */ - } else { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname)); -#else /* FncTrace */ signal = (*bfunc)(rargp); -#endif /* FncTrace */ - } - -#ifdef FncTrace - if (k_ftrace) { - k_ftrace--; - if (signal == A_Failure) - failtrace(&(bproc->pname)); - else - rtrace(&(bproc->pname),rargp); } -#endif /* FncTrace */ - goto C_rtn_term; } } @@ -781,19 +571,7 @@ invokej: case Op_Llist: /* construct list */ opnd = GetWord; - -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&mt_llist; - InterpEVValD(&value_tmp, E_Ocall); - rargp = (dptr)(rsp - 1) - opnd; - xargp = rargp; - ExInterp; -#else /* EventMon */ Setup_Arg(opnd); -#endif /* EventMon */ - { int i; for (i=1;i<=opnd;i++) @@ -840,13 +618,6 @@ mark0: break; case Op_Unmark: /* remove expression frame */ - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -858,12 +629,6 @@ Unmark_uw: --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Unmark_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Unmark_uw; } @@ -972,13 +737,6 @@ Unmark_uw: * limit not been reached). */ *lval = *(dptr)(rsp - 1); - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; /* @@ -989,12 +747,6 @@ Lsusp_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Lsusp_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Lsusp_uw; } rsp = (word *)efp - 1; @@ -1016,13 +768,6 @@ Lsusp_uw: struct descrip tmp; dptr svalp; struct b_proc *sproc; - -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Psusp); -#endif /* EventMon */ - svalp = (dptr)(rsp - 1); if (Var(*svalp)) { ExInterp; @@ -1082,11 +827,6 @@ Lsusp_uw: * a saved state, switch environments. */ if (pfp->pf_scan != NULL) { - -#ifdef EventMon - InterpEVValD(&k_subject, E_Ssusp); -#endif /* EventMon */ - tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; @@ -1096,14 +836,6 @@ Lsusp_uw: k_pos = IntVal(tmp); } -#ifdef MultiThread - /* - * If the program state changed for this procedure call, - * change back. - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - efp = pfp->pf_efp; ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; @@ -1132,12 +864,6 @@ Eret_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Eret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Eret_uw; } rsp = (word *)efp - 1; @@ -1148,11 +874,6 @@ Eret_uw: case Op_Pret: { /* return from procedure */ -#ifdef EventMon - struct descrip oldargp; - static struct descrip unwinder; -#endif /* EventMon */ - /* * An Icon procedure is returning a value. Determine if the * value being returned should be dereferenced and if so, @@ -1163,14 +884,6 @@ Eret_uw: */ struct b_proc *rproc; rproc = (struct b_proc *)BlkLoc(*glbl_argp); -#ifdef EventMon - oldargp = *glbl_argp; - ExInterp; - vanq_proc(efp, gfp); - EntInterp; - /* used to InterpEVValD(argp,E_Pret); here */ -#endif /* EventMon */ - *glbl_argp = *(dptr)(rsp - 1); if (Var(*glbl_argp)) { ExInterp; @@ -1187,20 +900,9 @@ Pret_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Pret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - unwinder = oldargp; -#endif /* EventMon */ - return A_Pret_uw; } -#ifdef EventMon - if (!is:proc(oldargp) && is:proc(unwinder)) - oldargp = unwinder; -#endif /* EventMon */ rsp = (word *)glbl_argp + 1; efp = pfp->pf_efp; gfp = pfp->pf_gfp; @@ -1208,15 +910,6 @@ Pret_uw: glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; -#ifdef MultiThread - if (pfp) - ENTERPSTATE(pfp->pf_prog); -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Pret); -#endif /* EventMon */ -#endif /* MultiThread */ break; } @@ -1224,9 +917,6 @@ Pret_uw: case Op_Efail: efail: -#ifdef EventMon - InterpEVVal((word)-1, E_Efail); -#endif /* EventMon */ efail_noev: /* * Failure has occurred in the current expression frame. @@ -1243,12 +933,6 @@ efail_noev: * structures that fail when complete. */ -#ifdef MultiThread - if (efp == 0) { - break; - } -#endif /* MultiThread */ - ipc = efp->ef_failure; gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -1298,58 +982,22 @@ efail_noev: tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); - -#ifdef EventMon - InterpEVValD(&k_subject, E_Sresum); -#endif /* EventMon */ } -#ifdef MultiThread - /* - * Enter the program state of the resumed frame - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - ++k_level; /* adjust procedure level */ } switch (type) { -#ifdef EventMon - case G_Fsusp: - InterpEVVal((word)0, E_Fresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; - - case G_Osusp: - InterpEVVal((word)0, E_Oresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; -#endif /* EventMon */ - case G_Csusp: - InterpEVVal((word)0, E_Eresum); --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Resume; case G_Esusp: - InterpEVVal((word)0, E_Eresum); goto efail_noev; case G_Psusp: /* resuming a procedure */ - InterpEVValD(glbl_argp, E_Presum); break; } @@ -1357,14 +1005,6 @@ efail_noev: } case Op_Pfail: { /* fail from procedure */ - -#ifdef EventMon - ExInterp; - vanq_proc(efp, gfp); - EVValD(glbl_argp, E_Pfail); - EntInterp; -#endif /* EventMon */ - /* * An Icon procedure is failing. Generate tracing message if * tracing is on. Deactivate inactive C generators created @@ -1382,10 +1022,6 @@ Pfail_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Pfail_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Pfail_uw; } efp = pfp->pf_efp; @@ -1393,17 +1029,6 @@ Pfail_uw: ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; - -#ifdef MultiThread - /* - * Enter the program state of the procedure being reentered. - * A NULL pfp indicates the program is complete. - */ - if (pfp) { - ENTERPSTATE(pfp->pf_prog); - } -#endif /* MultiThread */ - goto efail_noev; } /* ---Odds and Ends--- */ @@ -1478,12 +1103,6 @@ Pfail_uw: } goto mark0; -#ifdef TallyOpt - case Op_Tally: /* tally */ - tallybin[GetWord]++; - break; -#endif /* TallyOpt */ - case Op_Pnull: /* push null descriptor */ PushNull; break; @@ -1511,27 +1130,14 @@ Pfail_uw: /* ---Co-expressions--- */ case Op_Create: /* create */ - -#ifdef Coexpr PushNull; Setup_Arg(0); opnd = GetWord; opnd += (word)ipc.opnd; - signal = Ocreate((word *)opnd, rargp); - goto C_rtn_term; -#else /* Coexpr */ - err_msg(401, NULL); - goto efail; -#endif /* Coexpr */ case Op_Coact: { /* @e */ - -#ifndef Coexpr - err_msg(401, NULL); - goto efail; -#else /* Coexpr */ struct b_coexpr *ncp; dptr dp; @@ -1553,15 +1159,10 @@ Pfail_uw: goto efail_noev; else rsp -= 2; -#endif /* Coexpr */ break; } case Op_Coret: { /* return from co-expression */ - -#ifndef Coexpr - syserr("co-expression return, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1570,16 +1171,11 @@ Pfail_uw: ++BlkLoc(k_current)->coexpr.size; co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); EntInterp; -#endif /* Coexpr */ break; } case Op_Cofail: { /* fail from co-expression */ - -#ifndef Coexpr - syserr("co-expression failure, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1587,7 +1183,6 @@ Pfail_uw: co_chng(ncp, NULL, NULL, A_Cofail, 1); EntInterp; -#endif /* Coexpr */ break; } @@ -1600,8 +1195,8 @@ Pfail_uw: default: { char buf[50]; - sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", - (long)lastop, lastop); + sprintf(buf, "unimplemented opcode: %ld (0x%08lx)\n", + (long)lastop, (long)lastop); syserr(buf); } } @@ -1613,73 +1208,25 @@ C_rtn_term: switch (signal) { case A_Resume: -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)-1, - ((lastev == E_Function)? E_Ffail : E_Ofail)); - lastev = E_Misc; - } -#endif /* EventMon */ goto efail_noev; case A_Unmark_uw: /* unwind for unmark */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Unmark_uw; case A_Lsusp_uw: /* unwind for lsusp */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Lsusp_uw; case A_Eret_uw: /* unwind for eret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Eret_uw; case A_Pret_uw: /* unwind for pret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pret_uw; case A_Pfail_uw: /* unwind for pfail */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pfail_uw; } rsp = (word *)rargp + 1; /* set rsp to result */ - -#ifdef EventMon -return_term: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret)); - lastev = E_Misc; - } -#endif /* EventMon */ - continue; } @@ -1690,129 +1237,3 @@ interp_quit: /*NOTREACHED*/ return 0; /* avoid gcc warning */ } - -#ifdef EventMon -/* - * vanq_proc - monitor the removal of suspended operations from within - * a procedure. - */ -static void vanq_proc(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return; - - /* - * Go through all the bounded expression of the procedure. - */ - while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) { - gfp_v = efp_v->ef_gfp; - efp_v = efp_v->ef_efp; - } - } - -/* - * vanq_bound - monitor the removal of suspended operations from - * the current bounded expression and return the expression frame - * pointer for the bounded expression. - */ -static struct ef_marker *vanq_bound(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return efp_v; - - while (gfp_v != 0) { /* note removal of suspended operations */ - switch ((int)gfp_v->gf_gentype) { - case G_Psusp: - EVValD(gfp_v->gf_argp, E_Prem); - break; - /* G_Fsusp and G_Osusp handled in-line during unwinding */ - case G_Esusp: - EVVal((word)0, E_Erem); - break; - } - - if (((int)gfp_v->gf_gentype) == G_Psusp) { - vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp); - efp_v = gfp_v->gf_pfp->pf_efp; /* efp before the call */ - gfp_v = gfp_v->gf_pfp->pf_gfp; /* gfp before the call */ - } - else { - efp_v = gfp_v->gf_efp; - gfp_v = gfp_v->gf_gfp; - } - } - - return efp_v; - } -#endif /* EventMon */ - -#ifdef MultiThread -/* - * activate some other co-expression from an arbitrary point in - * the interpreter. - */ -int mt_activate(tvalp,rslt,ncp) -dptr tvalp, rslt; -register struct b_coexpr *ncp; -{ - register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current); - int first, rv; - - dptr savedtvalloc = NULL; - /* - * Set activator in new co-expression. - */ - if (ncp->es_actstk == NULL) { - Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); }); - /* - * If no one ever explicitly activates this co-expression, fail to - * the implicit activator. - */ - ncp->es_actstk->arec[0].activator = ccp; - first = 0; - } - else - first = 1; - - if(ccp->tvalloc) { - if (InRange(blkbase,ccp->tvalloc,blkfree)) { - fprintf(stderr, - "Multiprogram garbage collection disaster in mt_activate()!\n"); - fflush(stderr); - exit(1); - } - savedtvalloc = ccp->tvalloc; - } - - rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first); - - if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) { - fprintf(stderr,"averted co-expression disaster in activate\n"); - ccp->tvalloc = savedtvalloc; - } - - return rv; -} - - -/* - * activate the "&parent" co-expression from anywhere, if there is one - */ -void actparent(event) -int event; - { - struct progstate *parent = curpstate->parent; - - StrLen(parent->eventcode) = 1; - StrLoc(parent->eventcode) = (char *)&allchars[event & 0xFF]; - mt_activate(&(parent->eventcode), NULL, - (struct b_coexpr *)curpstate->parent->Mainhead); - } -#endif /* MultiThread */ -#endif /* !COMPILER */ diff --git a/src/runtime/invoke.r b/src/runtime/invoke.r index 87b9fd1..ab781af 100644 --- a/src/runtime/invoke.r +++ b/src/runtime/invoke.r @@ -1,148 +1,7 @@ /* - * invoke.r - contains invoke, apply + * invoke.r -- Perform setup for invocation. */ -#if COMPILER - -/* - * invoke - perform general invocation on a value. - */ -int invoke(nargs, args, rslt, succ_cont) -int nargs; -dptr args; -dptr rslt; -continuation succ_cont; - { - tended struct descrip callee; - struct b_proc *proc; - C_integer n; - - /* - * remove the operation being called from the argument list. - */ - deref(&args[0], &callee); - ++args; - nargs -= 1; - - if (is:proc(callee)) - return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt, - succ_cont); - else if (cnv:C_integer(callee, n)) { - if (n <= 0) - n += nargs + 1; - if (n <= 0 || n > nargs) - return A_Resume; - *rslt = args[n - 1]; - return A_Continue; - } - else if (cnv:string(callee, callee)) { - proc = strprc(&callee, (C_integer)nargs); - if (proc == NULL) - RunErr(106, &callee); - return (*(proc)->ccode)(nargs, args, rslt, succ_cont); - } - else - RunErr(106, &callee); - } - - -/* - * apply - implement binary bang. Construct an argument list for - * invoke() from the callee and the list it is applied to. - */ -int apply(callee, strct, rslt, succ_cont) -dptr callee; -dptr strct; -dptr rslt; -continuation succ_cont; - { - tended struct descrip dstrct; - struct tend_desc *tnd_args; /* place to tend arguments to invoke() */ - union block *ep; - int nargs; - word i, j; - word indx; - int signal; - - deref(strct, &dstrct); - - switch (Type(dstrct)) { - - case T_List: { - /* - * Copy the arguments from the list into an tended array of descriptors. - */ - nargs = BlkLoc(dstrct)->list.size + 1; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - for (ep = BlkLoc(dstrct)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ - ep != NULL; -#endif /* ListFix */ - ep = ep->lelem.listnext) { - for (i = 0; i < ep->lelem.nused; i++) { - j = ep->lelem.first + i; - if (j >= ep->lelem.nslots) - j -= ep->lelem.nslots; - tnd_args->d[indx++] = ep->lelem.lslots[j]; - } - } - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - case T_Record: { - /* - * Copy the arguments from the record into an tended array - * of descriptors. - */ - nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - ep = BlkLoc(dstrct); - for (i = 0; i < nargs; i++) - tnd_args->d[indx++] = ep->record.fields[i]; - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - default: { - RunErr(126, &dstrct); - } - } - } - -#else /* COMPILER */ - -#ifdef EventMon -#include "../h/opdefs.h" -#endif /* EventMon */ - - /* * invoke -- Perform setup for invocation. */ @@ -294,15 +153,12 @@ int nargs, *n; *cargp = newargp; sp = newsp; - EVVal((word)Op_Invoke,E_Ecall); - if ((nparam < 0) || (proc->ndynam == -2)) return I_Vararg; else return I_Builtin; } -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -310,7 +166,6 @@ int nargs, *n; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ /* * Build the procedure frame. @@ -326,10 +181,6 @@ int nargs, *n; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; -#ifdef MultiThread - newpfp->pf_prog = curpstate; -#endif /* MultiThread */ - glbl_argp = newargp; pfp = newpfp; newsp += Vwsizeof(*pfp); @@ -347,15 +198,6 @@ int nargs, *n; */ ipc.opnd = (word *)proc->entryp.icode; -#ifdef MultiThread - /* - * Enter the program state of the procedure being invoked. - */ - if (!InRange(code, ipc.opnd, ecode)) { - syserr("interprogram procedure calls temporarily prohibited\n"); - } -#endif /* MultiThread */ - efp = 0; gfp = 0; @@ -369,9 +211,5 @@ int nargs, *n; sp = newsp; k_level++; - EVValD(newargp, E_Pcall); - return I_Continue; } - -#endif /* COMPILER */ diff --git a/src/runtime/keyword.r b/src/runtime/keyword.r index e6eb462..9e92607 100644 --- a/src/runtime/keyword.r +++ b/src/runtime/keyword.r @@ -55,25 +55,15 @@ keyword{4} collections } end -#if !COMPILER "&column - source column number of current execution point" keyword{1} column abstract { return integer; } inline { -#ifdef MultiThread -#ifdef EventMon - return C_integer findcol(ipc.opnd); -#else /* EventMon */ fail; -#endif /* EventMon */ -#else - fail; -#endif /* MultiThread */ } end -#endif /* !COMPILER */ "¤t - the currently active co-expression" keyword{1} current @@ -259,11 +249,7 @@ keyword{1,*} features return string } body { -#if COMPILER -#define Feature(guard,sym,kwval) if ((guard) && (kwval)) suspend C_string kwval; -#else /* COMPILER */ #define Feature(guard,sym,kwval) if (kwval) suspend C_string kwval; -#endif /* COMPILER */ #include "../h/features.h" fail; } @@ -275,17 +261,10 @@ keyword{1} file return string } inline { -#if COMPILER - if (line_info) - return C_string file_name; - else - runerr(402); -#else /* COMPILER */ char *s; s = findfile(ipc.opnd); if (!strcmp(s,"?")) fail; return C_string s; -#endif /* COMPILER */ } end @@ -332,10 +311,6 @@ keyword{1} level } inline { -#if COMPILER - if (!debug_info) - runerr(402); -#endif /* COMPILER */ return C_integer k_level; } end @@ -346,14 +321,7 @@ keyword{1} line return integer; } inline { -#if COMPILER - if (line_info) - return C_integer line_num; - else - runerr(402); -#else /* COMPILER */ return C_integer findline(ipc.opnd); -#endif /* COMPILER */ } end @@ -460,11 +428,7 @@ keyword{1} source return coexpr } inline { -#ifndef Coexpr - return k_main; -#else /* Coexpr */ return coexpr(topact((struct b_coexpr *)BlkLoc(k_current))); -#endif /* Coexpr */ } end @@ -545,9 +509,7 @@ keyword{1} version constant Version end -#ifndef MultiThread struct descrip kywd_xwin[2] = {{D_Null}}; -#endif /* MultiThread */ "&window - variable containing the current graphics rendering context." #ifdef Graphics diff --git a/src/runtime/lmisc.r b/src/runtime/lmisc.r index 11f29de..52f0a6d 100644 --- a/src/runtime/lmisc.r +++ b/src/runtime/lmisc.r @@ -6,86 +6,48 @@ /* * create - return an entry block for a co-expression. */ -#if COMPILER -struct b_coexpr *create(fnc, cproc, ntemps, wrk_size) -continuation fnc; -struct b_proc *cproc; -int ntemps; -int wrk_size; -#else /* COMPILER */ int Ocreate(entryp, cargp) word *entryp; register dptr cargp; -#endif /* COMPILER */ { - -#ifdef Coexpr tended struct b_coexpr *sblkp; register struct b_refresh *rblkp; register dptr dp, ndp; int na, nl, i; - -#if !COMPILER struct b_proc *cproc; /* cproc is the Icon procedure that create occurs in */ cproc = (struct b_proc *)BlkLoc(glbl_argp[0]); -#endif /* COMPILER */ /* * Calculate number of arguments and number of local variables. */ -#if COMPILER - na = abs((int)cproc->nparam); -#else /* COMPILER */ na = pfp->pf_nargs + 1; /* includes Arg0 */ -#endif /* COMPILER */ nl = (int)cproc->ndynam; /* * Get a new co-expression stack and initialize. */ - -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), err_msg(0, NULL)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), err_msg(0, NULL)); -#endif /* MultiThread */ - - if (!sblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ /* * Get a refresh block for the new co-expression. */ -#if COMPILER - Protect(rblkp = alcrefresh(na, nl, ntemps, wrk_size), err_msg(0,NULL)); -#else /* COMPILER */ Protect(rblkp = alcrefresh(entryp, na, nl),err_msg(0,NULL)); -#endif /* COMPILER */ if (!rblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ sblkp->freshblk.dword = D_Refresh; BlkLoc(sblkp->freshblk) = (union block *) rblkp; -#if !COMPILER /* * Copy current procedure frame marker into refresh block. */ rblkp->pfmkr = *pfp; rblkp->pfmkr.pf_pfp = 0; -#endif /* COMPILER */ /* * Copy arguments into refresh block. @@ -98,11 +60,7 @@ register dptr cargp; /* * Copy locals into the refresh block. */ -#if COMPILER - dp = pfp->tend.d; -#else /* COMPILER */ dp = &(pfp->pf_locals)[0]; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *ndp++ = *dp++; @@ -111,33 +69,12 @@ register dptr cargp; */ co_init(sblkp); -#if COMPILER - sblkp->fnc = fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = cproc; - PFDebug(sblkp->pf)->old_fname = ""; - PFDebug(sblkp->pf)->old_line = 0; - } - - return sblkp; -#else /* COMPILER */ /* * Return the new co-expression. */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *) sblkp; Return; -#endif /* COMPILER */ -#else /* Coexpr */ - err_msg(401, NULL); -#if COMPILER - return NULL; -#else /* COMPILER */ - Fail; -#endif /* COMPILER */ -#endif /* Coexpr */ - } /* @@ -148,8 +85,6 @@ dptr val; struct b_coexpr *ncp; dptr result; { -#ifdef Coexpr - int first; /* @@ -169,8 +104,4 @@ dptr result; return A_Resume; else return A_Continue; - -#else /* Coexpr */ - RunErr(401,NULL); -#endif /* Coexpr */ } diff --git a/src/runtime/oarith.r b/src/runtime/oarith.r index b3ca88c..7d0978f 100644 --- a/src/runtime/oarith.r +++ b/src/runtime/oarith.r @@ -13,9 +13,7 @@ int over_flow = 0; operator{1} icon_op func_name(x, y) declare { -#ifdef LargeInts tended struct descrip lx, ly; -#endif /* LargeInts */ C_integer irslt; } arith_case (x, y) of { @@ -70,15 +68,11 @@ end irslt = div3(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigdiv(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; } @@ -112,15 +106,11 @@ ArithOp( / , divide , Divide , RealDivide) #begdef Sub(x,y) irslt = sub(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -196,15 +186,11 @@ ArithOp( % , mod , IntMod , RealMod) #begdef Mpy(x,y) irslt = mul(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -228,21 +214,15 @@ operator{1} - neg(x) i = neg(x); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(x,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,x); - errorfail; -#endif /* LargeInts */ } return C_integer i; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -253,7 +233,6 @@ operator{1} - neg(x) return result; } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -282,7 +261,6 @@ operator{1} + number(x) return C_integer x; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -291,7 +269,6 @@ operator{1} + number(x) return x; } } -#endif /* LargeInts */ else if cnv:C_double(x) then { abstract { return real @@ -319,15 +296,11 @@ end #begdef Add(x,y) irslt = add(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigadd(&lx, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -346,19 +319,11 @@ operator{1} ^ powr(x, y) return integer } inline { -#ifdef LargeInts tended struct descrip ly; MakeInt ( y, &ly ); if (bigpow(&x, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else - extern int over_flow; - C_integer r = iipow(IntVal(x), y); - if (over_flow) - runerr(203); - return C_integer r; -#endif } } else { @@ -374,7 +339,6 @@ operator{1} ^ powr(x, y) } } } -#ifdef LargeInts else if cnv:(exact)integer(y) then { if cnv:(exact)integer(x) then { abstract { @@ -399,7 +363,6 @@ operator{1} ^ powr(x, y) } } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -418,52 +381,6 @@ operator{1} ^ powr(x, y) } end -#if COMPILER || !(defined LargeInts) -/* - * iipow - raise an integer to an integral power. - */ -C_integer iipow(n1, n2) -C_integer n1, n2; - { - C_integer result; - - /* Handle some special cases first */ - over_flow = 0; - switch ( n1 ) { - case 1: - return 1; - case -1: - /* Result depends on whether n2 is even or odd */ - return ( n2 & 01 ) ? -1 : 1; - case 0: - if ( n2 <= 0 ) - over_flow = 1; - return 0; - default: - if (n2 < 0) - return 0; - } - - result = 1L; - for ( ; ; ) { - if (n2 & 01L) - { - result = mul(result, n1); - if (over_flow) - return 0; - } - - if ( ( n2 >>= 1 ) == 0 ) break; - n1 = mul(n1, n1); - if (over_flow) - return 0; - } - over_flow = 0; - return result; - } -#endif /* COMPILER || !(defined LargeInts) */ - - /* * ripow - raise a real number to an integral power. */ diff --git a/src/runtime/oasgn.r b/src/runtime/oasgn.r index b93d646..0b25c1d 100644 --- a/src/runtime/oasgn.r +++ b/src/runtime/oasgn.r @@ -14,15 +14,6 @@ */ #begdef GeneralAsgn(x, y) -#ifdef EventMon - body { - if (!is:null(curpstate->eventmask) && - Testb((word)E_Assign, curpstate->eventmask)) { - EVAsgn(&x); - } - } -#endif /* EventMon */ - type_case x of { tvsubs: { abstract { @@ -85,18 +76,10 @@ if (!cnv:C_integer(y, i)) runerr(101, y); - -#ifdef MultiThread - i = cvpos((long)i, StrLen(*(VarLoc(x)+1))); -#else /* MultiThread */ i = cvpos((long)i, StrLen(k_subject)); -#endif /* MultiThread */ - if (i == CvtFail) fail; IntVal(*VarLoc(x)) = i; - - EVVal(k_pos, E_Spos); } } kywdsubj: { @@ -107,12 +90,7 @@ if !cnv:string(y, *VarLoc(x)) then runerr(103, y); inline { -#ifdef MultiThread - IntVal(*(VarLoc(x)-1)) = 1; -#else /* MultiThread */ k_pos = 1; -#endif /* MultiThread */ - EVVal(k_pos, E_Spos); } } kywdstr: { @@ -132,12 +110,6 @@ } } -#ifdef EventMon - body { - EVValD(&y, E_Value); - } -#endif /* EventMon */ - #enddef @@ -460,8 +432,6 @@ const dptr src; } } tvsub->sslen = StrLen(srcstr); - - EVVal(tvsub->sslen, E_Ssasgn); return Succeeded; } diff --git a/src/runtime/ocat.r b/src/runtime/ocat.r index c778d6d..80f0e82 100644 --- a/src/runtime/ocat.r +++ b/src/runtime/ocat.r @@ -101,9 +101,6 @@ operator{1} ||| lconcat(x, y) Protect(bp1 = (struct b_list *)alclist(size3), runerr(0)); Protect(lp1 = (struct b_lelem *)alclstb(size3,(word)0,size3), runerr(0)); bp1->listhead = bp1->listtail = (union block *)lp1; -#ifdef ListFix - lp1->listprev = lp1->listnext = (union block *)bp1; -#endif /* ListFix */ /* * Make a copy of both lists in adjacent slots. @@ -112,9 +109,6 @@ operator{1} ||| lconcat(x, y) cpslots(&y, lp1->lslots + size1, (word)1, size2 + 1); BlkLoc(x) = (union block *)bp1; - - EVValD(&x, E_Lcreate); - return x; } end diff --git a/src/runtime/omisc.r b/src/runtime/omisc.r index 96a3e1b..4c11678 100644 --- a/src/runtime/omisc.r +++ b/src/runtime/omisc.r @@ -4,7 +4,6 @@ */ "^x - create a refreshed copy of a co-expression." -#ifdef Coexpr /* * ^x - return an entry block for co-expression x from the refresh block. */ @@ -21,12 +20,7 @@ operator{1} ^ refresh(x) /* * Get a new co-expression stack and initialize. */ -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), runerr(0)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), runerr(0)); -#endif /* MultiThread */ - sblkp->freshblk = BlkLoc(x)->coexpr.freshblk; if (ChkNull(sblkp->freshblk)) /* &main cannot be refreshed */ runerr(215, x); @@ -35,26 +29,8 @@ operator{1} ^ refresh(x) * Use refresh block to finish initializing the new co-expression. */ co_init(sblkp); - -#if COMPILER - sblkp->fnc = BlkLoc(x)->coexpr.fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc; - PFDebug(sblkp->pf)->old_fname = - PFDebug(BlkLoc(x)->coexpr.pf)->old_fname; - PFDebug(sblkp->pf)->old_line = - PFDebug(BlkLoc(x)->coexpr.pf)->old_line; - } -#endif /* COMPILER */ - return coexpr(sblkp); } -#else /* Coexpr */ -operator{} ^ refresh(x) - runerr(401) -#endif /* Coexpr */ - end @@ -151,9 +127,6 @@ operator{*} = tabmat(x) */ l = StrLen(x); k_pos += l; - - EVVal(k_pos, E_Spos); - suspend x; /* @@ -161,10 +134,8 @@ operator{*} = tabmat(x) */ if (i > StrLen(k_subject) + 1) runerr(205, kywd_pos); - else { + else k_pos = i; - EVVal(k_pos, E_Spos); - } fail; } end @@ -265,9 +236,6 @@ operator{1} [...] llist(elems[n]) * for the list. */ hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ /* * Assign each argument to a list element. @@ -275,9 +243,6 @@ operator{1} [...] llist(elems[n]) for (i = 0; i < n; i++) bp->lslots[i] = elems[i]; -/* Not quite right -- should be after list() returns in case it fails */ - Desc_EVValD(hp, E_Lcreate, D_List); - return list(hp); } end diff --git a/src/runtime/oref.r b/src/runtime/oref.r index 3ac86bc..8e1ffea 100644 --- a/src/runtime/oref.r +++ b/src/runtime/oref.r @@ -38,35 +38,18 @@ operator{*} ! bang(underef x -> dx) return type(dx).lst_elem } inline { - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Lbang); -#endif /* EventMon */ - /* * x is a list. Chain through each list element block and for * each one, suspend with a variable pointing to each * element contained in the block. */ for (ep = BlkLoc(dx)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ ep != NULL; -#endif /* ListFix */ ep = ep->lelem.listnext){ for (i = 0; i < ep->lelem.nused; i++) { j = ep->lelem.first + i; if (j >= ep->lelem.nslots) j -= ep->lelem.nslots; - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - suspend struct_var(&ep->lelem.lslots[j], ep); } } @@ -158,17 +141,12 @@ operator{*} ! bang(underef x -> dx) inline { struct b_tvtbl *tp; - EVValD(&dx, E_Tbang); - /* * x is a table. Chain down the element list in each bucket * and suspend a variable pointing to each element in turn. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - - EVValD(&ep->telem.tval, E_Tval); - Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); suspend tvtbl(tp); } @@ -180,14 +158,12 @@ operator{*} ! bang(underef x -> dx) return store[type(dx).set_elem] } inline { - EVValD(&dx, E_Sbang); /* * This is similar to the method for tables except that a * value is returned instead of a variable. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - EVValD(&ep->selem.setmem, E_Sval); suspend ep->selem.setmem; } } @@ -202,21 +178,8 @@ operator{*} ! bang(underef x -> dx) * x is a record. Loop through the fields and suspend * a variable pointing to each one. */ - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Rbang); -#endif /* EventMon */ - j = BlkLoc(dx)->record.recdesc->proc.nfields; for (i = 0; i < j; i++) { - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - suspend struct_var(&BlkLoc(dx)->record.fields[i], (struct b_record *)BlkLoc(dx)); } @@ -256,12 +219,6 @@ end operator{0,1} ? random(underef x -> dx) -#ifndef LargeInts - declare { - C_integer v = 0; - } -#endif /* LargeInts */ - if is:variable(x) && is:string(dx) then { abstract { return new tvsubs(type(x)) @@ -347,13 +304,6 @@ operator{0,1} ? random(underef x -> dx) rval = RandVal; rval *= val; i = (word)rval + 1; - -#ifdef EventMon - EVValD(&dx, E_Lrand); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - j = 1; /* * Work down chain list of list blocks and find the block that @@ -363,11 +313,7 @@ operator{0,1} ? random(underef x -> dx) while (i >= j + bp->lelem.nused) { j += bp->lelem.nused; bp = bp->lelem.listnext; -#ifdef ListFix - if (BlkType(bp) == T_List) -#else /* ListFix */ if (bp == NULL) -#endif /* ListFix */ syserr("list reference out of bounds in random"); } /* @@ -405,13 +351,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Trand); - MakeInt(n, &eventdesc); - EVValD(&eventdesc, E_Tsub); -#endif /* EventMon */ - - /* * Walk down the hash chains to find and return the nth element * as a variable. @@ -419,11 +358,7 @@ operator{0,1} ? random(underef x -> dx) for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) if (--n <= 0) { Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); @@ -456,11 +391,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Srand); - MakeInt(n, &eventdesc); -#endif /* EventMon */ - /* * Walk down the hash chains to find and return the nth element. */ @@ -497,43 +427,27 @@ operator{0,1} ? random(underef x -> dx) */ rval = RandVal; rval *= val; - -#ifdef EventMon - EVValD(&dx, E_Rrand); - MakeInt(rval + 1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - return struct_var(&rec->fields[(word)rval], rec); } } default: { -#ifdef LargeInts if !cnv:integer(dx) then runerr(113, dx) -#else /* LargeInts */ - if !cnv:C_integer(dx,v) then - runerr(113, dx) -#endif /* LargeInts */ - abstract { return integer ++ real } body { double rval; - -#ifdef LargeInts C_integer v; if (Type(dx) == T_Lrgint) { if (bigrand(&dx, &result) == Error) /* alcbignum failed */ runerr(0); return result; } - v = IntVal(dx); -#endif /* LargeInts */ + /* * x is an integer, be sure that it's non-negative. */ @@ -690,12 +604,6 @@ operator{0,1} [] subsc(underef x -> dx,y) register union block *bp; /* doesn't need to be tended */ struct b_list *lp; /* doesn't need to be tended */ -#ifdef EventMon - EVValD(&dx, E_Lref); - MakeInt(y, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - /* * Make sure that subscript y is in range. */ @@ -742,9 +650,6 @@ operator{0,1} [] subsc(underef x -> dx,y) uword hn; struct b_tvtbl *tp; - EVValD(&dx, E_Tref); - EVValD(&y, E_Tsub); - hn = hash(&y); Protect(tp = alctvtbl(&dx, &y, hn), runerr(0)); return tvtbl(tp); @@ -777,13 +682,6 @@ operator{0,1} [] subsc(underef x -> dx,y) for(i=0; i<nf; i++) { if (len == StrLen(bp2->proc.lnames[i]) && !strncmp(loc, StrLoc(bp2->proc.lnames[i]), len)) { - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i+1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Found the field, return a pointer to it. */ @@ -802,13 +700,6 @@ operator{0,1} [] subsc(underef x -> dx,y) i = cvpos(y, (word)(bp->record.recdesc->proc.nfields)); if (i == CvtFail || i > bp->record.recdesc->proc.nfields) fail; - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Locate the appropriate field and return a pointer to it. */ diff --git a/src/runtime/oset.r b/src/runtime/oset.r index 7808e80..dc8e126 100644 --- a/src/runtime/oset.r +++ b/src/runtime/oset.r @@ -84,7 +84,6 @@ operator{1} -- diff(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } @@ -175,7 +174,6 @@ operator{1} ** inter(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } diff --git a/src/runtime/ralc.r b/src/runtime/ralc.r index 9f55671..403515b 100644 --- a/src/runtime/ralc.r +++ b/src/runtime/ralc.r @@ -11,12 +11,11 @@ static struct region *newregion (word nbytes, word stdsize); extern word alcnum; -#ifndef MultiThread word coexp_ser = 2; /* serial numbers for co-expressions; &main is 1 */ +word extl_ser = 1; /* serial numbers for externals */ word list_ser = 1; /* serial numbers for lists */ word set_ser = 1; /* serial numbers for sets */ word table_ser = 1; /* serial numbers for tables */ -#endif /* MultiThread */ /* @@ -24,10 +23,6 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcBlk(var, struct_nm, t_code, nbytes) { -#ifdef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif /* MultiThread */ - /* * Ensure that there is enough room in the block region. */ @@ -35,13 +30,6 @@ word table_ser = 1; /* serial numbers for tables */ return NULL; /* - * If monitoring, show the allocation. - */ -#ifndef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif - - /* * Decrement the free space in the block region by the number of bytes * allocated and return the address of the first byte of the allocated * block. @@ -64,11 +52,7 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcVarBlk(var, struct_nm, t_code, n_desc) { -#ifdef EventMon - uword size; -#else /* EventMon */ register uword size; -#endif /* EventMon */ /* * Variable size blocks are declared with one descriptor, thus @@ -105,7 +89,6 @@ struct astkblk *alcactiv() return abp; } -#ifdef LargeInts /* * alcbignum - allocate an n-digit bignum in the block region */ @@ -125,17 +108,18 @@ word n; blk->lsd = n - 1; return blk; } -#endif /* LargeInts */ /* * alccoexp - allocate a co-expression stack block. + * + * Although pthreads allocates a C stack, we still need this an + * interpreter stack beyond the end of the coexpr block. */ -#if COMPILER struct b_coexpr *alccoexp() { struct b_coexpr *ep; - static int serial = 2; /* main co-expression is allocated elsewhere */ + ep = (struct b_coexpr *)malloc(stksize); /* @@ -146,112 +130,24 @@ struct b_coexpr *alccoexp() if (ep == NULL || alcnum > AlcMax) { collect(Static); ep = (struct b_coexpr *)malloc(stksize); - } - + } if (ep == NULL) ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ - - ep->title = T_Coexpr; - ep->size = 0; - ep->id = serial++; - ep->nextstk = stklist; - ep->es_tend = NULL; - ep->file_name = ""; - ep->line_num = 0; - ep->freshblk = nulldesc; - ep->es_actstk = NULL; - ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ - ep->cstate[1] = 0; - stklist = ep; - return ep; - } -#else /* COMPILER */ -#ifdef MultiThread -/* - * If this is a new program being loaded, an icodesize>0 gives the - * hdr.hsize and a stacksize to use; allocate - * sizeof(progstate) + icodesize + mstksize - * Otherwise (icodesize==0), allocate a normal stksize... - */ -struct b_coexpr *alccoexp(icodesize, stacksize) -long icodesize, stacksize; -#else /* MultiThread */ -struct b_coexpr *alccoexp() -#endif /* MultiThread */ - - { - struct b_coexpr *ep; - -#ifdef MultiThread - if (icodesize > 0) { - ep = (struct b_coexpr *) - calloc(1, stacksize+ - icodesize+ - sizeof(struct progstate)+ - sizeof(struct b_coexpr)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - - /* - * If malloc failed or if there have been too many co-expression allocations - * since a collection, attempt to free some co-expression blocks and retry. - */ - - if (ep == NULL || alcnum > AlcMax) { - - collect(Static); - -#ifdef MultiThread - if (icodesize>0) { - ep = (struct b_coexpr *) - malloc(mstksize+icodesize+sizeof(struct progstate)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - } - if (ep == NULL) - ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ ep->title = T_Coexpr; ep->es_actstk = NULL; ep->size = 0; -#ifdef MultiThread - ep->es_pfp = NULL; - ep->es_gfp = NULL; - ep->es_argp = NULL; - ep->tvalloc = NULL; - - if (icodesize > 0) - ep->id = 1; - else -#endif /* MultiThread */ ep->id = coexp_ser++; ep->nextstk = stklist; ep->es_tend = NULL; ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ ep->cstate[1] = 0; -#ifdef MultiThread - /* - * Initialize program state to self for &main; curpstate for others. - */ - if(icodesize>0) ep->program = (struct progstate *)(ep+1); - else ep->program = curpstate; -#endif /* MultiThread */ - stklist = ep; return ep; } -#endif /* COMPILER */ /* * alccset - allocate a cset in the block region. @@ -274,6 +170,46 @@ struct b_cset *alccset() } /* + * alcexternal - allocate an external data block in the block region. + * + * nbytes is total struct size including header, or zero to use default + * f is dispatch table of user C functions; also differentiates external types + * data is copied in to initialize the data block. + * Any of these can be zero/null for default behavior. + * + * May cause a garbage collection. Returns null if still unsuccessful. + */ + +struct b_external *alcexternal(long nbytes, struct b_extlfuns *f, void *data) + { + register struct b_external *blk; + long datasize; + static struct b_extlfuns fdefault; /* default dispatch table, all empty */ + + if (nbytes == 0) + nbytes = sizeof(struct b_external); + + /* datasize = nbytes - offsetof(struct b_external, data); */ + datasize = nbytes - ((char*)blk->data - (char*)blk); + if (datasize < 0) + syserr("alcexternal: invalid size"); + + /* now, after calculating datasize, round up nbytes to a word multiple */ + nbytes = (nbytes + sizeof(word) - 1) & ~(sizeof(word) - 1); + + if (f == NULL) + f = &fdefault; + + AlcBlk(blk, b_external, T_External, nbytes); + blk->blksize = nbytes; + blk->id = extl_ser++; + blk->funcs = f; + if (data != NULL) + memcpy(blk->data, data, datasize); + return blk; + } + +/* * alcfile - allocate a file block in the block region. */ @@ -429,23 +365,6 @@ union block *recptr; * alcrefresh - allocate a co-expression refresh block. */ -#if COMPILER -struct b_refresh *alcrefresh(na, nl, nt, wrk_sz) -int na; -int nl; -int nt; -int wrk_sz; - { - struct b_refresh *blk; - - AlcVarBlk(blk, b_refresh, T_Refresh, na + nl) - blk->nlocals = nl; - blk->nargs = na; - blk->ntemps = nt; - blk->wrk_size = wrk_sz; - return blk; - } -#else /* COMPILER */ struct b_refresh *alcrefresh(entryx, na, nl) word *entryx; int na, nl; @@ -457,7 +376,6 @@ int na, nl; blk->numlocals = nl; return blk; } -#endif /* COMPILER */ /* * alcselem - allocate a set element block. @@ -490,16 +408,6 @@ register word slen; register char *d; char *ofree; -#ifdef MultiThread - StrLen(ts) = slen; - StrLoc(ts) = s; -#ifdef EventMon - if (!noMTevents) -#endif /* EventMon */ - EVVal(slen, E_String); - s = StrLoc(ts); -#endif /* MultiThread */ - /* * Make sure there is enough room in the string space. */ @@ -606,7 +514,6 @@ union block *bp; syserr ("deallocation botch"); rp->free = (char *)bp; blktotal -= nbytes; - EVVal(nbytes, E_BlkDeAlc); } /* @@ -691,16 +598,6 @@ word nbytes; if (curr->Gprev) curr->Gprev->Gnext = rp; curr->Gprev = rp; *pcurr = rp; -#ifdef EventMon - if (!noMTevents) { - if (region == Strings) { - EVVal(rp->size, E_TenureString); - } - else { - EVVal(rp->size, E_TenureBlock); - } - } -#endif /* EventMon */ return rp->free; } diff --git a/src/runtime/rcoexpr.r b/src/runtime/rcoexpr.r index 4036ef6..a613873 100644 --- a/src/runtime/rcoexpr.r +++ b/src/runtime/rcoexpr.r @@ -2,10 +2,6 @@ * File: rcoexpr.r -- co_init, co_chng */ -#if COMPILER -static continuation coexpr_fnc; /* function to call after switching stacks */ -#endif /* COMPILER */ - /* * co_init - use the contents of the refresh block to initialize the * co-expression. @@ -13,9 +9,6 @@ static continuation coexpr_fnc; /* function to call after switching stacks */ void co_init(sblkp) struct b_coexpr *sblkp; { -#ifndef Coexpr - syserr("co_init() called, but co-expressions not implemented"); -#else /* Coexpr */ register word *newsp; register struct b_refresh *rblkp; register dptr dp, dsp; @@ -27,60 +20,16 @@ struct b_coexpr *sblkp; * Get pointer to refresh block. */ rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk); - -#if COMPILER - na = rblkp->nargs; /* number of arguments */ - nl = rblkp->nlocals; /* number of locals */ - nt = rblkp->ntemps; /* number of temporaries */ - - /* - * The C stack must be aligned on the correct boundary. For up-growing - * stacks, the C stack starts after the initial procedure frame of - * the co-expression block. For down-growing stacks, the C stack starts - * at the last word of the co-expression block. - */ -#ifdef UpStack - frame_size = sizeof(struct p_frame) + sizeof(struct descrip) * (nl + na + - nt - 1) + rblkp->wrk_size; - stack_strt = (word)((char *)&sblkp->pf + frame_size + StackAlign*WordSize); -#else /* UpStack */ - stack_strt = (word)((char *)sblkp + stksize - WordSize); -#endif /* UpStack */ - sblkp->cstate[0] = stack_strt & ~(WordSize * StackAlign - 1); - - sblkp->es_argp = &sblkp->pf.tend.d[nl + nt]; /* args follow temporaries */ - -#else /* COMPILER */ - na = (rblkp->pfmkr).pf_nargs + 1; /* number of arguments */ nl = (int)rblkp->numlocals; /* number of locals */ /* * The interpreter stack starts at word after co-expression stack block. - * C stack starts at end of stack region on machines with down-growing C - * stacks and somewhere in the middle of the region. - * - * The C stack is aligned on a doubleword boundary. For up-growing - * stacks, the C stack starts in the middle of the stack portion - * of the static block. For down-growing stacks, the C stack starts - * at the last word of the static block. + * There is no longer C state in this region; pthreads makes another stack. */ newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr)); - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + stksize - WordSize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ - -#endif /* COMPILER */ + sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ /* * Copy arguments onto new stack. @@ -93,16 +42,6 @@ struct b_coexpr *sblkp; /* * Set up state variables and initialize procedure frame. */ -#if COMPILER - sblkp->es_pfp = &sblkp->pf; - sblkp->es_tend = &sblkp->pf.tend; - sblkp->pf.old_pfp = NULL; - sblkp->pf.rslt = NULL; - sblkp->pf.succ_cont = NULL; - sblkp->pf.tend.previous = NULL; - sblkp->pf.tend.num = nl + na + nt; - sblkp->es_actstk = NULL; -#else /* COMPILER */ *((struct pf_marker *)dsp) = rblkp->pfmkr; sblkp->es_pfp = (struct pf_marker *)dsp; sblkp->es_tend = NULL; @@ -111,25 +50,14 @@ struct b_coexpr *sblkp; sblkp->es_gfp = 0; sblkp->es_efp = 0; sblkp->es_ilevel = 0; -#endif /* COMPILER */ sblkp->tvalloc = NULL; /* * Copy locals into the co-expression. */ -#if COMPILER - dsp = sblkp->pf.tend.d; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *dsp++ = *dp++; -#if COMPILER - /* - * Initialize temporary variables. - */ - for (i = 1; i <= nt; i++) - *dsp++ = nulldesc; -#else /* COMPILER */ /* * Push two null descriptors on the stack. */ @@ -137,9 +65,6 @@ struct b_coexpr *sblkp; *dsp++ = nulldesc; sblkp->es_sp = (word *)dsp - 1; -#endif /* COMPILER */ - -#endif /* Coexpr */ } /* @@ -152,60 +77,22 @@ struct descrip *rsltloc;/* location to put result */ int swtch_typ; /* A_Coact, A_Coret, A_Cofail, or A_MTEvent */ int first; { -#ifndef Coexpr - syserr("co_chng() called, but co-expressions not implemented"); -#else /* Coexpr */ register struct b_coexpr *ccp; static int coexp_act; /* used to pass signal across activations */ /* back to whomever activates, if they care */ ccp = (struct b_coexpr *)BlkLoc(k_current); -#if !COMPILER -#ifdef EventMon - switch(swtch_typ) { - /* - * A_MTEvent does not generate an event. - */ - case A_MTEvent: - break; - case A_Coact: - EVValX(ncp,E_Coact); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Coret: - EVValX(ncp,E_Coret); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Cofail: - EVValX(ncp,E_Cofail); - if (!is:null(curpstate->eventmask) && ncp->program == curpstate) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - } -#endif /* EventMon */ -#endif /* COMPILER */ - /* * Determine if we need to transmit a value. */ if (valloc != NULL) { -#if !COMPILER /* * Determine if we need to dereference the transmitted value. */ if (Var(*valloc)) retderef(valloc, (word *)glbl_argp, sp); -#endif /* COMPILER */ if (ncp->tvalloc != NULL) *ncp->tvalloc = *valloc; @@ -220,31 +107,14 @@ int first; ccp->es_argp = glbl_argp; ccp->es_tend = tend; -#if !COMPILER ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; -#endif /* COMPILER */ - -#if COMPILER - if (line_info) { - ccp->file_name = file_name; - ccp->line_num = line_num; - file_name = ncp->file_name; - line_num = ncp->line_num; - } -#endif /* COMPILER */ -#if COMPILER - if (debug_info) -#endif /* COMPILER */ - if (k_trace) -#ifdef EventMon - if (swtch_typ != A_MTEvent) -#endif /* EventMon */ - cotrace(ccp, ncp, swtch_typ, valloc); + if (k_trace) + cotrace(ccp, ncp, swtch_typ, valloc); /* * Establish state for new co-expression. @@ -252,45 +122,20 @@ int first; pfp = ncp->es_pfp; tend = ncp->es_tend; -#if !COMPILER efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; -#endif /* COMPILER */ - -#if !COMPILER -#ifdef MultiThread - /* - * Enter the program state of the co-expression being activated - */ - ENTERPSTATE(ncp->program); -#endif /* MultiThread */ -#endif /* COMPILER */ glbl_argp = ncp->es_argp; BlkLoc(k_current) = (union block *)ncp; -#if COMPILER - coexpr_fnc = ncp->fnc; -#endif /* COMPILER */ - -#ifdef EventMon - /* - * From here on out, A_MTEvent looks like a A_Coact. - */ - if (swtch_typ == A_MTEvent) - swtch_typ = A_Coact; -#endif /* EventMon */ - coexp_act = swtch_typ; coswitch(ccp->cstate, ncp->cstate,first); return coexp_act; -#endif /* Coexpr */ } -#ifdef Coexpr /* * new_context - determine what function to call to execute the new * co-expression; this completes the context switch. @@ -299,17 +144,5 @@ void new_context(fsig,cargp) int fsig; dptr cargp; { -#if COMPILER - (*coexpr_fnc)(); -#else /* COMPILER */ interp(fsig, cargp); -#endif /* COMPILER */ - } -#else /* Coexpr */ -/* dummy new_context if co-expressions aren't supported */ -void new_context(fsig,cargp) -int fsig; -dptr cargp; - { } -#endif /* Coexpr */ diff --git a/src/runtime/rcomp.r b/src/runtime/rcomp.r index 6cd0610..2ad3e35 100644 --- a/src/runtime/rcomp.r +++ b/src/runtime/rcomp.r @@ -35,8 +35,6 @@ dptr dp1, dp2; switch (Type(*dp1)) { -#ifdef LargeInts - case T_Integer: if (Type(*dp2) != T_Lrgint) { v1 = IntVal(*dp1); @@ -56,20 +54,6 @@ dptr dp1, dp2; return Equal; return ((lresult > 0) ? Greater : Less); -#else /* LargeInts */ - - case T_Integer: - v1 = IntVal(*dp1); - v2 = IntVal(*dp2); - if (v1 < v2) - return Less; - else if (v1 == v2) - return Equal; - else - return Greater; - -#endif /* LargeInts */ - case T_Coexpr: /* * Collate on co-expression id. @@ -171,14 +155,15 @@ dptr dp1, dp2; return ((lresult > 0) ? Greater : Less); case T_External: - /* - * Collate these values according to the relative positions of - * their blocks in the heap. - */ - lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); - if (lresult == 0) - return Equal; - return ((lresult > 0) ? Greater : Less); + /* + * Call associated collation function. + */ + { + struct descrip result = callextfunc(&extlcmp, dp1, dp2); + long ans = result.vword.integr; + if (ans == 0) return Equal; + return ans > 0 ? Greater : Less; + } default: syserr("anycmp: unknown datatype."); @@ -201,17 +186,12 @@ dptr dp; return 0; case T_Integer: return 1; - -#ifdef LargeInts case T_Lrgint: return 1; -#endif /* LargeInts */ - case T_Real: return 2; - - /* string: return 3 (see above) */ - + /* String (handled above): /* + /* return 3; */ case T_Cset: return 4; case T_File: @@ -285,12 +265,9 @@ dptr dp1, dp2; result = (IntVal(*dp1) == IntVal(*dp2)); break; -#ifdef LargeInts case T_Lrgint: result = (bigcmp(dp1, dp2) == 0); break; -#endif /* LargeInts */ - case T_Real: GetReal(dp1, rres1); diff --git a/src/runtime/rdebug.r b/src/runtime/rdebug.r index 26d1167..589ebeb 100644 --- a/src/runtime/rdebug.r +++ b/src/runtime/rdebug.r @@ -18,28 +18,6 @@ static void xtrace * tracebk - print a trace of procedure calls. */ -#if COMPILER - -void tracebk(lcl_pfp, argp) -struct p_frame *lcl_pfp; -dptr argp; - { - struct b_proc *cproc; - - struct debug *debug; - word nparam; - - if (lcl_pfp == NULL) - return; - debug = PFDebug(*lcl_pfp); - tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp); - cproc = debug->proc; - xtrace(cproc, (word)abs((int)cproc->nparam), argp, debug->old_line, - debug->old_fname); - } - -#else /* COMPILER */ - void tracebk(lcl_pfp, argp) struct pf_marker *lcl_pfp; dptr argp; @@ -87,8 +65,6 @@ dptr argp; pfp = (struct pf_marker *)(pfp->pf_efp); } } - -#endif /* COMPILER */ /* * xtrace - procedure *bp is being called with nargs arguments, the first @@ -105,16 +81,11 @@ char *pfile; if (bp == NULL) fprintf(stderr, "????"); else { - -#if COMPILER - putstr(stderr, &(bp->pname)); -#else /* COMPILER */ if (arg[0].dword == D_Proc) putstr(stderr, &(bp->pname)); else outimage(stderr, arg, 0); arg++; -#endif /* COMPILER */ putc('(', stderr); while (nargs--) { @@ -147,15 +118,9 @@ int get_name(dp1,dp0) word i, j, k; int t; -#if COMPILER - arg1 = glbl_argp; - loc1 = pfp->tend.d; - proc = PFDebug(*pfp)->proc; -#else /* COMPILER */ arg1 = &glbl_argp[1]; loc1 = pfp->pf_locals; proc = &BlkLoc(*glbl_argp)->proc; -#endif /* COMPILER */ type_case *dp1 of { tvsubs: { @@ -196,14 +161,6 @@ int get_name(dp1,dp0) StrLen(*dp0) = 6; StrLoc(*dp0) = "&trace"; } - -#ifdef FncTrace - else if (VarLoc(*dp1) == &kywd_ftrc) { - StrLen(*dp0) = 7; - StrLoc(*dp0) = "&ftrace"; - } -#endif /* FncTrace */ - else if (VarLoc(*dp1) == &kywd_dmp) { StrLen(*dp0) = 5; StrLoc(*dp0) = "&dump"; @@ -216,21 +173,6 @@ int get_name(dp1,dp0) syserr("name: unknown integer keyword variable"); kywdevent: -#ifdef MultiThread - if (VarLoc(*dp1) == &curpstate->eventsource) { - StrLen(*dp0) = 12; - StrLoc(*dp0) = "&eventsource"; - } - else if (VarLoc(*dp1) == &curpstate->eventval) { - StrLen(*dp0) = 11; - StrLoc(*dp0) = "&eventvalue"; - } - else if (VarLoc(*dp1) == &curpstate->eventcode) { - StrLen(*dp0) = 10; - StrLoc(*dp0) = "&eventcode"; - } - else -#endif /* MultiThread */ syserr("name: unknown event keyword variable"); kywdwin: { @@ -293,20 +235,11 @@ int get_name(dp1,dp0) i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1; if (i < 1) i += blkptr->lelem.nslots; -#ifdef ListFix - while (BlkType(blkptr->lelem.listprev) == T_Lelem) { -#else /* ListFix */ while (blkptr->lelem.listprev != NULL) { -#endif /* ListFix */ blkptr = blkptr->lelem.listprev; i += blkptr->lelem.nused; } -#ifdef ListFix - sprintf(sbuf,"list_%d[%ld]", - (long)blkptr->lelem.listprev->list.id, (long)i); -#else /* ListFix */ sprintf(sbuf,"L[%ld]", (long)i); -#endif /* ListFix */ i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -314,16 +247,8 @@ int get_name(dp1,dp0) case T_Record: /* record */ i = varptr - blkptr->record.fields; proc = &blkptr->record.recdesc->proc; - -#ifdef TableFix - sprintf(sbuf,"record %s_%d.%s", StrLoc(proc->recname), - blkptr->record.id, - StrLoc(proc->lnames[i])); -#else sprintf(sbuf,"%s.%s", StrLoc(proc->recname), StrLoc(proc->lnames[i])); -#endif - i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -334,104 +259,13 @@ int get_name(dp1,dp0) return Error; break; default: /* none of the above */ -#ifdef EventMon - *dp0 = emptystr; -#else /* EventMon */ syserr("name: invalid structure reference"); -#endif /* EventMon */ - } } } return Succeeded; } -#if COMPILER -#begdef PTraceSetup() - struct b_proc *proc; - - --k_trace; - showline(file_name, line_num); - showlevel(k_level); - proc = PFDebug(*pfp)->proc; /* get address of procedure block */ - putstr(stderr, &proc->pname); -#enddef - -/* - * ctrace - a procedure is being called; produce a trace message. - */ -void ctrace() - { - dptr arg; - int n; - - PTraceSetup(); - - putc('(', stderr); - arg = glbl_argp; - n = abs((int)proc->nparam); - while (n--) { - outimage(stderr, arg++, 0); - if (n) - putc(',', stderr); - } - putc(')', stderr); - putc('\n', stderr); - fflush(stderr); - } - -/* - * rtrace - a procedure is returning; produce a trace message. - */ - -void rtrace() - { - PTraceSetup(); - - fprintf(stderr, " returned "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * failtrace - procedure named s is failing; produce a trace message. - */ - -void failtrace() - { - PTraceSetup(); - - fprintf(stderr, " failed\n"); - fflush(stderr); - } - -/* - * strace - a procedure is suspending; produce a trace message. - */ - -void strace() - { - PTraceSetup(); - - fprintf(stderr, " suspended "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * atrace - a procedure is being resumed; produce a trace message. - */ -void atrace() - { - PTraceSetup(); - - fprintf(stderr, " resumed\n"); - fflush(stderr); - } -#endif /* COMPILER */ - /* * keyref(bp,dp) -- print name of subscripted table */ @@ -451,16 +285,7 @@ static int keyref(bp, dp) */ s2 = StrLoc(*dp); len = StrLen(*dp); -#ifdef TableFix - if (BlkType(bp) == T_Tvtbl) - bp = bp->tvtbl.clink; - else - while(BlkType(bp) == T_Telem) - bp = bp->telem.clink; - sprintf(sbuf, "table_%d[", bp->table.id); -#else /* TableFix */ strcpy(sbuf, "T["); -#endif /* TableFix */ { char * dest = sbuf + strlen(sbuf); strncpy(dest, s2, len); dest[len] = '\0'; @@ -473,7 +298,6 @@ static int keyref(bp, dp) return Succeeded; } -#ifdef Coexpr /* * cotrace -- a co-expression context switch; produce a trace message. */ @@ -484,26 +308,16 @@ int swtch_typ; dptr valloc; { struct b_proc *proc; - -#if !COMPILER inst t_ipc; -#endif /* !COMPILER */ --k_trace; -#if COMPILER - showline(ccp->file_name, ccp->line_num); - proc = PFDebug(*ccp->es_pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ - /* * Compute the ipc of the instruction causing the context switch. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); proc = (struct b_proc *)BlkLoc(*glbl_argp); -#endif /* COMPILER */ - showlevel(k_level); putstr(stderr, &proc->pname); fprintf(stderr,"; co-expression_%ld ", (long)ccp->id); @@ -525,7 +339,6 @@ dptr valloc; fprintf(stderr,"co-expression_%ld\n", (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ /* * showline - print file and line number information. @@ -559,11 +372,8 @@ register int n; } } -#if !COMPILER - #include "../h/opdefs.h" - extern struct descrip value_tmp; /* argument of Op_Apply */ extern struct b_proc *opblks[]; @@ -812,7 +622,6 @@ dptr dp; fflush(stderr); } -#ifdef Coexpr /* * coacttrace -- co-expression is being activated; produce a trace message. */ @@ -883,8 +692,6 @@ struct b_coexpr *ncp; (long)ccp->id, (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ -#endif /* !COMPILER */ /* * Service routine to display variables in given number of @@ -892,11 +699,7 @@ struct b_coexpr *ncp; */ int xdisp(fp,dp,count,f) -#if COMPILER - struct p_frame *fp; -#else /* COMPILER */ struct pf_marker *fp; -#endif /* COMPILER */ register dptr dp; int count; FILE *f; @@ -909,13 +712,7 @@ int xdisp(fp,dp,count,f) while (count--) { /* go back through 'count' frames */ if (fp == NULL) break; /* needed because &level is wrong in co-expressions */ - -#if COMPILER - bp = PFDebug(*fp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */ - /* #%#% was: no post-increment there, but *pre*increment dp below */ -#endif /* COMPILER */ /* * Print procedure name. @@ -939,11 +736,7 @@ int xdisp(fp,dp,count,f) /* * Print locals. */ -#if COMPILER - dp = fp->tend.d; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (n = bp->ndynam; n > 0; n--) { fprintf(f, " "); putstr(f, np); @@ -965,26 +758,14 @@ int xdisp(fp,dp,count,f) putc('\n', f); np++; } - -#if COMPILER - dp = fp->old_argp; - fp = fp->old_pfp; -#else /* COMPILER */ dp = fp->pf_argp; fp = fp->pf_pfp; -#endif /* COMPILER */ } /* * Print globals. Sort names in lexical order using temporary index array. */ - -#if COMPILER - nglobals = n_globals; -#else /* COMPILER */ nglobals = eglobals - globals; -#endif /* COMPILER */ - indices = (word *)malloc(nglobals * sizeof(word)); if (indices == NULL) return Failed; diff --git a/src/runtime/rexternal.r b/src/runtime/rexternal.r new file mode 100644 index 0000000..c3a33c6 --- /dev/null +++ b/src/runtime/rexternal.r @@ -0,0 +1,136 @@ +/* + * File: rexternal.r + * Functions dealing with external values and their custom functions. + * + * Functions in this file that declare (argc, argv) signatures + * follow the ipl/cfuncs/icall.h calling conventions and call + * dynamically loaded C functions if available for this external type. + */ + +/* + * callextfunc(func, d1, d2) -- call func(argc, argv) via icall.h conventions. + * + * func() is called with argv=1 if d2 is null or argv=2 if not. + */ +struct descrip callextfunc(int (*func)(int, dptr), dptr dp1, dptr dp2) { + struct descrip stack[3]; + int nargs = 1; + + stack[0] = nulldesc; + stack[1] = *dp1; + if (dp2 != NULL) { + stack[2] = *dp2; + nargs = 2; + } + if (func(nargs, stack) != 0) + syserr("external value helper function did not succeed"); + return stack[0]; + } + +/* + * extlname(argc, argv) - return the name of the type of external value argv[1]. + */ +int extlname(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlname != NULL) { + funcs->extlname(1, argv); /* call custom name function */ + if (! is:string(argv[0])) + syserr("extlname: not a string"); + } + else { + argv[0].dword = 8; /* strlen("external") */ + argv[0].vword.sptr = "external"; + } + return 0; + } + +/* + * extlimage(argc, argv) - return the image of external value argv[1]. + * + * Always sets argv[0] to a valid string, but returns Error + * if storage is not available for formatting the details. + */ +int extlimage(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + word len; + int nwords; + + if (funcs->extlimage != NULL) { + funcs->extlimage(1, argv); /* call custom image function */ + if (! is:string(argv[0])) + syserr("extlimage: not a string"); + return 0; + } + + extlname(1, &argv[0]); /* get type name, result in argv[0] */ + len = StrLen(argv[0]); + Protect(reserve(Strings, len + 30), return Error); + Protect(StrLoc(argv[0]) = alcstr(StrLoc(argv[0]), len), return Error); + /* + * to type name append "_<id>(nwords)" + */ + nwords = ((char*)block + block->blksize - (char*)block->data) / sizeof(word); + len += sprintf(StrLoc(argv[0]) + len, "_%ld(%d)", (long)block->id, nwords); + StrLen(argv[0]) = len; + return 0; + } + +/* + * extlcmp(argc, argv) - compare two external values argv[1] and argv[2]. + */ + +int extlcmp(int argc, dptr argv) { + struct b_external *block1 = (struct b_external *)BlkLoc(argv[1]); + struct b_external *block2 = (struct b_external *)BlkLoc(argv[2]); + struct b_extlfuns *funcs = block1->funcs; + + /* + * If the two values share the same function list, then by definition + * they are the same type and are compared using a custom function if + * one is provided in the list. + */ + if (block1->funcs == block2->funcs && funcs->extlcmp != NULL) { + funcs->extlcmp(1, argv); /* call custom comparison function */ + if (! is:integer(argv[0])) + syserr("extlcmp: not an integer"); + } + else { + /* + * Otherwise, sort by name and then by serial number. + */ + struct descrip name1 = callextfunc(&extlname, &argv[1], NULL); + struct descrip name2 = callextfunc(&extlname, &argv[2], NULL); + long result = lexcmp(&name1, &name2); + if (result == Equal) + result = block1->id - block2->id; + argv[0].dword = D_Integer; + argv[0].vword.integr = result; + } + return 0; + } + +/* + * extlcopy(argc, argv) - return a copy of external value argv[1]. + * + * By default this is the original descriptor. + */ + +int extlcopy(int argc, dptr argv) { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlcopy != NULL) { + funcs->extlcopy(1, argv); /* call custom copy function */ + if (Qual(argv[0]) || Type(argv[0]) != T_External) + syserr("extlcopy: not an external"); + } + else { + argv[0] = argv[1]; /* the identical external value */ + } + return 0; + } diff --git a/src/runtime/rlrgint.r b/src/runtime/rlrgint.r index f624cc7..ec1aaa4 100644 --- a/src/runtime/rlrgint.r +++ b/src/runtime/rlrgint.r @@ -3,8 +3,6 @@ * Large integer arithmetic */ -#ifdef LargeInts - extern int over_flow; /* @@ -2298,5 +2296,3 @@ word n; return 0; return u[n - 1] > (DIGIT)k ? 1 : -1; } - -#endif /* LargeInts */ diff --git a/src/runtime/rmemmgt.r b/src/runtime/rmemmgt.r index 4a9daa2..8cc6956 100644 --- a/src/runtime/rmemmgt.r +++ b/src/runtime/rmemmgt.r @@ -20,20 +20,13 @@ static void adjust (char *source, char *dest); static void compact (char *source); static void mvc (uword n, char *src, char *dest); -#ifdef MultiThread -static void markprogram (struct progstate *pstate); -#endif /*MultiThread*/ - /* * Variables */ - -#ifndef MultiThread word coll_stat = 0; /* collections in static region */ word coll_str = 0; /* collections in string region */ word coll_blk = 0; /* collections in block region */ word coll_tot = 0; /* total collections */ -#endif /* MultiThread */ word alcnum = 0; /* co-expressions allocated since g.c. */ dptr *quallist; /* string qualifier list */ @@ -89,13 +82,7 @@ int firstd[] = { 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 3*WordSize, /* T_File (5), file block */ - -#ifdef MultiThread - 8*WordSize, /* T_Proc (6), procedure block */ -#else /* MultiThread */ 7*WordSize, /* T_Proc (6), procedure block */ -#endif /* MultiThread */ - 4*WordSize, /* T_Record (7), record block */ 0, /* T_List (8), list header block */ 7*WordSize, /* T_Lelem (9), list element block */ @@ -106,13 +93,7 @@ int firstd[] = { 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ 0, /* T_Slots (15), set/table hash block */ 3*WordSize, /* T_Tvsubs (16), substring trapped variable */ - -#if COMPILER - 2*WordSize, /* T_Refresh (17), refresh block */ -#else /* COMPILER */ (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ -#endif /* COMPILER */ - -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ -1, /* T_Kywdint (20), integer keyword variable */ @@ -252,35 +233,18 @@ uword segsize[] = { * initalloc - initialization routine to allocate memory regions */ -#if COMPILER -void initalloc() - { - -#else /* COMPILER */ -#ifdef MultiThread -void initalloc(codesize,p) -struct progstate *p; -#else /* MultiThread */ void initalloc(codesize) -#endif /* MultiThread */ word codesize; { -#ifdef MultiThread - struct region *ps, *pb; -#endif if ((uword)codesize > (unsigned)MaxBlock) error(NULL, "icode file too large"); /* * Allocate icode region */ -#ifdef MultiThread - if (codesize) -#endif /* MultiThread */ if ((code = (char *)AllocReg(codesize)) == NULL) error(NULL, "insufficient memory, corrupted icode file, or wrong platform"); -#endif /* COMPILER */ /* * Set up allocated memory. The regions are: @@ -290,25 +254,6 @@ word codesize; * Qualifier list */ -#ifdef MultiThread - ps = p->stringregion; - ps->free = ps->base = (char *)AllocReg(ps->size); - if (ps->free == NULL) - error(NULL, "insufficient memory for string region"); - ps->end = ps->base + ps->size; - - pb = p->blockregion; - pb->free = pb->base = (char *)AllocReg(pb->size); - if (pb->free == NULL) - error(NULL, "insufficient memory for block region"); - pb->end = pb->base + pb->size; - - if (p == &rootpstate) { - if ((quallist = (dptr *)malloc(qualsize)) == NULL) - error(NULL, "insufficient memory for qualifier list"); - equallist = (dptr *)((char *)quallist + qualsize); - } -#else /* MultiThread */ { uword t1, t2; t1 = ssize; @@ -331,7 +276,6 @@ word codesize; if ((quallist = (dptr *)malloc(qualsize)) == NULL) error(NULL, "insufficient memory for qualifier list"); equallist = (dptr *)((char *)quallist + qualsize); -#endif /* MultiThread */ } /* @@ -343,11 +287,6 @@ int region; { struct b_coexpr *cp; -#ifdef EventMon - if (!noMTevents) - EVVal((word)region,E_Collect); -#endif /* EventMon */ - switch (region) { case Static: coll_stat++; @@ -366,11 +305,8 @@ int region; /* * Garbage collection cannot be done until initialization is complete. */ - -#if !COMPILER if (sp == NULL) return 0; -#endif /* !COMPILER */ /* * Sync the values (used by sweep) in the coexpr block for ¤t @@ -378,13 +314,10 @@ int region; */ cp = (struct b_coexpr *)BlkLoc(k_current); cp->es_tend = tend; - -#if !COMPILER cp->es_pfp = pfp; cp->es_gfp = gfp; cp->es_efp = efp; cp->es_sp = sp; -#endif /* !COMPILER */ /* * Reset qualifier list. @@ -395,18 +328,13 @@ int region; /* * Mark the stacks for &main and the current co-expression. */ -#ifdef MultiThread - markprogram(&rootpstate); -#endif /* MultiThread */ markblock(&k_main); markblock(&k_current); /* * Mark &subject and the cached s2 and s3 strings for map. */ -#ifndef MultiThread postqual(&k_subject); postqual(&kywd_prog); -#endif /* MultiThread */ if (Qual(maps2)) /* caution: the cached arguments of */ postqual(&maps2); /* map may not be strings. */ else if (Pointer(maps2)) @@ -436,7 +364,6 @@ int region; * Mark the globals and the statics. */ -#ifndef MultiThread { register struct descrip *dp; for (dp = globals; dp < eglobals; dp++) if (Qual(*dp)) @@ -457,7 +384,6 @@ int region; if (is:file(lastEventWin)) markblock(&(lastEventWin)); #endif /* Graphics */ -#endif /* MultiThread */ reclaim(); @@ -483,75 +409,10 @@ int region; } } -#ifdef EventMon - if (!noMTevents) { - mmrefresh(); - EVValD(&nulldesc, E_EndCollect); - } -#endif /* EventMon */ - return 1; } /* - * markprogram - traverse pointers out of a program state structure - */ - -#ifdef MultiThread -#define PostDescrip(d) \ - if (Qual(d)) \ - postqual(&(d)); \ - else if (Pointer(d))\ - markblock(&(d)); - -static void markprogram(pstate) -struct progstate *pstate; - { - struct descrip *dp; - - PostDescrip(pstate->parentdesc); - PostDescrip(pstate->eventmask); - PostDescrip(pstate->opcodemask); - PostDescrip(pstate->eventcode); - PostDescrip(pstate->eventval); - PostDescrip(pstate->eventsource); - - /* Kywd_err, &error, always an integer */ - /* Kywd_pos, &pos, always an integer */ - postqual(&(pstate->ksub)); - postqual(&(pstate->Kywd_prog)); - /* Kywd_ran, &random, always an integer */ - /* Kywd_trc, &trace, always an integer */ - - /* - * Mark the globals and the statics. - */ - for (dp = pstate->Globals; dp < pstate->Eglobals; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - for (dp = pstate->Statics; dp < pstate->Estatics; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - /* - * no marking for &x, &y, &row, &col, &interval, all integers - */ -#ifdef Graphics - PostDescrip(pstate->LastEventWin); /* last Event() win */ - PostDescrip(pstate->Kywd_xwin[XKey_Window]); /* &window */ -#endif /* Graphics */ - - PostDescrip(pstate->K_errorvalue); - PostDescrip(pstate->T_errorvalue); - } -#endif /* MultiThread */ - -/* * postqual - mark a string qualifier. Strings outside the string space * are ignored. */ @@ -693,17 +554,6 @@ dptr dp; BlkType(block) = (uword)dp; sweep((struct b_coexpr *)block); -#ifdef MultiThread - if (((struct b_coexpr *)block)+1 == - (struct b_coexpr *)((struct b_coexpr *)block)->program){ - /* - * This coexpr is an &main; traverse its roots - */ - markprogram(((struct b_coexpr *)block)->program); - } -#endif /* MultiThread */ - -#ifdef Coexpr /* * Mark the activators of this co-expression. The activators are * stored as a list of addresses, but markblock requires the address @@ -723,7 +573,6 @@ dptr dp; } if(BlkLoc(cp->freshblk) != NULL) markblock(&((struct b_coexpr *)block)->freshblk); -#endif /* Coexpr */ } else { @@ -950,12 +799,9 @@ struct b_coexpr *ce; } } } -#if !COMPILER sweep_stk(ce); -#endif /* !COMPILER */ } -#if !COMPILER /* * sweep_stk - sweep the stack, marking all descriptors there. Method * is to start at a known point, specifically, the frame that the @@ -992,19 +838,6 @@ struct b_coexpr *ce; s_sp = ce->es_sp; nargs = 0; /* Nargs counter is 0 initially. */ -#ifdef MultiThread - if (fp == 0) { - if (is:list(* (dptr) (s_sp - 1))) { - /* - * this is the argument list of an un-started task - */ - if (Pointer(*((dptr)(&s_sp[-1])))) { - markblock((dptr)&s_sp[-1]); - } - } - } -#endif /* MultiThread */ - while ((fp != 0 || nargs)) { /* Keep going until current fp is 0 and no arguments are left. */ if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { @@ -1071,7 +904,6 @@ struct b_coexpr *ce; } } } -#endif /* !COMPILER */ /* * reclaim - reclaim space in the allocated memory regions. The marking @@ -1118,11 +950,7 @@ static void cofree() * Reset the type for &main. */ -#ifdef MultiThread - rootpstate.Mainhead->title = T_Coexpr; -#else /* MultiThread */ BlkLoc(k_main)->coexpr.title = T_Coexpr; -#endif /* MultiThread */ /* * The co-expression blocks are linked together through their @@ -1145,9 +973,7 @@ static void cofree() abp = abp->astk_nxt; free((pointer)xabp); } - #ifdef CoClean - coclean(xep->cstate); - #endif /* CoClean */ + coclean(xep->cstate); free((pointer)xep); } else { @@ -1392,68 +1218,3 @@ register char *src, *dest; * Note that src == dest implies no action */ } - -#ifdef DeBugIconx -/* - * descr - dump a descriptor. Used only for debugging. - */ - -void descr(dp) -dptr dp; - { - int i; - - fprintf(stderr,"%08lx: ",(long)dp); - if (Qual(*dp)) - fprintf(stderr,"%15s","qualifier"); - - else if (Var(*dp)) - fprintf(stderr,"%15s","variable"); - else { - i = Type(*dp); - switch (i) { - case T_Null: - fprintf(stderr,"%15s","null"); - break; - case T_Integer: - fprintf(stderr,"%15s","integer"); - break; - default: - fprintf(stderr,"%15s",blkname[i]); - } - } - fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); - } - -/* - * blkdump - dump the allocated block region. Used only for debugging. - * NOTE: Not adapted for multiple regions. - */ - -void blkdump() - { - register char *blk; - register word type, size, fdesc; - register dptr ndesc; - - fprintf(stderr, - "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", - (long)blkbase,(long)blkfree,(long)blkend); - fprintf(stderr," loc type size contents\n"); - - for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { - type = BlkType(blk); - size = BlkSize(blk); - fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], - (long)size); - if ((fdesc = firstd[type]) > 0) - for (ndesc = (dptr)(blk + fdesc); - ndesc < (dptr)(blk + size); ndesc++) { - fprintf(stderr," "); - descr(ndesc); - } - fprintf(stderr,"\n"); - } - fprintf(stderr,"end of block region.\n"); - } -#endif /* DeBugIconx */ diff --git a/src/runtime/rmisc.r b/src/runtime/rmisc.r index a302da2..18097c5 100644 --- a/src/runtime/rmisc.r +++ b/src/runtime/rmisc.r @@ -50,17 +50,7 @@ int getvar(s,vp) register dptr np; register int i; struct b_proc *bp; -#if COMPILER - struct descrip sdp; - - if (!debug_info) - fatalerr(402,NULL); - - StrLoc(sdp) = s; - StrLen(sdp) = strlen(s); -#else /* COMPILER */ struct pf_marker *fp = pfp; -#endif /* COMPILER */ /* * Is it a keyword that's a variable? @@ -97,15 +87,6 @@ int getvar(s,vp) VarLoc(*vp) = &kywd_trc; return Succeeded; } - -#ifdef FncTrace - else if (strcmp(s,"&ftrace") == 0) { - vp->dword = D_Kywdint; - VarLoc(*vp) = &kywd_ftrc; - return Succeeded; - } -#endif /* FncTrace */ - else if (strcmp(s,"&dump") == 0) { vp->dword = D_Kywdint; VarLoc(*vp) = &kywd_dmp; @@ -119,24 +100,6 @@ int getvar(s,vp) } #endif /* Graphics */ -#ifdef MultiThread - else if (strcmp(s,"&eventvalue") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventval); - return Succeeded; - } - else if (strcmp(s,"&eventsource") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventsource); - return Succeeded; - } - else if (strcmp(s,"&eventcode") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventcode); - return Succeeded; - } -#endif /* MultiThread */ - else return Failed; } @@ -149,53 +112,31 @@ int getvar(s,vp) * If no such variable exits, it fails. */ -#if !COMPILER /* * If no procedure has been called (as can happen with icon_call(), * dont' try to find local identifier. */ if (pfp == NULL) goto glbvars; -#endif /* !COMPILER */ dp = glbl_argp; -#if COMPILER - bp = PFDebug(*pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ -#endif /* COMPILER */ np = bp->lnames; /* Check the formal parameter names. */ for (i = abs((int)bp->nparam); i > 0; i--) { -#if COMPILER - if (eq(&sdp, np) == 1) { -#else /* COMPILER */ dp++; if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return ParamName; } np++; -#if COMPILER - dp++; -#endif /* COMPILER */ } - -#if COMPILER - dp = &pfp->tend.d[0]; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */ -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return LocalName; @@ -206,11 +147,7 @@ int getvar(s,vp) dp = &statics[bp->fstatic]; /* Check the local static names. */ for (i = (int)bp->nstatic; i > 0; i--) { -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return StaticName; @@ -219,15 +156,6 @@ int getvar(s,vp) dp++; } -#if COMPILER - for (i = 0; i < n_globals; ++i) { - if (eq(&sdp, &gnames[i])) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&globals[i]; - return GlobalName; - } - } -#else /* COMPILER */ glbvars: dp = globals; /* Check the global variable names. */ np = gnames; @@ -240,7 +168,6 @@ glbvars: np++; dp++; } -#endif /* COMPILER */ return Failed; } @@ -288,7 +215,6 @@ dptr dp; i = (13255 * (uword)IntVal(*dp)) >> 10; break; -#ifdef LargeInts /* * The hash value of a bignum is based on its length and its * most and least significant digits. @@ -301,7 +227,6 @@ dptr dp; (b->digits[b->msd] << 8) ^ b->digits[b->lsd]; } break; -#endif /* LargeInts */ /* * The hash value of a real number is itself times a constant, @@ -412,15 +337,10 @@ int noimage; fprintf(f, "&null"); integer: - -#ifdef LargeInts if (Type(*dp) == T_Lrgint) bigprint(f, dp); else fprintf(f, "%ld", (long)IntVal(*dp)); -#else /* LargeInts */ - fprintf(f, "%ld", (long)IntVal(*dp)); -#endif /* LargeInts */ real: { char s[30]; @@ -436,7 +356,7 @@ int noimage; * Check for a predefined cset; use keyword name if found. */ if ((csn = csname(dp)) != NULL) { - fprintf(f, csn); + fprintf(f, "%s", csn); return; } /* @@ -628,12 +548,6 @@ int noimage; fprintf(f, "&random = "); else if (VarLoc(*dp) == &kywd_trc) fprintf(f, "&trace = "); - -#ifdef FncTrace - else if (VarLoc(*dp) == &kywd_ftrc) - fprintf(f, "&ftrace = "); -#endif /* FncTrace */ - else if (VarLoc(*dp) == &kywd_dmp) fprintf(f, "&dump = "); else if (VarLoc(*dp) == &kywd_err) @@ -642,14 +556,6 @@ int noimage; } kywdevent: { -#ifdef MultiThread - if (VarLoc(*dp) == &curpstate->eventsource) - fprintf(f, "&eventsource = "); - else if (VarLoc(*dp) == &curpstate->eventcode) - fprintf(f, "&eventcode = "); - else if (VarLoc(*dp) == &curpstate->eventval) - fprintf(f, "&eventval = "); -#endif /* MultiThread */ outimage(f, VarLoc(*dp), noimage); } @@ -682,8 +588,13 @@ int noimage; outimage(f, dp, noimage); putc(')', f); } - else if (Type(*dp) == T_External) - fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize); + else if (Type(*dp) == T_External) { + q = callextfunc(&extlimage, dp, NULL); /* get image as a string */ + i = StrLen(q); + s = StrLoc(q); + while (i-- > 0) + putc(*s++, f); + } else if (Type(*dp) <= MaxType) fprintf(f, "%s", blkname[Type(*dp)]); else @@ -848,7 +759,6 @@ int (*compar)(); return 0; } -#if !COMPILER /* * qtos - convert a qualified string named by *dp to a C-style string. * Put the C-style string in sbuf if it will fit, otherwise put it @@ -883,9 +793,7 @@ char *sbuf; } return Succeeded; } -#endif /* !COMPILER */ -#ifdef Coexpr /* * pushact - push actvtr on the activator stack of ce */ @@ -895,10 +803,6 @@ struct b_coexpr *ce, *actvtr; struct astkblk *abp = ce->es_actstk, *nabp; struct actrec *arp; -#ifdef MultiThread - abp->arec[0].activator = actvtr; -#else /* MultiThread */ - /* * If the last activator is the same as this one, just increment * its count. @@ -924,10 +828,8 @@ struct b_coexpr *ce, *actvtr; arp->acount = 1; arp->activator = actvtr; ce->es_actstk = abp; -#endif /* MultiThread */ return Succeeded; } -#endif /* Coexpr */ /* * popact - pop the most recent activator from the activator stack of ce @@ -936,17 +838,10 @@ struct b_coexpr *ce, *actvtr; struct b_coexpr *popact(ce) struct b_coexpr *ce; { - -#ifdef Coexpr - struct astkblk *abp = ce->es_actstk, *oabp; struct actrec *arp; struct b_coexpr *actvtr; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ - /* * If the current stack block is empty, pop it. */ @@ -971,15 +866,8 @@ struct b_coexpr *ce; ce->es_actstk = abp; return actvtr; -#endif /* MultiThread */ - -#else /* Coexpr */ - syserr("popact() called, but co-expressions not implemented"); -#endif /* Coexpr */ - } -#ifdef Coexpr /* * topact - return the most recent activator of ce. */ @@ -988,48 +876,14 @@ struct b_coexpr *ce; { struct astkblk *abp = ce->es_actstk; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ if (abp->nactivators == 0) abp = abp->astk_nxt; return abp->arec[abp->nactivators-1].activator; -#endif /* MultiThread */ } -#ifdef DeBugIconx -/* - * dumpact - dump an activator stack - */ -void dumpact(ce) -struct b_coexpr *ce; -{ - struct astkblk *abp = ce->es_actstk; - struct actrec *arp; - int i; - - if (abp) - fprintf(stderr, "Ce %ld ", (long)ce->id); - while (abp) { - fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n", - abp, abp->nactivators); - for (i = abp->nactivators; i >= 1; i--) { - arp = &abp->arec[i-1]; - /*for (j = 1; j <= arp->acount; j++)*/ - fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id), - arp->acount); - } - abp = abp->astk_nxt; - } -} -#endif /* DeBugIconx */ -#endif /* Coexpr */ - -#if !COMPILER /* * findline - find the source line number associated with the ipc */ -#ifdef SrcColumnInfo int findline(ipc) word *ipc; { @@ -1042,19 +896,12 @@ word *ipc; } int findloc(ipc) -#else /* SrcColumnInfo */ -int findline(ipc) -#endif /* SrcColumnInfo */ word *ipc; { uword ipc_offset; uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1084,11 +931,7 @@ int line; { uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1113,10 +956,7 @@ word *ipc; { uword ipc_offset; struct ipc_fname *p; - -#ifndef MultiThread extern struct ipc_fname *filenms, *efilenms; -#endif /* MultiThread */ if (!InRange(code,ipc,ecode)) return "?"; @@ -1130,7 +970,6 @@ word *ipc; /*NOTREACHED*/ return 0; /* avoid gcc warning */ } -#endif /* !COMPILER */ /* * doimage(c,q) - allocate character c in string space, with escape @@ -1249,7 +1088,6 @@ dptr dp1, dp2; } integer: { -#ifdef LargeInts if (Type(source) == T_Lrgint) { word slen; word dlen; @@ -1271,9 +1109,6 @@ dptr dp1, dp2; } else cnv: string(source, *dp2); -#else /* LargeInts */ - cnv:string(source, *dp2); -#endif /* LargeInts */ } real: { @@ -1472,16 +1307,9 @@ dptr dp1, dp2; } default: - if (Type(*dp1) == T_External) { - /* - * For now, just produce "external(n)". - */ - sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize); - len = strlen(sbuf); - Protect(t = alcstr(sbuf, len), return Error); - StrLoc(*dp2) = t; - StrLen(*dp2) = len; - } + if (Type(*dp1) == T_External) { + *dp2 = callextfunc(&extlimage, dp1, NULL); + } else { ReturnErrVal(123, source, Error); } @@ -1685,100 +1513,6 @@ word a; return -a; } -#if COMPILER -/* - * sig_rsm - standard success continuation that just signals resumption. - */ - -int sig_rsm() - { - return A_Resume; - } - -/* - * cmd_line - convert command line arguments into a list of strings. - */ -void cmd_line(argc, argv, rslt) -int argc; -char **argv; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Skip the program name. - */ - --argc; - ++argv; - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(argc), fatalerr(0,NULL)); - Protect(bp = alclstb(argc, (word)0, argc), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < argc; ++i) { - StrLen(bp->lslots[i]) = strlen(argv[i]); - StrLoc(bp->lslots[i]) = argv[i]; - } - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } - -/* - * varargs - construct list for use in procedures with variable length - * argument list. - */ -void varargs(argp, nargs, rslt) -dptr argp; -int nargs; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(nargs), fatalerr(0,NULL)); - Protect(bp = alclstb(nargs, (word)0, nargs), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < nargs; i++) - deref(&argp[i], &bp->lslots[i]); - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } -#endif /* COMPILER */ - /* * retderef - Dereference local variables and substrings of local * string-valued variables. This is used for return, suspend, and diff --git a/src/runtime/rmswin.ri b/src/runtime/rmswin.ri index 3471fd3..317e95f 100644 --- a/src/runtime/rmswin.ri +++ b/src/runtime/rmswin.ri @@ -232,7 +232,7 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) if (! winInitialized++) { BORDWIDTH = FRAMEWIDTH * 2; - BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2 - 1; + BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2; GetCPInfo(CP_ACP, &cpinfo); MAXBYTESPERCHAR = cpinfo.MaxCharSize; } @@ -299,10 +299,10 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) palette = CreatePalette(logpal); if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } oldfont = SelectObject(hdc, wc->font->font); @@ -1552,7 +1552,7 @@ int alc_rgb(wbp w, SysColor rgb) LOGPALETTE lp; if (palette) { for (i=0; i < numColors; i++) { - if (rgb == scp[i].c && scp[i].type == SHARED) break; + if (rgb == scp[i].c && scp[i].type == CSHARED) break; } if (i == numColors) { numColors++; @@ -1563,7 +1563,7 @@ int alc_rgb(wbp w, SysColor rgb) scp = realloc(scp, numColors * sizeof(struct wcolor)); if (scp == NULL) { numColors--; return Failed; } scp[numColors - 1].c = rgb; - scp[numColors - 1].type = SHARED; + scp[numColors - 1].type = CSHARED; sprintf(scp[numColors - 1].name, "%d,%d,%d", RED(rgb), GREEN(rgb), BLUE(rgb)); lp.palNumEntries = 1; @@ -2529,10 +2529,10 @@ HBITMAP loadimage(wbp w, char *filename, unsigned int *width, if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } else { @@ -2570,7 +2570,7 @@ char *get_mutable_name(wbp w, int mute_index) char *tmp; PALETTEENTRY pe; - if (-mute_index > numColors || scp[-mute_index].type != MUTABLE) { + if (-mute_index > numColors || scp[-mute_index].type != CMUTABLE) { return NULL; } @@ -2642,7 +2642,7 @@ int mutable_color(wbp w, dptr argv, int argc, int *retval) } scp[numColors-1].c = -(numColors-1); sprintf(scp[numColors-1].name, "%d:", -(numColors-1)); - scp[numColors-1].type = MUTABLE; + scp[numColors-1].type = CMUTABLE; if (ResizePalette(palette, numColors) == 0) { FREE_STDLOCALS(w); return Failed; diff --git a/src/runtime/rstruct.r b/src/runtime/rstruct.r index 22ab704..acf72f4 100644 --- a/src/runtime/rstruct.r +++ b/src/runtime/rstruct.r @@ -91,10 +91,6 @@ word i, j; Protect(lp2 = (struct b_list *) alclist(size), return Error); Protect(bp2 = (struct b_lelem *)alclstb(nslots,(word)0,size), return Error); lp2->listhead = lp2->listtail = (union block *) bp2; -#ifdef ListFix - bp2->listprev = bp2->listnext = (union block *) lp2; -#endif /* ListFix */ - cpslots(dp1, bp2->lslots, i, j); /* @@ -102,95 +98,9 @@ word i, j; */ dp2->dword = D_List; BlkLoc(*dp2) = (union block *) lp2; - EVValD(dp2, E_Lcreate); return Succeeded; } -#ifdef TableFix -/* - * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. - */ -int cpset(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Set); - EVValD(dp2, E_Screate); - return i; - } - -int cptable(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Table); - BlkLoc(*dp2)->table.defvalue = BlkLoc(*dp1)->table.defvalue; - EVValD(dp2, E_Tcreate); - return i; - } - -int cphash(dp1, dp2, n, tcode) -dptr dp1, dp2; -word n; -int tcode; - { - union block *src; - tended union block *dst; - tended struct b_slots *seg; - tended struct b_selem *ep, *prev; - struct b_selem *se; - register word slotnum; - register int i; - - /* - * Make a new set organized like dp1, with room for n elements. - */ - dst = hmake(tcode, BlkLoc(*dp1)->set.mask + 1, n); - if (dst == NULL) - return Error; - /* - * Copy the header and slot blocks. - */ - src = BlkLoc(*dp1); - dst->set.size = src->set.size; /* actual set size */ - dst->set.mask = src->set.mask; /* hash mask */ - for (i = 0; i < HSegs && src->set.hdir[i] != NULL; i++) - memcpy((char *)dst->set.hdir[i], (char *)src->set.hdir[i], - src->set.hdir[i]->blksize); - /* - * Work down the chain of element blocks in each bucket - * and create identical chains in new set. - */ - for (i = 0; i < HSegs && (seg = dst->set.hdir[i]) != NULL; i++) - for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { - prev = NULL; - for (ep = (struct b_selem *)seg->hslots[slotnum]; - ep != NULL && BlkType(ep) != T_Table; - ep = (struct b_selem *)ep->clink) { - if (tcode == T_Set) { - Protect(se = alcselem(&ep->setmem, ep->hashnum), return Error); - se->clink = ep->clink; - } - else { - Protect(se = (struct b_selem *)alctelem(), return Error); - *(struct b_telem *)se = *(struct b_telem *)ep; /* copy table entry */ - if (BlkType(se->clink) == T_Table) - se->clink = dst; - } - if (prev == NULL) - seg->hslots[slotnum] = (union block *)se; - else - prev->clink = (union block *)se; - prev = se; - } - } - dp2->dword = tcode | D_Typecode | F_Ptr; - BlkLoc(*dp2) = dst; - if (TooSparse(dst)) - hshrink(dst); - return Succeeded; - } -#else /* TableFix */ /* * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. */ @@ -243,10 +153,8 @@ word n; BlkLoc(*dp2) = dst; if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Screate, D_Set); return Succeeded; } -#endif /* TableFix */ /* * hmake - make a hash structure (Set or Table) with a given number of slots. @@ -281,13 +189,6 @@ word nslots, nelem; for (; seg >= 0; seg--) { Protect(segp = alcsegment(segsize[seg]), return NULL); blk->set.hdir[seg] = segp; -#ifdef TableFix - if (tcode == T_Table) { - int j; - for (j = 0; j < segsize[seg]; j++) - segp->hslots[j] = blk; - } -#endif /* TableFix */ } blk->set.mask = nslots - 1; return blk; @@ -384,15 +285,9 @@ union block *ep; * has same hash value as the current one, in which case we defer it * by doing nothing now. */ -#ifdef TableFix - if (bp->table.mask != s->tmask && - (ep->selem.clink == NULL || BlkType(ep->telem.clink) == T_Table || - ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#else /* TableFix */ if (bp->table.mask != s->tmask && (ep->selem.clink == NULL || ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#endif /* TableFix */ /* * Yes, they did split. Make a note of the current state. */ @@ -414,12 +309,7 @@ union block *ep; * element, because it may have moved to a new segment. */ ep = bp->table.hdir[s->segnum]->hslots[s->slotnum]; -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= hn) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= hn) -#endif /* TableFix */ ep = ep->telem.clink; } @@ -429,22 +319,14 @@ union block *ep; * that have identical hash numbers. Find the next element in * the current hash chain. */ -#ifdef TableFix - if (ep != NULL && BlkType(ep) != T_Table) /* NULL on very first call */ -#else /* TableFix */ if (ep != NULL) /* already NULL on very first call */ -#endif /* TableFix */ ep = ep->telem.clink; /* next element in chain, if any */ } /* * If we don't yet have an element, search successive slots. */ -#ifdef TableFix - while (ep == NULL || BlkType(ep) == T_Table) { -#else /* TableFix */ while (ep == NULL) { -#endif /* TableFix */ /* * Move to the next slot and pick the first entry. */ @@ -470,12 +352,7 @@ union block *ep; * This chain was split from its parent while the parent was * being processed. Skip past elements already processed. */ -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= s->sghash[i]) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= s->sghash[i]) -#endif /* TableFix */ ep = ep->telem.clink; } } @@ -484,9 +361,6 @@ union block *ep; /* * Return the element. */ -#ifdef TableFix - if (ep && BlkType(ep) == T_Table) ep = NULL; -#endif /* TableFix */ return ep; } @@ -508,25 +382,12 @@ union block *bp; return; /* can't split further */ newslots = ps->mask + 1; Protect(newseg = alcsegment(newslots), return); -#ifdef TableFix - if (BlkType(bp) == T_Table) { - int j; - for(j=0; j<newslots; j++) newseg->hslots[j] = bp; - } -#endif /* TableFix */ - curslot = newseg->hslots; for (segnum = 0; (seg = ps->hdir[segnum]) != NULL; segnum++) for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { tp0 = &seg->hslots[slotnum]; /* ptr to tail of old slot */ tp1 = curslot++; /* ptr to tail of new slot */ -#ifdef TableFix - for (ep = *tp0; - ep != NULL && BlkType(ep) != T_Table; - ep = ep->selem.clink) { -#else /* TableFix */ for (ep = *tp0; ep != NULL; ep = ep->selem.clink) { -#endif /* TableFix */ if ((ep->selem.hashnum & newslots) == 0) { *tp0 = ep; /* element does not move */ tp0 = &ep->selem.clink; @@ -536,14 +397,7 @@ union block *bp; tp1 = &ep->selem.clink; } } -#ifdef TableFix - if ( BlkType(bp) == T_Table ) - *tp0 = *tp1 = bp; - else - *tp0 = *tp1 = NULL; -#else /* TableFix */ *tp0 = *tp1 = NULL; -#endif /* TableFix */ } ps->hdir[segnum] = newseg; ps->mask = (ps->mask << 1) | 1; @@ -578,12 +432,7 @@ union block *bp; tp = &seg->hslots[slotnum]; /* tail pointer */ ep0 = seg->hslots[slotnum]; /* lower slot entry pointer */ ep1 = *uppslot++; /* upper slot entry pointer */ -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table && - ep1 != NULL && BlkType(ep1) != T_Table) -#else /* TableFix */ while (ep0 != NULL && ep1 != NULL) -#endif /* TableFix */ if (ep0->selem.hashnum < ep1->selem.hashnum) { *tp = ep0; tp = &ep0->selem.clink; @@ -594,20 +443,12 @@ union block *bp; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; } -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table) { -#else /* TableFix */ while (ep0 != NULL) { -#endif /* TableFix */ *tp = ep0; tp = &ep0->selem.clink; ep0 = ep0->selem.clink; } -#ifdef TableFix - while (ep1 != NULL && BlkType(ep1) != T_Table) { -#else /* TableFix */ while (ep1 != NULL) { -#endif /* TableFix */ *tp = ep1; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; @@ -640,11 +481,7 @@ int *res; /* pointer to integer result flag */ * Look for x in the hash chain. */ *res = 0; -#ifdef TableFix - while ((pe = (struct b_selem *)*lp) != NULL && BlkType(pe) != T_Table) { -#else /* TableFix */ while ((pe = (struct b_selem *)*lp) != NULL) { -#endif /* TableFix */ eh = pe->hashnum; if (eh > hn) /* too far - it isn't there */ return lp; diff --git a/src/runtime/rsys.r b/src/runtime/rsys.r index f4bdfc1..83f6380 100644 --- a/src/runtime/rsys.r +++ b/src/runtime/rsys.r @@ -126,16 +126,11 @@ dptr d; int idelay(n) int n; { - #if MSWIN - Sleep(n); - return Succeeded; - #else /* MSWIN */ - struct timeval t; - t.tv_sec = n / 1000; - t.tv_usec = (n % 1000) * 1000; - select(1, NULL, NULL, NULL, &t); - return Succeeded; - #endif /* MSWIN */ + struct timeval t; + t.tv_sec = n / 1000; + t.tv_usec = (n % 1000) * 1000; + select(1, NULL, NULL, NULL, &t); + return Succeeded; } #ifdef KeyboardFncs diff --git a/src/runtime/rwindow.r b/src/runtime/rwindow.r index 752baa2..0ad4ddc 100644 --- a/src/runtime/rwindow.r +++ b/src/runtime/rwindow.r @@ -10,7 +10,6 @@ static int sicmp (siptr sip1, siptr sip2); int canvas_serial, context_serial; -#ifndef MultiThread struct descrip amperX = {D_Integer}; struct descrip amperY = {D_Integer}; struct descrip amperCol = {D_Integer}; @@ -19,8 +18,6 @@ struct descrip amperInterval = {D_Integer}; struct descrip lastEventWin = {D_Null}; int lastEvFWidth = 0, lastEvLeading = 0, lastEvAscent = 0; uword xmod_control, xmod_shift, xmod_meta; -#endif /* MultiThread */ - /* * subscript the already-processed-events "queue" to index i. diff --git a/src/runtime/rxrsc.ri b/src/runtime/rxrsc.ri index c99edeb..199468c 100644 --- a/src/runtime/rxrsc.ri +++ b/src/runtime/rxrsc.ri @@ -16,7 +16,7 @@ int fontcmp(char *font1, char *font2, int size, int flags); /* check for color match */ #define CMATCH(cp, rr, gg, bb) \ ((cp)->r == (rr) && (cp)->g == (gg) && (cp->b) == (bb) && \ - (cp)->type == SHARED && (cp)->refcount > 0) + (cp)->type == CSHARED && (cp)->refcount > 0) /* * Allocate a color given linear r, g, b. Colors are shared on a @@ -122,7 +122,7 @@ int is_iconcolor; cp->g = g; cp->b = b; cp->c = color.pixel; - cp->type = SHARED; + cp->type = CSHARED; /* * Remember in window color list, too, if not TrueColor visual. */ @@ -234,7 +234,7 @@ wbp w1, w2; for (i1 = 0; i1 < ws1->numColors; i1++) { j = ws1->theColors[i1]; - if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != MUTABLE) { + if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != CMUTABLE) { for (i2 = 0; i2 < ws2->numColors; i2++) { if (j == ws2->theColors[i2]) break; @@ -315,33 +315,11 @@ int extent; */ if (((extent==0) && (wd->colrptrs[j] == w->context->fg)) || ((extent==0) && (wd->colrptrs[j] == w->context->bg)) || - (wd->colrptrs[j]->type == MUTABLE)) { + (wd->colrptrs[j]->type == CMUTABLE)) { theColors[numSaved++] = j; continue; } -#ifdef FreeColorFix - /* - * don't free ANY context's fg or bg - */ - { - wcp wc; int numhits = 0; - for(wc=wcntxts; wc; wc=wc->next) { - if ((wc->fg == wd->colrptrs[j]) || - (wc->bg == wd->colrptrs[j])) { - if (numhits == 0) - theColors[numSaved++] = j; - numhits++; - } - } - if (numhits) { - if (numhits > wd->colrptrs[j]->refcount) - wd->colrptrs[j]->refcount = numhits; - continue; - } - } -#endif /* FreeColorFix */ - if (--(wd->colrptrs[j]->refcount) == 0) { toFree[freed++] = wd->colrptrs[j]->c; } @@ -428,7 +406,7 @@ char *s; cp = wd->colrptrs[0]; strcpy(cp->name,"black"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 0; color.red = color.green = color.blue = 0; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -438,7 +416,7 @@ char *s; cp = wd->colrptrs[1]; strcpy(cp->name,"white"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 65535; color.red = color.green = color.blue = 65535; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -685,7 +663,7 @@ int size, flags; */ p = xlfd_field(fontlist[champ], XLFD_Size); if (p[0] == '0' && p[1] == '-') - sprintf(fontspec, "%.*s%d%s", p - fontlist[champ], + sprintf(fontspec, "%.*s%d%s", (int) (p - fontlist[champ]), fontlist[champ], bestsize, p + 1); else strcpy(fontspec, fontlist[champ]); diff --git a/src/runtime/rxwin.ri b/src/runtime/rxwin.ri index c2dc48c..3db8086 100644 --- a/src/runtime/rxwin.ri +++ b/src/runtime/rxwin.ri @@ -1140,22 +1140,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - if (ws->win == (Window) NULL) { - wmap(w); - } - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); - XSync(stddpy, False); - while (ws->iconic != IconicState) - if ((hm = handle_misc(wd, NULL)) < 1) { - if (hm == -1) return Error; - else if (hm == 0) { - return Failed; - } - } -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1265,11 +1250,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1509,7 +1490,7 @@ int fg; return setfgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -fg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -fg - 1) break; if (i == wd->numColors) return Failed; wc->fg = wd->colrptrs[i]; @@ -1562,7 +1543,7 @@ int bg; return setbgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -bg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -bg - 1) break; if (i == wd->numColors) return Failed; wc->bg = wd->colrptrs[i]; @@ -2287,7 +2268,7 @@ int *retval; i = alc_centry(wd); if (i == 0) return Failed; - wd->colrptrs[i]->type = MUTABLE; + wd->colrptrs[i]->type = CMUTABLE; wd->colrptrs[i]->c = pixels[0]; /* save color index as "name", followed by a null string for value */ @@ -2351,7 +2332,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i == dp->numColors) @@ -2390,7 +2371,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i != dp->numColors) @@ -2416,7 +2397,7 @@ char *s; for (i = 2; i < dp->numColors; i++) if (dp->colrptrs[i]->r == color.red && dp->colrptrs[i]->g == color.green - && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != MUTABLE) + && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != CMUTABLE) break; if (i != dp->numColors) free_xcolor(w, dp->colrptrs[i]->c); @@ -2794,7 +2775,7 @@ struct imgmem *imem; for (cpp = wd->colrptrs ; cpp < wd->colrptrs + wd->numColors; cpp++) { if ((*cpp)->c == c) { - if ((*cpp)->type == MUTABLE) + if ((*cpp)->type == CMUTABLE) *rv = -c - 1; else { *rv = 1; |