diff options
Diffstat (limited to 'unix/boot/spp')
371 files changed, 26213 insertions, 0 deletions
diff --git a/unix/boot/spp/README b/unix/boot/spp/README new file mode 100644 index 00000000..d4d64dfc --- /dev/null +++ b/unix/boot/spp/README @@ -0,0 +1,43 @@ +These directories contain the source code for the UNIX version of the compiler +for the IRAF subset preprocessor language (SPP). In its current implementation +the compiler consists of the following modules: + + xc.e main program (like cc) + xpp.e first pass (written in Lex and C) + rpp.e second pass (written in ratfor) + +files: + xpp subdirectory containing XPP + rpp subdirectory containing RPP + xc.c the XC compiler/linker + +runtime files: + lib$xc.e installed UNIX xc compiler + lib$xpp.e installed first pass + lib$rpp.e installed second pass + + +This implementation of the SPP preprocessor (kludgy though it may be) should be +portable to any host computer supporting C and Fortran compilers. A Ratfor +compiler and runtime library is no longer required. XPP does contain some +machine dependencies in its internal tables describing the host Fortran +compiler, and these should be reviewed. RPP has a C language interface to the +host machine which contains knowledge of how the host system permits C and +Fortran to be mixed in the same program. Hopefully all machine dependence +has been concentrated in the two files xpp/xppcode.c and rpp/ratlibc/ratdef.h. + +This version of the preprocessor no longer knows about pathnames other than +those defined in the C include file "iraf.h", which is also used by the +CL and all other C files in IRAF. The "iraf.h" file is the only file used +by IRAF which does not reside in the IRAF directories (although a copy appears +in lib$libc and we make a symbolic link to it on our 4.2BSD UNIX system). +XC has to know the root directory of IRAF to reference important files in +iraf$lib. The root directory may be set on the command line with the "-r" +(root) argument; if "-r ospathname" is omitted the default is the value of +IRAFDIR given in "iraf.h" + +On our UNIX development system we have the executables (xc.e, xpp.e, etc.) +linked into both the source directory and the IRAF library lib$. Hence when +any of these executables are relinked, the new versions do not have to +be installed. If your system does not support links you will need to copy +the executable to lib$ after compilation. diff --git a/unix/boot/spp/mkpkg.sh b/unix/boot/spp/mkpkg.sh new file mode 100644 index 00000000..71417ba7 --- /dev/null +++ b/unix/boot/spp/mkpkg.sh @@ -0,0 +1,12 @@ +# Make the Subset Preprocessor language (SPP) compiler. + +echo "----------------------- XC ----------------------------" +$CC -c $HSI_CF xc.c +$CC $HSI_LF xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../hlib +rm -f xc.o + +echo "----------------------- XPP ----------------------------" +(cd xpp; sh -x mkpkg.sh) +echo "----------------------- RPP ----------------------------" +(cd rpp; sh -x mkpkg.sh) diff --git a/unix/boot/spp/mkxc.sh b/unix/boot/spp/mkxc.sh new file mode 100644 index 00000000..853e89bc --- /dev/null +++ b/unix/boot/spp/mkxc.sh @@ -0,0 +1,6 @@ +# Make the XC driver program. + +$CC -c $HSI_CF xc.c +$CC $HSI_LF xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../hlib +rm xc.o diff --git a/unix/boot/spp/mkxc_dbg.sh b/unix/boot/spp/mkxc_dbg.sh new file mode 100644 index 00000000..c9cea5af --- /dev/null +++ b/unix/boot/spp/mkxc_dbg.sh @@ -0,0 +1,6 @@ +# Make the XC driver program. + +$CC -c -g $HSI_CF xc.c +$CC $HSI_LF -g xc.o $HSI_LIBS -o xc.e +mv -f xc.e ../../bin.redhat +rm xc.o diff --git a/unix/boot/spp/rpp/README b/unix/boot/spp/rpp/README new file mode 100644 index 00000000..a9df5096 --- /dev/null +++ b/unix/boot/spp/rpp/README @@ -0,0 +1,40 @@ +RPP -- Second pass of the SPP preprocessor. + + While RPP is derived from ratfor, it is not a ratfor preprocessor. +It accepts as input the output of the first pass, XPP, and produces Fortran as +output. XPP and RPP together with the UNIX driver program XC make up the +preprocessor for the IRAF SPP language. + + +subdirectories: + + ratlibc Interface to the host system, written in C + ratlibf Fortran version of the ratfor library (used by RPP) + ratlibr Ratfor version of the ratfor library + rppfor Fortran source for RPP + rpprat Ratfor source for RPP + + +RPP consists of the source for the program itself, the portable library +functions, and the interface to the host system. Everything required to +compile and link RPP on a host system providing a C and Fortran compiler +is included in these directories. RPP is currently implemented as a stand +alone (bootstrap) program, i.e. it can be compiled before IRAF itself is +running. While the ratfor sources for the preprocessor and the library +are included in the distribution, a ratfor preprocessor is not necessary +to compile RPP. All ratfor sources are distributed already preprocessed +into Fortran. + +To compile RPP on a UNIX host type "make". If there are any problems they +will most likely be in the interface routines, which are not (cannot be) +completely portable. In particular the definitions in ratlibc/ratdef.h +should be examined to see is they are appropriate for your machine. The +single biggest difference between different host systems providing C and +simple UNIX like STDIO is in the naming conventions of external identifiers. +All C externals called from Fortran are defined in ratdef.h to make it +easier to change the names. RPP is a C program (it has a C main) even +though most of the code is written in Fortran. + +Source for a Fortran (ratfor) version of the interface routines is provided +in ratlibr/old. Since XPP is currently written in C we have not bothered +to try to use these routines. diff --git a/unix/boot/spp/rpp/mkpkg.sh b/unix/boot/spp/rpp/mkpkg.sh new file mode 100644 index 00000000..33bc0b88 --- /dev/null +++ b/unix/boot/spp/rpp/mkpkg.sh @@ -0,0 +1,13 @@ +# Make the second pass (RPP) of the SPP language compiler. + +echo "----------------------- RPPFOR -------------------------" +(cd rppfor; sh -x mkpkg.sh) +echo "----------------------- RATLIBF ------------------------" +(cd ratlibf; sh -x mkpkg.sh) +echo "----------------------- RATLIBC ------------------------" +(cd ratlibc; sh -x mkpkg.sh) + +$CC -c $HSI_CF rpp.c +$CC $HSI_LF rpp.o librpp.a libf.a libc.a $HSI_F77LIBS -o rpp.e +mv -f rpp.e ../../../hlib +rm *.[ao] diff --git a/unix/boot/spp/rpp/ratlibc/README b/unix/boot/spp/rpp/ratlibc/README new file mode 100644 index 00000000..427e3969 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/README @@ -0,0 +1 @@ +RPP/RATLIBC -- Host system interface routines for the RPP program. diff --git a/unix/boot/spp/rpp/ratlibc/cant.c b/unix/boot/spp/rpp/ratlibc/cant.c new file mode 100644 index 00000000..2d82c3e9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/cant.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +extern int ENDST (void); + + +void CANT(rname) +register RCHAR *rname; +{ + while (*rname != REOS) + putc(*rname++, stderr); + fprintf(stderr, ": cant open\n"); + ENDST(); +} diff --git a/unix/boot/spp/rpp/ratlibc/close.c b/unix/boot/spp/rpp/ratlibc/close.c new file mode 100644 index 00000000..a54d4a80 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/close.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void CLOSE(fd) +FINT *fd; +{ + fclose(_fdtofile[*fd]); +} diff --git a/unix/boot/spp/rpp/ratlibc/endst.c b/unix/boot/spp/rpp/ratlibc/endst.c new file mode 100644 index 00000000..b8f83f3d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/endst.c @@ -0,0 +1,10 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdlib.h> +#include "ratdef.h" + +void ENDST() +{ + exit(0); +} diff --git a/unix/boot/spp/rpp/ratlibc/getarg.c b/unix/boot/spp/rpp/ratlibc/getarg.c new file mode 100644 index 00000000..2952d7d7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/getarg.c @@ -0,0 +1,28 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +FINT +GETARG(n, s, maxsiz) +FINT *n; +register RCHAR *s; +FINT *maxsiz; +{ + extern int xargc; + extern char **xargv; + register char *t; + register int i; + + if(*n>=0 && *n<xargc) + t = xargv[*n]; + else if (*n == -1) + return(xargc); + else + return(REOF); /* non-existent argument */ + + for(i = 0; i<*maxsiz-1 && *t!='\0' ; ++i) + *s++ = *t++; + *s++ = REOS; /* terminate ratfor string with eos */ + return(i); /* return length of argument */ +} diff --git a/unix/boot/spp/rpp/ratlibc/getlin.c b/unix/boot/spp/rpp/ratlibc/getlin.c new file mode 100644 index 00000000..1949f9cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/getlin.c @@ -0,0 +1,32 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +FINT +GETLIN(line, fd) +RCHAR *line; +FINT *fd; +{ + register int c=0; + register int count=0; + register RCHAR *cs; + FILE *fp; + + fp = _fdtofile[*fd]; + cs = line; + while (++count<MAXLINE && (c = getc(fp))>=0) { + *cs++ = c; + if (c == '\n') { + *cs++ = REOS; + return (count); /* count includes newline, but does + not include the EOS */ + } + } + + if (c<0 && cs==line) + return(REOF); + + *cs++ = REOS; + return(count); +} diff --git a/unix/boot/spp/rpp/ratlibc/initst.c b/unix/boot/spp/rpp/ratlibc/initst.c new file mode 100644 index 00000000..6cf4a9a4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/initst.c @@ -0,0 +1,18 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +FILE *_fdtofile[10]; + +/* + * Ratfor initialization routine. To be called as the first + * executable statement of every program using the tools + * subroutines. + */ +void INITST() +{ + _fdtofile[0] = stdin; + _fdtofile[1] = stdout; + _fdtofile[2] = stderr; +} diff --git a/unix/boot/spp/rpp/ratlibc/mkpkg.sh b/unix/boot/spp/rpp/ratlibc/mkpkg.sh new file mode 100644 index 00000000..8159d992 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/mkpkg.sh @@ -0,0 +1,9 @@ +# Host system interface for the RPP program. + +$CC -c -g $HSI_CF cant.c close.c endst.c getarg.c getlin.c initst.c open.c\ + putch.c putlin.c r4tocstr.c remark.c + +ar rv libc.a *.o +$RANLIB libc.a +mv -f libc.a .. +rm *.o diff --git a/unix/boot/spp/rpp/ratlibc/open.c b/unix/boot/spp/rpp/ratlibc/open.c new file mode 100644 index 00000000..fa4558d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/open.c @@ -0,0 +1,30 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +extern void r4tocstr (register RCHAR *rstr, register char *cstr); + +FINT +OPEN(rname, mode) +RCHAR *rname; +register FINT *mode; +{ + register FILE *fp; + char cname[FILENAMESIZE]; + + r4tocstr(rname, cname); + + if (*mode == APPEND) + fp = fopen(cname, "a"); + else if (*mode == READWRITE || *mode == WRITE) + fp = fopen(cname, "w"); + else + fp = fopen(cname, "r"); + + if (fp == NULL) + return(RERR); /* unable to open file */ + + _fdtofile[fileno(fp)] = fp; + return(fileno(fp)); +} diff --git a/unix/boot/spp/rpp/ratlibc/putch.c b/unix/boot/spp/rpp/ratlibc/putch.c new file mode 100644 index 00000000..322628cc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/putch.c @@ -0,0 +1,15 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +int PUTCH(c, fd) +register RCHAR *c; +register FINT *fd; +{ + register FILE *file; + + file = _fdtofile[*fd]; + putc(*c, file); + return 0; +} diff --git a/unix/boot/spp/rpp/ratlibc/putlin.c b/unix/boot/spp/rpp/ratlibc/putlin.c new file mode 100644 index 00000000..0da6c4d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/putlin.c @@ -0,0 +1,16 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void PUTLIN(line, fd) +RCHAR *line; +FINT *fd; +{ + register FILE *fp; + register int c; + + fp = _fdtofile[*fd]; + while((c = *line++) != REOS) + putc(c, fp); +} diff --git a/unix/boot/spp/rpp/ratlibc/r4tocstr.c b/unix/boot/spp/rpp/ratlibc/r4tocstr.c new file mode 100644 index 00000000..36924353 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/r4tocstr.c @@ -0,0 +1,22 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +/* Convert a Ratfor string (one character per integer, terminated + * by an EOS) to a C string (one character per 8-bit byte, terminated + * by a byte of zero). + */ +void r4tocstr(rstr, cstr) +register RCHAR *rstr; +register char *cstr; +{ + while (*rstr != REOS) { + if (*rstr > 0177) { + *cstr++ = *((char *)rstr); + rstr++; + } else + *cstr++ = *rstr++; + } + *cstr = '\0'; +} diff --git a/unix/boot/spp/rpp/ratlibc/ratdef.h b/unix/boot/spp/rpp/ratlibc/ratdef.h new file mode 100644 index 00000000..2f5b7e1c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/ratdef.h @@ -0,0 +1,73 @@ +#include <stdio.h> + +extern FILE *_fdtofile[]; /* map file descriptor (small integer) to + FILE pointer. Ratfor uses file descriptors, + we must use FILE pointers for stdio lib */ + +/* + * The following definitions must be the same as those used by the + * Ratfor system. + */ +#define REOF (-1) /* Ratfor EOF */ +#define REOS (-2) /* Ratfor end-of-string */ +#define RERR (-3) /* Ratfor error return */ +#define NO 0 +#define YES 1 +#define NOERR 0 +#define OK (-2) +#define MAXLINE 128 +#define FILENAMESIZE 40 /* max num chars per filename */ + +#define READ 1 /* modes for file open */ +#define WRITE 2 +#define READWRITE 3 +#define APPEND 4 + +/* + * The following typedefs refer to the data types passed by the + * Fortran compiler (Ratfor) calling us. + */ +#ifdef ILP32 +typedef int RCHAR; /* Ratfor character string */ +typedef int FINT; /* Fortran plain vanilla integer */ + /* integer*2 with new f77 on Unix */ +#else +typedef long int RCHAR; /* Ratfor character string */ +typedef long int FINT; /* Fortran plain vanilla integer */ + /* integer*2 with new f77 on Unix */ +#endif + + +/* All names of C functions called from ratfor are defined here to make them + * easy to change to reflect the characteristics of the host machine. Some + * versions of UNIX append an underscore to Fortran external names, some + * prepend an underscore, and some do both. VMS renders C and Fortran external + * names the same, making it easier to mix the two languages but causing + * name conflicts. + */ +#define AMOVE amove_ +#define CANT cant_ +#define CLOSE rfclos_ +#define CREATE create_ +#define ENDST endst_ +#define EXIT rexit_ +#define FLUSH rfflus_ +#define GETARG getarg_ +#define GETCH getch_ +#define GETLIN getlin_ +#define GETNOW getnow_ +#define INITST initst_ +#define ISATTY isatty_ +#define MKUNIQ mkuniq_ +#define NOTE rfnote_ +#define OPEN rfopen_ +#define PUTCH putch_ +#define PUTHOL puthol_ +#define PUTLIN putlin_ +#define RATFOR ratfor_ +#define READF readf_ +#define REMARK remark_ +#define REMOVE rfrmov_ +#define RWIND rwind_ +#define SEEK rfseek_ +#define WRITEF writef_ diff --git a/unix/boot/spp/rpp/ratlibc/remark.c b/unix/boot/spp/rpp/ratlibc/remark.c new file mode 100644 index 00000000..23e30213 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibc/remark.c @@ -0,0 +1,43 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratdef.h" + +void REMARK (strarg) +int *strarg; /* hollerith string is an integer array */ +{ + register char *strin = (char *)strarg; + register char c; + + while (((c = *strin++) != '.') && (c != '\0')) + if (c == '@') { + switch (*strin) { + case '.': + putc ('.', stderr); + strin++; + break; + + case 't': + putc ('\t', stderr); + strin++; + break; + + case 'b': + putc ('\b', stderr); + strin++; + break; + + case 'n': + putc ('\n', stderr); + strin++; + break; + + default: + putc ('@', stderr); + break; + } + } else + putc (c, stderr); + + putc ('\n', stderr); +} diff --git a/unix/boot/spp/rpp/ratlibf/README b/unix/boot/spp/rpp/ratlibf/README new file mode 100644 index 00000000..52be57b2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/README @@ -0,0 +1 @@ +RPP/RATLIBF -- Fortran source for the library utilities used by the RPP program. diff --git a/unix/boot/spp/rpp/ratlibf/addset.f b/unix/boot/spp/rpp/ratlibf/addset.f new file mode 100644 index 00000000..629b4b91 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/addset.f @@ -0,0 +1,13 @@ + integer function addset (c, str, j, maxsiz) + integer j, maxsiz + integer c, str (maxsiz) + if (.not.(j .gt. maxsiz))goto 23000 + addset = 0 + goto 23001 +23000 continue + str(j) = c + j = j + 1 + addset = 1 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/addstr.f b/unix/boot/spp/rpp/ratlibf/addstr.f new file mode 100644 index 00000000..eedc7cf3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/addstr.f @@ -0,0 +1,16 @@ + integer function addstr (s, str, j, maxsiz) + integer j, maxsiz + integer s (100), str (maxsiz) + integer i, addset + i = 1 +23000 if (.not.(s (i) .ne. -2))goto 23002 + if (.not.(addset (s (i), str, j, maxsiz) .eq. 0))goto 23003 + addstr = 0 + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + addstr = 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/amatch.f b/unix/boot/spp/rpp/ratlibf/amatch.f new file mode 100644 index 00000000..fe23fb53 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/amatch.f @@ -0,0 +1,68 @@ + integer function amatch (lin, from, pat, tagbeg, tagend) + integer lin (128), pat (128) + integer from, tagbeg (10), tagend (10) + integer i, j, offset, stack + integer omatch, patsiz + i = 1 +23000 if (.not.(i .le. 10))goto 23002 + tagbeg (i) = 0 + tagend (i) = 0 +23001 i = i + 1 + goto 23000 +23002 continue + tagbeg (1) = from + stack = 0 + offset = from + j = 1 +23003 if (.not.(pat (j) .ne. -2))goto 23005 + if (.not.(pat (j) .eq. 42))goto 23006 + stack = j + j = j + 4 + i = offset +23008 if (.not.(lin (i) .ne. -2))goto 23010 + if (.not.(omatch (lin, i, pat, j) .eq. 0))goto 23011 + goto 23010 +23011 continue +23009 goto 23008 +23010 continue + pat (stack + 1) = i - offset + pat (stack + 3) = offset + offset = i + goto 23007 +23006 continue + if (.not.(pat (j) .eq. 123))goto 23013 + i = pat (j + 1) + tagbeg (i + 1) = offset + goto 23014 +23013 continue + if (.not.(pat (j) .eq. 125))goto 23015 + i = pat (j + 1) + tagend (i + 1) = offset + goto 23016 +23015 continue + if (.not.(omatch (lin, offset, pat, j) .eq. 0))goto 23017 +23019 if (.not.(stack .gt. 0))goto 23021 + if (.not.(pat (stack + 1) .gt. 0))goto 23022 + goto 23021 +23022 continue +23020 stack = pat (stack + 2) + goto 23019 +23021 continue + if (.not.(stack .le. 0))goto 23024 + amatch = 0 + return +23024 continue + pat (stack + 1) = pat (stack + 1) - 1 + j = stack + 4 + offset = pat (stack + 3) + pat (stack + 1) +23017 continue +23016 continue +23014 continue +23007 continue +23004 j = j + patsiz (pat, j) + goto 23003 +23005 continue + amatch = offset + tagend (1) = offset + return + end diff --git a/unix/boot/spp/rpp/ratlibf/catsub.f b/unix/boot/spp/rpp/ratlibf/catsub.f new file mode 100644 index 00000000..a7dbc318 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/catsub.f @@ -0,0 +1,28 @@ + subroutine catsub (lin, from, to, sub, new, k, maxnew) + integer lin(128) + integer from(10), to(10) + integer maxnew + integer sub(maxnew), new(128) + integer k + integer i, j, junk, ri + integer addset + i = 1 +23000 if (.not.(sub (i) .ne. -2))goto 23002 + if (.not.(sub (i) .eq. -3))goto 23003 + i = i + 1 + ri = sub (i) + 1 + j = from (ri) +23005 if (.not.(j .lt. to (ri)))goto 23007 + junk = addset (lin (j), new, k, maxnew) +23006 j = j + 1 + goto 23005 +23007 continue + goto 23004 +23003 continue + junk = addset (sub (i), new, k, maxnew) +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/clower.f b/unix/boot/spp/rpp/ratlibf/clower.f new file mode 100644 index 00000000..e001f4fd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/clower.f @@ -0,0 +1,12 @@ + integer function clower(c) + integer c + integer k + if (.not.(c .ge. 65 .and. c .le. 90))goto 23000 + k = 97 - 65 + clower = c + k + goto 23001 +23000 continue + clower = c +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/concat.f b/unix/boot/spp/rpp/ratlibf/concat.f new file mode 100644 index 00000000..9385f2d1 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/concat.f @@ -0,0 +1,8 @@ + subroutine concat (buf1, buf2, outstr) + integer buf1(100), buf2(100), outstr(100) + integer i + i = 1 + call stcopy (buf1, 1, outstr, i) + call scopy (buf2, 1, outstr, i) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctoc.f b/unix/boot/spp/rpp/ratlibf/ctoc.f new file mode 100644 index 00000000..a5d3d4b3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctoc.f @@ -0,0 +1,14 @@ + integer function ctoc (from, to, len) + integer len + integer from (100), to (len) + integer i + i = 1 +23000 if (.not.(i .lt. len .and. from (i) .ne. -2))goto 23002 + to (i) = from (i) +23001 i = i + 1 + goto 23000 +23002 continue + to (i) = -2 + ctoc=(i - 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctoi.f b/unix/boot/spp/rpp/ratlibf/ctoi.f new file mode 100644 index 00000000..8aa92061 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctoi.f @@ -0,0 +1,26 @@ + integer function ctoi(in, i) + integer in (100) + integer i + integer d + external index + integer index + integer digits(11) + data digits (1) /48/, digits (2) /49/, digits (3) /50/, digits (4) + * /51/, digits (5) /52/, digits (6) /53/, digits (7) /54/, digits ( + *8) /55/, digits (9) /56/, digits (10) /57/, digits (11) /-2/ +23000 if (.not.(in (i) .eq. 32 .or. in (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + ctoi = 0 +23002 if (.not.(in (i) .ne. -2))goto 23004 + d = index (digits, in (i)) + if (.not.(d .eq. 0))goto 23005 + goto 23004 +23005 continue + ctoi = 10 * ctoi + d - 1 +23003 i = i + 1 + goto 23002 +23004 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/ctomn.f b/unix/boot/spp/rpp/ratlibf/ctomn.f new file mode 100644 index 00000000..a2e0294e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/ctomn.f @@ -0,0 +1,30 @@ + integer function ctomn (c, rep) + integer c, rep (4) + integer i + integer length + integer mntext (136) + data mntext / 78, 85, 76, -2, 83, 79, 72, -2, 83, 84, 88, -2, 69, + * 84, 88, -2, 69, 79, 84, -2, 69, 78, 81, -2, 65, 67, 75, -2, 66, 6 + *9, 76, -2, 66, 83, -2, -2, 72, 84, -2, -2, 76, 70, -2, -2, 86, 84, + * -2, -2, 70, 70, -2, -2, 67, 82, -2, -2, 83, 79, -2, -2, 83, 73, - + *2, -2, 68, 76, 69, -2, 68, 67, 49, -2, 68, 67, 50, -2, 68, 67, 51, + * -2, 68, 67, 52, -2, 78, 65, 75, -2, 83, 89, 78, -2, 69, 84, 66, - + *2, 67, 65, 78, -2, 69, 77, -2, -2, 83, 85, 66, -2, 69, 83, 67, -2, + * 70, 83, -2, -2, 71, 83, -2, -2, 82, 83, -2, -2, 85, 83, -2, -2, 8 + *3, 80, -2, -2, 68, 69, 76, -2/ + i = mod (max0(c,0), 128) + if (.not.(0 .le. i .and. i .le. 32))goto 23000 + call scopy (mntext, 4 * i + 1, rep, 1) + goto 23001 +23000 continue + if (.not.(i .eq. 127))goto 23002 + call scopy (mntext, 133, rep, 1) + goto 23003 +23002 continue + rep (1) = c + rep (2) = -2 +23003 continue +23001 continue + ctomn=(length (rep)) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/cupper.f b/unix/boot/spp/rpp/ratlibf/cupper.f new file mode 100644 index 00000000..549ee9df --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/cupper.f @@ -0,0 +1,10 @@ + integer function cupper (c) + integer c + if (.not.(c .ge. 97 .and. c .le. 122))goto 23000 + cupper = c + (65 - 97) + goto 23001 +23000 continue + cupper = c +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/delete.f b/unix/boot/spp/rpp/ratlibf/delete.f new file mode 100644 index 00000000..92d5fb37 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/delete.f @@ -0,0 +1,13 @@ + subroutine delete (symbol, st) + integer symbol (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer stlu + integer node, pred + if (.not.(stlu (symbol, node, pred, st) .eq. 1))goto 23000 + mem (pred + 0) = mem (node + 0) + call dsfree (node) +23000 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/docant.f b/unix/boot/spp/rpp/ratlibf/docant.f new file mode 100644 index 00000000..0bcdd7ca --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/docant.f @@ -0,0 +1,13 @@ + subroutine docant(name) + integer name(100), prog(30) + integer length + integer getarg + length = getarg(0, prog, 30) + if (.not.(length .ne. -1))goto 23000 + call putlin(prog, 2) + call putch(58, 2) + call putch(32, 2) +23000 continue + call cant(name) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dodash.f b/unix/boot/spp/rpp/ratlibf/dodash.f new file mode 100644 index 00000000..63dd7e48 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dodash.f @@ -0,0 +1,18 @@ + subroutine dodash (valid, array, i, set, j, maxset) + integer i, j, maxset + integer valid (100), array (100), set (maxset) + integer esc + integer junk, k, limit + external index + integer addset, index + i = i + 1 + j = j - 1 + limit = index (valid, esc (array, i)) + k = index (valid, set (j)) +23000 if (.not.(k .le. limit))goto 23002 + junk = addset (valid (k), set, j, maxset) +23001 k = k + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsdbiu.f b/unix/boot/spp/rpp/ratlibf/dsdbiu.f new file mode 100644 index 00000000..62efd56e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsdbiu.f @@ -0,0 +1,47 @@ + subroutine dsdbiu (b, form) + integer b + integer form + integer mem( 1) + common/cdsmem/mem + integer l, s, lmax + integer blanks(6) + data blanks(1)/9/,blanks(2)/32/,blanks(3)/32/,blanks(4)/32/,blanks + *(5)/32/,blanks(6)/-2/ + call putint (b, 5, 2) + call putch (32, 2) + call putint (mem (b + 0), 0, 2) + call remark (14H words in use.) + l = 0 + s = b + mem (b + 0) + if (.not.(form .eq. 48))goto 23000 + lmax = 5 + goto 23001 +23000 continue + lmax = 50 +23001 continue + b = b + 2 +23002 if (.not.(b .lt. s))goto 23004 + if (.not.(l .eq. 0))goto 23005 + call putlin (blanks, 2) +23005 continue + if (.not.(form .eq. 48))goto 23007 + call putint (mem (b), 10, 2) + goto 23008 +23007 continue + if (.not.(form .eq. 97))goto 23009 + call putch (mem (b), 2) +23009 continue +23008 continue + l = l + 1 + if (.not.(l .ge. lmax))goto 23011 + l = 0 + call putch (10, 2) +23011 continue +23003 b = b + 1 + goto 23002 +23004 continue + if (.not.(l .ne. 0))goto 23013 + call putch (10, 2) +23013 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsdump.f b/unix/boot/spp/rpp/ratlibf/dsdump.f new file mode 100644 index 00000000..366bd5c4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsdump.f @@ -0,0 +1,28 @@ + subroutine dsdump (form) + integer form + integer mem( 1) + common/cdsmem/mem + integer p, t, q + t = 2 + call remark (27H** DYNAMIC STORAGE DUMP **.) + call putint (1, 5, 2) + call putch (32, 2) + call putint (2 + 1, 0, 2) + call remark (14H words in use.) + p = mem (t + 1) +23000 if (.not.(p .ne. 0))goto 23001 + call putint (p, 5, 2) + call putch (32, 2) + call putint (mem (p + 0), 0, 2) + call remark (17H words available.) + q = p + mem (p + 0) +23002 if (.not.(q .ne. mem (p + 1) .and. q .lt. mem (1)))goto 23003 + call dsdbiu (q, form) + goto 23002 +23003 continue + p = mem (p + 1) + goto 23000 +23001 continue + call remark (15H** END DUMP **.) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsfree.f b/unix/boot/spp/rpp/ratlibf/dsfree.f new file mode 100644 index 00000000..8ab2f2a0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsfree.f @@ -0,0 +1,44 @@ + subroutine dsfree (block) + integer block + integer mem( 1) + common/cdsmem/mem + integer p0, p, q + integer n, junk + integer con (10) + p0 = block - 2 + n = mem (p0 + 0) + q = 2 +23000 continue + p = mem (q + 1) + if (.not.(p .eq. 0 .or. p .gt. p0))goto 23003 + goto 23002 +23003 continue + q = p +23001 goto 23000 +23002 continue + if (.not.(q + mem (q + 0) .gt. p0))goto 23005 + call remark (45Hin dsfree: attempt to free unallocated block.) + call remark (21Htype 'c' to continue.) + junk = getlin (con, 0) + if (.not.(con (1) .ne. 99 .and. con (1) .ne. 67))goto 23007 + call endst +23007 continue + return +23005 continue + if (.not.(p0 + n .eq. p .and. p .ne. 0))goto 23009 + n = n + mem (p + 0) + mem (p0 + 1) = mem (p + 1) + goto 23010 +23009 continue + mem (p0 + 1) = p +23010 continue + if (.not.(q + mem (q + 0) .eq. p0))goto 23011 + mem (q + 0) = mem (q + 0) + n + mem (q + 1) = mem (p0 + 1) + goto 23012 +23011 continue + mem (q + 1) = p0 + mem (p0 + 0) = n +23012 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsget.f b/unix/boot/spp/rpp/ratlibf/dsget.f new file mode 100644 index 00000000..ef4fbcfe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsget.f @@ -0,0 +1,45 @@ + integer function dsget (w) + integer w + integer mem( 1) + common/cdsmem/mem + integer p, q, l + integer n, k, junk + integer getlin + integer c (10) + n = w + 2 + q = 2 +23000 continue + p = mem (q + 1) + if (.not.(p .eq. 0))goto 23003 + call remark (31Hin dsget: out of storage space.) + call remark (41Htype 'c' or 'i' for char or integer dump.) + junk = getlin (c, 0) + if (.not.(c (1) .eq. 99 .or. c (1) .eq. 67))goto 23005 + call dsdump (97) + goto 23006 +23005 continue + if (.not.(c (1) .eq. 105 .or. c (1) .eq. 73))goto 23007 + call dsdump (48) +23007 continue +23006 continue + call error (19Hprogram terminated.) +23003 continue + if (.not.(mem (p + 0) .ge. n))goto 23009 + goto 23002 +23009 continue + q = p +23001 goto 23000 +23002 continue + k = mem (p + 0) - n + if (.not.(k .ge. 8))goto 23011 + mem (p + 0) = k + l = p + k + mem (l + 0) = n + goto 23012 +23011 continue + mem (q + 1) = mem (p + 1) + l = p +23012 continue + dsget=(l + 2) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/dsinit.f b/unix/boot/spp/rpp/ratlibf/dsinit.f new file mode 100644 index 00000000..9eb0ebad --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/dsinit.f @@ -0,0 +1,17 @@ + subroutine dsinit (w) + integer w + integer mem( 1) + common/cdsmem/mem + integer t + if (.not.(w .lt. 2 * 2 + 2))goto 23000 + call error (42Hin dsinit: unreasonably small memory size.) +23000 continue + t = 2 + mem (t + 0) = 0 + mem (t + 1) = 2 + 2 + t = 2 + 2 + mem (t + 0) = w - 2 - 1 + mem (t + 1) = 0 + mem (1) = w + return + end diff --git a/unix/boot/spp/rpp/ratlibf/enter.f b/unix/boot/spp/rpp/ratlibf/enter.f new file mode 100644 index 00000000..6711c57d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/enter.f @@ -0,0 +1,34 @@ + subroutine enter (symbol, info, st) + integer symbol (100) + integer info (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer i, nodsiz, j + integer stlu, length + integer node, pred + integer dsget + nodsiz = mem (st) + if (.not.(stlu (symbol, node, pred, st) .eq. 0))goto 23000 + node = dsget (1 + nodsiz + length (symbol) + 1) + mem (node + 0) = 0 + mem (pred + 0) = node + i = 1 + j = node + 1 + nodsiz +23002 if (.not.(symbol (i) .ne. -2))goto 23003 + mem (j) = symbol (i) + i = i + 1 + j = j + 1 + goto 23002 +23003 continue + mem (j) = -2 +23000 continue + i = 1 +23004 if (.not.(i .le. nodsiz))goto 23006 + j = node + 1 + i - 1 + mem (j) = info (i) +23005 i = i + 1 + goto 23004 +23006 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/equal.f b/unix/boot/spp/rpp/ratlibf/equal.f new file mode 100644 index 00000000..1148779c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/equal.f @@ -0,0 +1,15 @@ + integer function equal (str1, str2) + integer str1(100), str2(100) + integer i + i = 1 +23000 if (.not.(str1 (i) .eq. str2 (i)))goto 23002 + if (.not.(str1 (i) .eq. -2))goto 23003 + equal=(1) + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + equal=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/error.f b/unix/boot/spp/rpp/ratlibf/error.f new file mode 100644 index 00000000..f4e15821 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/error.f @@ -0,0 +1,5 @@ + subroutine error (line) + integer line (100) + call remark (line) + call endst + end diff --git a/unix/boot/spp/rpp/ratlibf/errsub.f b/unix/boot/spp/rpp/ratlibf/errsub.f new file mode 100644 index 00000000..63aa3c0e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/errsub.f @@ -0,0 +1,22 @@ + integer function errsub (arg, file, access) + integer arg (100), file (100) + integer access + if (.not.(arg (1) .eq. 63 .and. arg (2) .ne. 63 .and. arg (2) .ne. + * -2))goto 23000 + errsub = 1 + access = 2 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + if (.not.(arg (1) .eq. 63 .and. arg (2) .eq. 63 .and. arg (3) .ne. + * -2))goto 23002 + errsub = 1 + access = 4 + call scopy (arg, 3, file, 1) + goto 23003 +23002 continue + errsub = 0 +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/esc.f b/unix/boot/spp/rpp/ratlibf/esc.f new file mode 100644 index 00000000..fd3ce7fe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/esc.f @@ -0,0 +1,27 @@ + integer function esc (array, i) + integer array (100) + integer i + if (.not.(array (i) .ne. 64))goto 23000 + esc = array (i) + goto 23001 +23000 continue + if (.not.(array (i+1) .eq. -2))goto 23002 + esc = 64 + goto 23003 +23002 continue + i = i + 1 + if (.not.(array (i) .eq. 110 .or. array (i) .eq. 78))goto 23004 + esc = 10 + goto 23005 +23004 continue + if (.not.(array (i) .eq. 116 .or. array (i) .eq. 84))goto 23006 + esc = 9 + goto 23007 +23006 continue + esc = array (i) +23007 continue +23005 continue +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fcopy.f b/unix/boot/spp/rpp/ratlibf/fcopy.f new file mode 100644 index 00000000..6c63dad8 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fcopy.f @@ -0,0 +1,10 @@ + subroutine fcopy (in, out) + integer in, out + integer line (128) + integer getlin +23000 if (.not.(getlin (line, in) .ne. -1))goto 23001 + call putlin (line, out) + goto 23000 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/filset.f b/unix/boot/spp/rpp/ratlibf/filset.f new file mode 100644 index 00000000..d5ada767 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/filset.f @@ -0,0 +1,63 @@ + subroutine filset (delim, array, i, set, j, maxset) + integer i, j, maxset + integer array (100), delim, set (maxset) + integer esc + integer junk + external index + integer addset, index + integer digits(11) + integer lowalf(27) + integer upalf(27) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + data lowalf(1)/97/,lowalf(2)/98/,lowalf(3)/99/,lowalf(4)/100/,lowa + *lf(5)/101/,lowalf(6)/102/,lowalf(7)/103/,lowalf(8)/104/,lowalf(9)/ + *105/,lowalf(10)/106/,lowalf(11)/107/,lowalf(12)/108/,lowalf(13)/10 + *9/,lowalf(14)/110/,lowalf(15)/111/,lowalf(16)/112/,lowalf(17)/113/ + *,lowalf(18)/114/,lowalf(19)/115/,lowalf(20)/116/,lowalf(21)/117/,l + *owalf(22)/118/,lowalf(23)/119/,lowalf(24)/120/,lowalf(25)/121/,low + *alf(26)/122/,lowalf(27)/-2/ + data upalf(1)/65/,upalf(2)/66/,upalf(3)/67/,upalf(4)/68/,upalf(5)/ + *69/,upalf(6)/70/,upalf(7)/71/,upalf(8)/72/,upalf(9)/73/,upalf(10)/ + *74/,upalf(11)/75/,upalf(12)/76/,upalf(13)/77/,upalf(14)/78/,upalf( + *15)/79/,upalf(16)/80/,upalf(17)/81/,upalf(18)/82/,upalf(19)/83/,up + *alf(20)/84/,upalf(21)/85/,upalf(22)/86/,upalf(23)/87/,upalf(24)/88 + */,upalf(25)/89/,upalf(26)/90/,upalf(27)/-2/ +23000 if (.not.(array (i) .ne. delim .and. array (i) .ne. -2))goto 23002 + if (.not.(array (i) .eq. 64))goto 23003 + junk = addset (esc (array, i), set, j, maxset) + goto 23004 +23003 continue + if (.not.(array (i) .ne. 45))goto 23005 + junk = addset (array (i), set, j, maxset) + goto 23006 +23005 continue + if (.not.(j .le. 1 .or. array (i + 1) .eq. -2))goto 23007 + junk = addset (45, set, j, maxset) + goto 23008 +23007 continue + if (.not.(index (digits, set (j - 1)) .gt. 0))goto 23009 + call dodash (digits, array, i, set, j, maxset) + goto 23010 +23009 continue + if (.not.(index (lowalf, set (j - 1)) .gt. 0))goto 23011 + call dodash (lowalf, array, i, set, j, maxset) + goto 23012 +23011 continue + if (.not.(index (upalf, set (j - 1)) .gt. 0))goto 23013 + call dodash (upalf, array, i, set, j, maxset) + goto 23014 +23013 continue + junk = addset (45, set, j, maxset) +23014 continue +23012 continue +23010 continue +23008 continue +23006 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fmtdat.f b/unix/boot/spp/rpp/ratlibf/fmtdat.f new file mode 100644 index 00000000..7a81c9c8 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fmtdat.f @@ -0,0 +1,23 @@ + subroutine fmtdat(date, time, now, form) + integer date(100), time(100) + integer now(7), form + date(1) = now(2) / 10 + 48 + date(2) = mod(now(2), 10) + 48 + date(3) = 47 + date(4) = now(3) / 10 + 48 + date(5) = mod(now(3), 10) + 48 + date(6) = 47 + date(7) = mod(now(1), 100) / 10 + 48 + date(8) = mod(now(1), 10) + 48 + date(9) = -2 + time(1) = now(4) / 10 + 48 + time(2) = mod(now(4), 10) + 48 + time(3) = 58 + time(4) = now(5) / 10 + 48 + time(5) = mod(now(5), 10) + 48 + time(6) = 58 + time(7) = now(6) / 10 + 48 + time(8) = mod(now(6), 10) + 48 + time(9) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/fold.f b/unix/boot/spp/rpp/ratlibf/fold.f new file mode 100644 index 00000000..187bb721 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/fold.f @@ -0,0 +1,12 @@ + subroutine fold (token) + integer token (100) + integer clower + integer i + i = 1 +23000 if (.not.(token (i) .ne. -2))goto 23002 + token (i) = clower (token (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/gctoi.f b/unix/boot/spp/rpp/ratlibf/gctoi.f new file mode 100644 index 00000000..93ac3b6d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/gctoi.f @@ -0,0 +1,61 @@ + integer function gctoi (str, i, radix) + integer str (100) + integer i, radix + integer base, v, d, j + external index + integer index + integer clower + logical neg + integer digits(17) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/97/,digits(12)/98/,digits(13)/99/,digits( + *14)/100/,digits(15)/101/,digits(16)/102/,digits(17)/-2/ + v = 0 + base = radix +23000 if (.not.(str (i) .eq. 32 .or. str (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + neg = (str (i) .eq. 45) + if (.not.(str (i) .eq. 43 .or. str (i) .eq. 45))goto 23002 + i = i + 1 +23002 continue + if (.not.(str (i + 2) .eq. 114 .and. str (i) .eq. 49 .and. (48.le. + *str (i + 1).and.str (i + 1).le.57) .or. str (i + 1) .eq. 114 .and. + * (48.le.str (i).and.str (i).le.57)))goto 23004 + base = str (i) - 48 + j = i + if (.not.(str (i + 1) .ne. 114))goto 23006 + j = j + 1 + base = base * 10 + (str (j) - 48) +23006 continue + if (.not.(base .lt. 2 .or. base .gt. 16))goto 23008 + base = radix + goto 23009 +23008 continue + i = j + 2 +23009 continue +23004 continue +23010 if (.not.(str (i) .ne. -2))goto 23012 + if (.not.((48.le.str (i).and.str (i).le.57)))goto 23013 + d = str (i) - 48 + goto 23014 +23013 continue + d = index (digits, clower (str (i))) - 1 +23014 continue + if (.not.(d .lt. 0 .or. d .ge. base))goto 23015 + goto 23012 +23015 continue + v = v * base + d +23011 i = i + 1 + goto 23010 +23012 continue + if (.not.(neg))goto 23017 + gctoi=(-v) + return +23017 continue + gctoi=(+v) + return +23018 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/getc.f b/unix/boot/spp/rpp/ratlibf/getc.f new file mode 100644 index 00000000..1dfabd93 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getc.f @@ -0,0 +1,6 @@ + integer function getc (c) + integer c + integer getch + getc = getch (c, 0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getccl.f b/unix/boot/spp/rpp/ratlibf/getccl.f new file mode 100644 index 00000000..67ac73fa --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getccl.f @@ -0,0 +1,25 @@ + integer function getccl (arg, i, pat, j) + integer arg (128), pat (128) + integer i, j + integer jstart, junk + integer addset + i = i + 1 + if (.not.(arg (i) .eq. 126))goto 23000 + junk = addset (110, pat, j, 128) + i = i + 1 + goto 23001 +23000 continue + junk = addset (91, pat, j, 128) +23001 continue + jstart = j + junk = addset (0, pat, j, 128) + call filset (93, arg, i, pat, j, 128) + pat (jstart) = j - jstart - 1 + if (.not.(arg (i) .eq. 93))goto 23002 + getccl = -2 + goto 23003 +23002 continue + getccl = -3 +23003 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getpat.f b/unix/boot/spp/rpp/ratlibf/getpat.f new file mode 100644 index 00000000..02d00ace --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getpat.f @@ -0,0 +1,6 @@ + integer function getpat (str, pat) + integer str (100), pat (100) + integer makpat + getpat=(makpat (str, 1, -2, pat)) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/getwrd.f b/unix/boot/spp/rpp/ratlibf/getwrd.f new file mode 100644 index 00000000..f1c0f8d7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/getwrd.f @@ -0,0 +1,20 @@ + integer function getwrd (in, i, out) + integer in (100), out (100) + integer i + integer j +23000 if (.not.(in (i) .eq. 32 .or. in (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + j = 1 +23002 if (.not.(in (i) .ne. -2 .and. in (i) .ne. 32 .and. in (i) .ne. 9 + *.and. in (i) .ne. 10))goto 23003 + out (j) = in (i) + i = i + 1 + j = j + 1 + goto 23002 +23003 continue + out (j) = -2 + getwrd = j - 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/gfnarg.f b/unix/boot/spp/rpp/ratlibf/gfnarg.f new file mode 100644 index 00000000..19d4655d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/gfnarg.f @@ -0,0 +1,142 @@ + integer function gfnarg (name, state) + integer name (100) + integer state (4) + integer l + integer getarg, getlin + integer fd + integer rfopen + integer in1(12) + integer in2(12) + integer in3(12) + data in1(1)/47/,in1(2)/100/,in1(3)/101/,in1(4)/118/,in1(5)/47/,in1 + *(6)/115/,in1(7)/116/,in1(8)/100/,in1(9)/105/,in1(10)/110/,in1(11)/ + *49/,in1(12)/-2/ + data in2(1)/47/,in2(2)/100/,in2(3)/101/,in2(4)/118/,in2(5)/47/,in2 + *(6)/115/,in2(7)/116/,in2(8)/100/,in2(9)/105/,in2(10)/110/,in2(11)/ + *50/,in2(12)/-2/ + data in3(1)/47/,in3(2)/100/,in3(3)/101/,in3(4)/118/,in3(5)/47/,in3 + *(6)/115/,in3(7)/116/,in3(8)/100/,in3(9)/105/,in3(10)/110/,in3(11)/ + *51/,in3(12)/-2/ +23000 continue + if (.not.(state (1) .eq. 1))goto 23003 + state (1) = 2 + state (2) = 1 + state (3) = -3 + state (4) = 0 + goto 23004 +23003 continue + if (.not.(state (1) .eq. 2))goto 23005 + if (.not.(getarg (state (2), name, 128) .ne. -1))goto 23007 + state (1) = 2 + state (2) = state (2) + 1 + if (.not.(name (1) .ne. 45))goto 23009 + state (4) = state (4) + 1 + gfnarg=(-2) + return +23009 continue + if (.not.(name (2) .eq. -2))goto 23011 + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23011 continue + if (.not.(name (2) .eq. 49 .and. name (3) .eq. -2))goto 23013 + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23013 continue + if (.not.(name (2) .eq. 50 .and. name (3) .eq. -2))goto 23015 + call scopy (in2, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23015 continue + if (.not.(name (2) .eq. 51 .and. name (3) .eq. -2))goto 23017 + call scopy (in3, 1, name, 1) + state (4) = state (4) + 1 + gfnarg=(-2) + return +23017 continue + if (.not.(name (2) .eq. 110 .or. name (2) .eq. 78))goto 23019 + state (1) = 3 + if (.not.(name (3) .eq. -2))goto 23021 + state (3) = 0 + goto 23022 +23021 continue + if (.not.(name (3) .eq. 49 .and. name (4) .eq. -2))goto 23023 + state (3) = stdin1 + goto 23024 +23023 continue + if (.not.(name (3) .eq. 50 .and. name (4) .eq. -2))goto 23025 + state (3) = stdin2 + goto 23026 +23025 continue + if (.not.(name (3) .eq. 51 .and. name (4) .eq. -2))goto 23027 + state (3) = stdin3 + goto 23028 +23027 continue + state (3) = rfopen(name (3), 1) + if (.not.(state (3) .eq. -3))goto 23029 + call putlin (name, 2) + call remark (14H: can't open.) + state (1) = 2 +23029 continue +23028 continue +23026 continue +23024 continue +23022 continue + goto 23020 +23019 continue + gfnarg=(-3) + return +23020 continue +23018 continue +23016 continue +23014 continue +23012 continue +23010 continue + goto 23008 +23007 continue + state (1) = 4 +23008 continue + goto 23006 +23005 continue + if (.not.(state (1) .eq. 3))goto 23031 + l = getlin (name, state (3)) + if (.not.(l .ne. -1))goto 23033 + name (l) = -2 + state (4) = state (4) + 1 + gfnarg=(-2) + return +23033 continue + if (.not.(fd .ne. -3 .and. fd .ne. 0))goto 23035 + call rfclos(state (3)) +23035 continue + state (1) = 2 + goto 23032 +23031 continue + if (.not.(state (1) .eq. 4))goto 23037 + state (1) = 5 + if (.not.(state (4) .eq. 0))goto 23039 + call scopy (in1, 1, name, 1) + gfnarg=(-2) + return +23039 continue + goto 23002 +23037 continue + if (.not.(state (1) .eq. 5))goto 23041 + goto 23002 +23041 continue + call error (32Hin gfnarg: bad state (1) value.) +23042 continue +23038 continue +23032 continue +23006 continue +23004 continue +23001 goto 23000 +23002 continue + name (1) = -2 + gfnarg=(-1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/index.f b/unix/boot/spp/rpp/ratlibf/index.f new file mode 100644 index 00000000..d5978954 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/index.f @@ -0,0 +1,13 @@ + integer function index (str, c) + integer str (100), c + index = 1 +23000 if (.not.(str (index) .ne. -2))goto 23002 + if (.not.(str (index) .eq. c))goto 23003 + return +23003 continue +23001 index = index + 1 + goto 23000 +23002 continue + index = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/insub.f b/unix/boot/spp/rpp/ratlibf/insub.f new file mode 100644 index 00000000..72e50ff1 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/insub.f @@ -0,0 +1,11 @@ + integer function insub (arg, file) + integer arg (100), file (100) + if (.not.(arg (1) .eq. 60 .and. arg (2) .ne. -2))goto 23000 + insub = 1 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + insub = 0 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/itoc.f b/unix/boot/spp/rpp/ratlibf/itoc.f new file mode 100644 index 00000000..3ceea6a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/itoc.f @@ -0,0 +1,35 @@ + integer function itoc (int, str, size) + integer int, size + integer str (100) + integer mod + integer d, i, intval, j, k + integer digits (11) + data digits (1) /48/, digits (2) /49/, digits (3) /50/, digits (4) + * /51/, digits (5) /52/, digits (6) /53/, digits (7) /54/, digits ( + *8) /55/, digits (9) /56/, digits (10) /57/, digits (11) /-2/ + intval = iabs (int) + str (1) = -2 + i = 1 +23000 continue + i = i + 1 + d = mod (intval, 10) + str (i) = digits (d+1) + intval = intval / 10 +23001 if (.not.(intval .eq. 0 .or. i .ge. size))goto 23000 +23002 continue + if (.not.(int .lt. 0 .and. i .lt. size))goto 23003 + i = i + 1 + str (i) = 45 +23003 continue + itoc = i - 1 + j = 1 +23005 if (.not.(j .lt. i))goto 23007 + k = str (i) + str (i) = str (j) + str (j) = k + i = i - 1 +23006 j = j + 1 + goto 23005 +23007 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/length.f b/unix/boot/spp/rpp/ratlibf/length.f new file mode 100644 index 00000000..4bf20e40 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/length.f @@ -0,0 +1,9 @@ + integer function length (str) + integer str (100) + length = 0 +23000 if (.not.(str (length+1) .ne. -2))goto 23002 +23001 length = length + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/locate.f b/unix/boot/spp/rpp/ratlibf/locate.f new file mode 100644 index 00000000..6db95e25 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/locate.f @@ -0,0 +1,16 @@ + integer function locate (c, pat, offset) + integer c, pat (128) + integer offset + integer i + i = offset + pat (offset) +23000 if (.not.(i .gt. offset))goto 23002 + if (.not.(c .eq. pat (i)))goto 23003 + locate=(1) + return +23003 continue +23001 i = i - 1 + goto 23000 +23002 continue + locate=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/lookup.f b/unix/boot/spp/rpp/ratlibf/lookup.f new file mode 100644 index 00000000..f70e9842 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/lookup.f @@ -0,0 +1,24 @@ + integer function lookup (symbol, info, st) + integer symbol (100) + integer info (100) + integer st + integer mem( 1) + common/cdsmem/mem + integer i, nodsiz, kluge + integer stlu + integer node, pred + if (.not.(stlu (symbol, node, pred, st) .eq. 0))goto 23000 + lookup = 0 + return +23000 continue + nodsiz = mem (st) + i = 1 +23002 if (.not.(i .le. nodsiz))goto 23004 + kluge = node + 1 - 1 + i + info (i) = mem (kluge) +23003 i = i + 1 + goto 23002 +23004 continue + lookup = 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/lower.f b/unix/boot/spp/rpp/ratlibf/lower.f new file mode 100644 index 00000000..b3550701 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/lower.f @@ -0,0 +1,5 @@ + subroutine lower (token) + integer token (100) + call fold (token) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/makpat.f b/unix/boot/spp/rpp/ratlibf/makpat.f new file mode 100644 index 00000000..27744665 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/makpat.f @@ -0,0 +1,90 @@ + integer function makpat (arg, from, delim, pat) + integer arg (128), delim, pat (128) + integer from + integer esc + integer i, j, junk, lastcl, lastj, lj, tagnst, tagnum, tagstk (9) + integer addset, getccl, stclos + j = 1 + lastj = 1 + lastcl = 0 + tagnum = 0 + tagnst = 0 + i = from +23000 if (.not.(arg (i) .ne. delim .and. arg (i) .ne. -2))goto 23002 + lj = j + if (.not.(arg (i) .eq. 63))goto 23003 + junk = addset (63, pat, j, 128) + goto 23004 +23003 continue + if (.not.(arg (i) .eq. 37 .and. i .eq. from))goto 23005 + junk = addset (37, pat, j, 128) + goto 23006 +23005 continue + if (.not.(arg (i) .eq. 36 .and. arg (i + 1) .eq. delim))goto 23007 + junk = addset (36, pat, j, 128) + goto 23008 +23007 continue + if (.not.(arg (i) .eq. 91))goto 23009 + if (.not.(getccl (arg, i, pat, j) .eq. -3))goto 23011 + makpat = -3 + return +23011 continue + goto 23010 +23009 continue + if (.not.(arg (i) .eq. 42 .and. i .gt. from))goto 23013 + lj = lastj + if (.not.(pat (lj) .eq. 37 .or. pat (lj) .eq. 36 .or. pat (lj) .eq + *. 42 .or. pat (lj) .eq. 123 .or. pat (lj) .eq. 125))goto 23015 + goto 23002 +23015 continue + lastcl = stclos (pat, j, lastj, lastcl) + goto 23014 +23013 continue + if (.not.(arg (i) .eq. 123))goto 23017 + if (.not.(tagnum .ge. 9))goto 23019 + goto 23002 +23019 continue + tagnum = tagnum + 1 + tagnst = tagnst + 1 + tagstk (tagnst) = tagnum + junk = addset (123, pat, j, 128) + junk = addset (tagnum, pat, j, 128) + goto 23018 +23017 continue + if (.not.(arg (i) .eq. 125 .and. tagnst .gt. 0))goto 23021 + junk = addset (125, pat, j, 128) + junk = addset (tagstk (tagnst), pat, j, 128) + tagnst = tagnst - 1 + goto 23022 +23021 continue + junk = addset (97, pat, j, 128) + junk = addset (esc (arg, i), pat, j, 128) +23022 continue +23018 continue +23014 continue +23010 continue +23008 continue +23006 continue +23004 continue + lastj = lj +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(arg (i) .ne. delim))goto 23023 + makpat = -3 + goto 23024 +23023 continue + if (.not.(addset (-2, pat, j, 128) .eq. 0))goto 23025 + makpat = -3 + goto 23026 +23025 continue + if (.not.(tagnst .ne. 0))goto 23027 + makpat = -3 + goto 23028 +23027 continue + makpat = i +23028 continue +23026 continue +23024 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/maksub.f b/unix/boot/spp/rpp/ratlibf/maksub.f new file mode 100644 index 00000000..176c5321 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/maksub.f @@ -0,0 +1,40 @@ + integer function maksub (arg, from, delim, sub) + integer arg (128), delim, sub (128) + integer from + integer esc, type + integer i, j, junk + integer addset + j = 1 + i = from +23000 if (.not.(arg (i) .ne. delim .and. arg (i) .ne. -2))goto 23002 + if (.not.(arg (i) .eq. 38))goto 23003 + junk = addset (-3, sub, j, 128) + junk = addset (0, sub, j, 128) + goto 23004 +23003 continue + if (.not.(arg (i) .eq. 64 .and. type (arg (i + 1)) .eq. 48))goto 2 + *3005 + i = i + 1 + junk = addset (-3, sub, j, 128) + junk = addset (arg (i) - 48, sub, j, 128) + goto 23006 +23005 continue + junk = addset (esc (arg, i), sub, j, 128) +23006 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(arg (i) .ne. delim))goto 23007 + maksub = -3 + goto 23008 +23007 continue + if (.not.(addset (-2, sub, j, 128) .eq. 0))goto 23009 + maksub = -3 + goto 23010 +23009 continue + maksub = i +23010 continue +23008 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/match.f b/unix/boot/spp/rpp/ratlibf/match.f new file mode 100644 index 00000000..de4e3638 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/match.f @@ -0,0 +1,16 @@ + integer function match (lin, pat) + integer lin (128), pat (128) + integer i, junk (9) + integer amatch + i = 1 +23000 if (.not.(lin (i) .ne. -2))goto 23002 + if (.not.(amatch (lin, i, pat, junk, junk) .gt. 0))goto 23003 + match = 1 + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + match = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/mkpkg.sh b/unix/boot/spp/rpp/ratlibf/mkpkg.sh new file mode 100644 index 00000000..e9cb8822 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mkpkg.sh @@ -0,0 +1,18 @@ +# Utility library subroutines for RPP. + +$F77 -c $HSI_FF addset.f addstr.f amatch.f catsub.f clower.f concat.f +$F77 -c $HSI_FF ctoc.f ctoi.f ctomn.f cupper.f delete.f docant.f dodash.f +$F77 -c $HSI_FF dsdbiu.f dsdump.f dsfree.f dsget.f dsinit.f enter.f equal.f +$F77 -c $HSI_FF error.f errsub.f esc.f fcopy.f filset.f fmtdat.f fold.f +$F77 -c $HSI_FF gctoi.f getc.f getccl.f getpat.f getwrd.f gfnarg.f index.f +$F77 -c $HSI_FF insub.f itoc.f length.f locate.f lookup.f lower.f makpat.f +$F77 -c $HSI_FF maksub.f match.f mktabl.f mntoc.f omatch.f outsub.f patsiz.f +$F77 -c $HSI_FF prompt.f putc.f putdec.f putint.f putstr.f query.f rmtabl.f +$F77 -c $HSI_FF scopy.f sctabl.f sdrop.f skipbl.f slstr.f stake.f stclos.f +$F77 -c $HSI_FF stcopy.f stlu.f strcmp.f strim.f termin.f trmout.f type.f +$F77 -c $HSI_FF upper.f wkday.f + +ar rv libf.a *.o +$RANLIB libf.a +mv -f libf.a .. +rm *.o diff --git a/unix/boot/spp/rpp/ratlibf/mktabl.f b/unix/boot/spp/rpp/ratlibf/mktabl.f new file mode 100644 index 00000000..9c3e7908 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mktabl.f @@ -0,0 +1,17 @@ + integer function mktabl (nodsiz) + integer nodsiz + integer mem( 1) + common/cdsmem/mem + integer st + integer dsget + integer i + st = dsget (43 + 1) + mem (st) = nodsiz + mktabl = st + do 23000 i = 1, 43 + st = st + 1 + mem (st) = 0 +23000 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/mntoc.f b/unix/boot/spp/rpp/ratlibf/mntoc.f new file mode 100644 index 00000000..5a54ec16 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/mntoc.f @@ -0,0 +1,52 @@ + integer function mntoc (buf, p, defalt) + integer buf (100), defalt + integer p + integer i, tp + integer equal + integer c, tmp (128) + integer text (170) + data text / 6, 97, 99, 107, -2, 7, 98, 101, 108, -2, 8, 98, 115, + *-2, -2, 24, 99, 97, 110, -2, 13, 99, 114, -2, -2, 17, 100, 99, 49, + * -2, 18, 100, 99, 50, -2, 19, 100, 99, 51, -2, 20, 100, 99, 52, -2 + *, 127, 100, 101, 108, -2, 16, 100, 108, 101, -2, 25, 101, 109, -2, + * -2, 5, 101, 110, 113, -2, 4, 101, 111, 116, -2, 27, 101, 115, 99, + * -2, 23, 101, 116, 98, -2, 3, 101, 116, 120, -2, 12, 102, 102, -2, + * -2, 28, 102, 115, -2, -2, 29, 103, 115, -2, -2, 9, 104, 116, -2, + *-2, 10, 108, 102, -2, -2, 21, 110, 97, 107, -2, 0, 110, 117, 108, + *-2, 30, 114, 115, -2, -2, 15, 115, 105, -2, -2, 14, 115, 111, -2, + *-2, 1, 115, 111, 104, -2, 32, 115, 112, -2, -2, 2, 115, 116, 120, + *-2, 26, 115, 117, 98, -2, 22, 115, 121, 110, -2, 31, 117, 115, -2, + * -2, 11, 118, 116, -2, -2/ + tp = 1 +23000 continue + tmp (tp) = buf (p) + tp = tp + 1 + p = p + 1 +23001 if (.not.(.not. (((65.le.buf (p).and.buf (p).le.90).or.(97.le.buf + *(p).and.buf (p).le.122)) .or. (48.le.buf (p).and.buf (p).le.57)) . + *or. tp .ge. 128))goto 23000 +23002 continue + tmp (tp) = -2 + if (.not.(tp .eq. 2))goto 23003 + c = tmp (1) + goto 23004 +23003 continue + call lower (tmp) + i = 1 +23005 if (.not.(i .lt. 170))goto 23007 + if (.not.(equal (tmp, text (i + 1)) .eq. 1))goto 23008 + goto 23007 +23008 continue +23006 i = i + 5 + goto 23005 +23007 continue + if (.not.(i .lt. 170))goto 23010 + c = text (i) + goto 23011 +23010 continue + c = defalt +23011 continue +23004 continue + mntoc=(c) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/omatch.f b/unix/boot/spp/rpp/ratlibf/omatch.f new file mode 100644 index 00000000..60d57c83 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/omatch.f @@ -0,0 +1,60 @@ + integer function omatch (lin, i, pat, j) + integer lin (128), pat (128) + integer i, j + integer bump + integer locate + omatch = 0 + if (.not.(lin (i) .eq. -2))goto 23000 + return +23000 continue + bump = -1 + if (.not.(pat (j) .eq. 97))goto 23002 + if (.not.(lin (i) .eq. pat (j + 1)))goto 23004 + bump = 1 +23004 continue + goto 23003 +23002 continue + if (.not.(pat (j) .eq. 37))goto 23006 + if (.not.(i .eq. 1))goto 23008 + bump = 0 +23008 continue + goto 23007 +23006 continue + if (.not.(pat (j) .eq. 63))goto 23010 + if (.not.(lin (i) .ne. 10))goto 23012 + bump = 1 +23012 continue + goto 23011 +23010 continue + if (.not.(pat (j) .eq. 36))goto 23014 + if (.not.(lin (i) .eq. 10))goto 23016 + bump = 0 +23016 continue + goto 23015 +23014 continue + if (.not.(pat (j) .eq. 91))goto 23018 + if (.not.(locate (lin (i), pat, j + 1) .eq. 1))goto 23020 + bump = 1 +23020 continue + goto 23019 +23018 continue + if (.not.(pat (j) .eq. 110))goto 23022 + if (.not.(lin (i) .ne. 10 .and. locate (lin (i), pat, j + 1) .eq. + *0))goto 23024 + bump = 1 +23024 continue + goto 23023 +23022 continue + call error (24Hin omatch: can't happen.) +23023 continue +23019 continue +23015 continue +23011 continue +23007 continue +23003 continue + if (.not.(bump .ge. 0))goto 23026 + i = i + bump + omatch = 1 +23026 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/outsub.f b/unix/boot/spp/rpp/ratlibf/outsub.f new file mode 100644 index 00000000..c8da87de --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/outsub.f @@ -0,0 +1,22 @@ + integer function outsub (arg, file, access) + integer arg (100), file (100) + integer access + if (.not.(arg (1) .eq. 62 .and. arg (2) .ne. 62 .and. arg (2) .ne. + * -2))goto 23000 + outsub = 1 + access = 2 + call scopy (arg, 2, file, 1) + goto 23001 +23000 continue + if (.not.(arg (1) .eq. 62 .and. arg (2) .eq. 62 .and. arg (3) .ne. + * -2))goto 23002 + access = 4 + outsub = 1 + call scopy (arg, 3, file, 1) + goto 23003 +23002 continue + outsub = 0 +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/patsiz.f b/unix/boot/spp/rpp/ratlibf/patsiz.f new file mode 100644 index 00000000..e15449de --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/patsiz.f @@ -0,0 +1,28 @@ + integer function patsiz (pat, n) + integer pat (128) + integer n + if (.not.(pat (n) .eq. 97 .or. pat (n) .eq. 123 .or. pat (n) .eq. + *125))goto 23000 + patsiz = 2 + goto 23001 +23000 continue + if (.not.(pat (n) .eq. 37 .or. pat (n) .eq. 36 .or. pat (n) .eq. 6 + *3))goto 23002 + patsiz = 1 + goto 23003 +23002 continue + if (.not.(pat (n) .eq. 91 .or. pat (n) .eq. 110))goto 23004 + patsiz = pat (n + 1) + 2 + goto 23005 +23004 continue + if (.not.(pat (n) .eq. 42))goto 23006 + patsiz = 4 + goto 23007 +23006 continue + call error (24Hin patsiz: can't happen.) +23007 continue +23005 continue +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/prompt.f b/unix/boot/spp/rpp/ratlibf/prompt.f new file mode 100644 index 00000000..64ab202e --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/prompt.f @@ -0,0 +1,11 @@ + subroutine prompt (str, buf, fd) + integer str(100), buf(100) + integer fd + integer isatty + if (.not.(isatty(fd) .eq. 1))goto 23000 + call putlin (str, fd) + call rfflus(fd) +23000 continue + call getlin (buf, fd) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putc.f b/unix/boot/spp/rpp/ratlibf/putc.f new file mode 100644 index 00000000..c3eecfde --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putc.f @@ -0,0 +1,5 @@ + subroutine putc (c) + integer c + call putch (c, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putdec.f b/unix/boot/spp/rpp/ratlibf/putdec.f new file mode 100644 index 00000000..878febcf --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putdec.f @@ -0,0 +1,20 @@ + subroutine putdec(n,w) + integer n, w + integer chars (20) + integer i, nd + integer itoc + nd = itoc (n, chars, 20) + i = nd + 1 +23000 if (.not.(i .le. w))goto 23002 + call putc (32) +23001 i = i + 1 + goto 23000 +23002 continue + i = 1 +23003 if (.not.(i .le. nd))goto 23005 + call putc (chars (i)) +23004 i = i + 1 + goto 23003 +23005 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putint.f b/unix/boot/spp/rpp/ratlibf/putint.f new file mode 100644 index 00000000..182e96e2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putint.f @@ -0,0 +1,10 @@ + subroutine putint (n, w, fd) + integer n, w + integer fd + integer chars (20) + integer junk + integer itoc + junk = itoc (n, chars, 20) + call putstr (chars, w, fd) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/putstr.f b/unix/boot/spp/rpp/ratlibf/putstr.f new file mode 100644 index 00000000..aaf0f060 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/putstr.f @@ -0,0 +1,27 @@ + subroutine putstr (str, w, fd) + integer str (100) + integer w + integer fd + integer length + integer i, len + len = length (str) + i = len + 1 +23000 if (.not.(i .le. w))goto 23002 + call putch (32, fd) +23001 i = i + 1 + goto 23000 +23002 continue + i = 1 +23003 if (.not.(i .le. len))goto 23005 + call putch (str (i), fd) +23004 i = i + 1 + goto 23003 +23005 continue + i = (-w) - len +23006 if (.not.(i .gt. 0))goto 23008 + call putch (32, fd) +23007 i = i - 1 + goto 23006 +23008 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/query.f b/unix/boot/spp/rpp/ratlibf/query.f new file mode 100644 index 00000000..d12c514a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/query.f @@ -0,0 +1,12 @@ + subroutine query (mesg) + integer mesg (100) + integer getarg + integer arg1 (3), arg2 (1) + if (.not.(getarg (1, arg1, 3) .ne. -1 .and. getarg (2, arg2, 1) .e + *q. -1))goto 23000 + if (.not.(arg1 (1) .eq. 63 .and. arg1 (2) .eq. -2))goto 23002 + call error (mesg) +23002 continue +23000 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/rmtabl.f b/unix/boot/spp/rpp/ratlibf/rmtabl.f new file mode 100644 index 00000000..5b552cab --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/rmtabl.f @@ -0,0 +1,21 @@ + subroutine rmtabl (st) + integer st + integer mem( 1) + common/cdsmem/mem + integer i + integer walker, bucket, node + bucket = st + do 23000 i = 1, 43 + bucket = bucket + 1 + walker = mem (bucket) +23002 if (.not.(walker .ne. 0))goto 23003 + node = walker + walker = mem (node + 0) + call dsfree (node) + goto 23002 +23003 continue +23000 continue +23001 continue + call dsfree (st) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/scopy.f b/unix/boot/spp/rpp/ratlibf/scopy.f new file mode 100644 index 00000000..a16bc5ee --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/scopy.f @@ -0,0 +1,15 @@ + subroutine scopy (from, i, to, j) + integer from (100), to (100) + integer i, j + integer k1, k2 + k2 = j + k1 = i +23000 if (.not.(from (k1) .ne. -2))goto 23002 + to (k2) = from (k1) + k2 = k2 + 1 +23001 k1 = k1 + 1 + goto 23000 +23002 continue + to (k2) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/sctabl.f b/unix/boot/spp/rpp/ratlibf/sctabl.f new file mode 100644 index 00000000..1ba16897 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/sctabl.f @@ -0,0 +1,54 @@ + integer function sctabl (table, sym, info, posn) + integer table, posn + integer sym (100) + integer info (100) + integer mem( 1) + common/cdsmem/mem + integer bucket, walker + integer dsget + integer nodsiz, i, j + if (.not.(posn .eq. 0))goto 23000 + posn = dsget (2) + mem (posn) = 1 + mem (posn + 1) = mem (table + 1) +23000 continue + bucket = mem (posn) + walker = mem (posn + 1) + nodsiz = mem (table) +23002 continue + if (.not.(walker .ne. 0))goto 23005 + i = walker + 1 + nodsiz + j = 1 +23007 if (.not.(mem (i) .ne. -2))goto 23008 + sym (j) = mem (i) + i = i + 1 + j = j + 1 + goto 23007 +23008 continue + sym (j) = -2 + i = 1 +23009 if (.not.(i .le. nodsiz))goto 23011 + j = walker + 1 + i - 1 + info (i) = mem (j) +23010 i = i + 1 + goto 23009 +23011 continue + mem (posn) = bucket + mem (posn + 1) = mem (walker + 0) + sctabl = 1 + return +23005 continue + bucket = bucket + 1 + if (.not.(bucket .gt. 43))goto 23012 + goto 23004 +23012 continue + j = table + bucket + walker = mem (j) +23006 continue +23003 goto 23002 +23004 continue + call dsfree (posn) + posn = 0 + sctabl = -1 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/sdrop.f b/unix/boot/spp/rpp/ratlibf/sdrop.f new file mode 100644 index 00000000..b5334b9f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/sdrop.f @@ -0,0 +1,15 @@ + integer function sdrop (from, to, chars) + integer from (100), to (100) + integer chars + integer len, start + integer ctoc, length, min0 + len = length (from) + if (.not.(chars .lt. 0))goto 23000 + sdrop=(ctoc (from, to, len + chars + 1)) + return +23000 continue + start = min0 (chars, len) + sdrop=(ctoc (from (start + 1), to, len + 1)) + return +23001 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/skipbl.f b/unix/boot/spp/rpp/ratlibf/skipbl.f new file mode 100644 index 00000000..be60610a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/skipbl.f @@ -0,0 +1,9 @@ + subroutine skipbl(lin, i) + integer lin(100) + integer i +23000 if (.not.(lin (i) .eq. 32 .or. lin (i) .eq. 9))goto 23001 + i = i + 1 + goto 23000 +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/slstr.f b/unix/boot/spp/rpp/ratlibf/slstr.f new file mode 100644 index 00000000..d8d98292 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/slstr.f @@ -0,0 +1,32 @@ + integer function slstr (from, to, first, chars) + integer from (100), to (100) + integer first, chars + integer len, i, j, k + integer length + len = length (from) + i = first + if (.not.(i .lt. 1))goto 23000 + i = i + len + 1 +23000 continue + if (.not.(chars .lt. 0))goto 23002 + i = i + chars + 1 + chars = - chars +23002 continue + j = i + chars - 1 + if (.not.(i .lt. 1))goto 23004 + i = 1 +23004 continue + if (.not.(j .gt. len))goto 23006 + j = len +23006 continue + k = 0 +23008 if (.not.(i .le. j))goto 23010 + to (k + 1) = from (i) + i = i + 1 +23009 k = k + 1 + goto 23008 +23010 continue + to (k + 1) = -2 + slstr=(k) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stake.f b/unix/boot/spp/rpp/ratlibf/stake.f new file mode 100644 index 00000000..08ba5652 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stake.f @@ -0,0 +1,15 @@ + integer function stake (from, to, chars) + integer from (100), to (100) + integer chars + integer len, start + integer length, ctoc, max0 + len = length (from) + if (.not.(chars .lt. 0))goto 23000 + start = max0 (len + chars, 0) + stake=(ctoc (from (start + 1), to, len + 1)) + return +23000 continue + stake=(ctoc (from, to, chars + 1)) + return +23001 continue + end diff --git a/unix/boot/spp/rpp/ratlibf/stclos.f b/unix/boot/spp/rpp/ratlibf/stclos.f new file mode 100644 index 00000000..64c041eb --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stclos.f @@ -0,0 +1,20 @@ + integer function stclos (pat, j, lastj, lastcl) + integer pat (128) + integer j, lastj, lastcl + integer addset + integer jp, jt, junk + jp = j - 1 +23000 if (.not.(jp .ge. lastj))goto 23002 + jt = jp + 4 + junk = addset (pat (jp), pat, jt, 128) +23001 jp = jp - 1 + goto 23000 +23002 continue + j = j + 4 + stclos = lastj + junk = addset (42, pat, lastj, 128) + junk = addset (0, pat, lastj, 128) + junk = addset (lastcl, pat, lastj, 128) + junk = addset (0, pat, lastj, 128) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stcopy.f b/unix/boot/spp/rpp/ratlibf/stcopy.f new file mode 100644 index 00000000..36ca2ac2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stcopy.f @@ -0,0 +1,14 @@ + subroutine stcopy (in, i, out, j) + integer in (100), out (100) + integer i, j + integer k + k = i +23000 if (.not.(in (k) .ne. -2))goto 23002 + out (j) = in (k) + j = j + 1 +23001 k = k + 1 + goto 23000 +23002 continue + out(j) = -2 + return + end diff --git a/unix/boot/spp/rpp/ratlibf/stlu.f b/unix/boot/spp/rpp/ratlibf/stlu.f new file mode 100644 index 00000000..6cfbd0a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/stlu.f @@ -0,0 +1,36 @@ + integer function stlu (symbol, node, pred, st) + integer symbol (100) + integer node, pred, st + integer mem( 1) + common/cdsmem/mem + integer hash, i, j, nodsiz + nodsiz = mem (st) + hash = 0 + i = 1 +23000 if (.not.(symbol (i) .ne. -2))goto 23002 + hash = hash + symbol (i) +23001 i = i + 1 + goto 23000 +23002 continue + hash = mod (hash, 43) + 1 + pred = st + hash + node = mem (pred) +23003 if (.not.(node .ne. 0))goto 23004 + i = 1 + j = node + 1 + nodsiz +23005 if (.not.(symbol (i) .eq. mem (j)))goto 23006 + if (.not.(symbol (i) .eq. -2))goto 23007 + stlu=(1) + return +23007 continue + i = i + 1 + j = j + 1 + goto 23005 +23006 continue + pred = node + node = mem (pred + 0) + goto 23003 +23004 continue + stlu=(0) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/strcmp.f b/unix/boot/spp/rpp/ratlibf/strcmp.f new file mode 100644 index 00000000..9d037401 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/strcmp.f @@ -0,0 +1,30 @@ + integer function strcmp (str1, str2) + integer str1 (100), str2 (100) + integer i + i = 1 +23000 if (.not.(str1 (i) .eq. str2 (i)))goto 23002 + if (.not.(str1 (i) .eq. -2))goto 23003 + strcmp=(0) + return +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(str1 (i) .eq. -2))goto 23005 + strcmp = -1 + goto 23006 +23005 continue + if (.not.(str2 (i) .eq. -2))goto 23007 + strcmp = + 1 + goto 23008 +23007 continue + if (.not.(str1 (i) .lt. str2 (i)))goto 23009 + strcmp = -1 + goto 23010 +23009 continue + strcmp = +1 +23010 continue +23008 continue +23006 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/strim.f b/unix/boot/spp/rpp/ratlibf/strim.f new file mode 100644 index 00000000..f9aaa9b4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/strim.f @@ -0,0 +1,16 @@ + integer function strim (str) + integer str (100) + integer lnb, i + lnb = 0 + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + if (.not.(str (i) .ne. 32 .and. str (i) .ne. 9))goto 23003 + lnb = i +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + str (lnb + 1) = -2 + strim=(lnb) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/termin.f b/unix/boot/spp/rpp/ratlibf/termin.f new file mode 100644 index 00000000..2ba3823d --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/termin.f @@ -0,0 +1,8 @@ + subroutine termin (name) + integer name (100) + integer tname(9) + data tname(1)/47/,tname(2)/100/,tname(3)/101/,tname(4)/118/,tname( + *5)/47/,tname(6)/116/,tname(7)/116/,tname(8)/121/,tname(9)/-2/ + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/trmout.f b/unix/boot/spp/rpp/ratlibf/trmout.f new file mode 100644 index 00000000..398620cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/trmout.f @@ -0,0 +1,8 @@ + subroutine trmout (name) + integer name (100) + integer tname(9) + data tname(1)/47/,tname(2)/100/,tname(3)/101/,tname(4)/118/,tname( + *5)/47/,tname(6)/116/,tname(7)/116/,tname(8)/121/,tname(9)/-2/ + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibf/type.f b/unix/boot/spp/rpp/ratlibf/type.f new file mode 100644 index 00000000..decd4d15 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/type.f @@ -0,0 +1,16 @@ + integer function type (c) + integer c + if (.not.((97 .le. c .and. c .le. 122) .or. (65 .le. c .and. c .le + *. 90)))goto 23000 + type = 97 + goto 23001 +23000 continue + if (.not.(48 .le. c .and. c .le. 57))goto 23002 + type = 48 + goto 23003 +23002 continue + type = c +23003 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/upper.f b/unix/boot/spp/rpp/ratlibf/upper.f new file mode 100644 index 00000000..1cf34941 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/upper.f @@ -0,0 +1,12 @@ + subroutine upper (token) + integer token (100) + integer cupper + integer i + i = 1 +23000 if (.not.(token (i) .ne. -2))goto 23002 + token (i) = cupper (token (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/ratlibf/wkday.f b/unix/boot/spp/rpp/ratlibf/wkday.f new file mode 100644 index 00000000..69d80796 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibf/wkday.f @@ -0,0 +1,14 @@ + integer function wkday (month, day, year) + integer month, day, year + integer lmonth, lday, lyear + lmonth = month - 2 + lday = day + lyear = year + if (.not.(lmonth .le. 0))goto 23000 + lmonth = lmonth + 12 + lyear = lyear - 1 +23000 continue + wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 3 + *4, 7) + 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/Makefile b/unix/boot/spp/rpp/ratlibr/Makefile new file mode 100644 index 00000000..7c4d42b4 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/Makefile @@ -0,0 +1,33 @@ +# Ratfor source for the ratfor library. A TOOLS compatible ratfor compiler +# is required to compile this. The original UNIX ratfor compiler may not do +# the job. + +.r.f: + /usr/local/bin/ratfor $*.r > $*.f + +SRCS= addset.r addstr.r amatch.r catsub.r clower.r concat.r ctoc.r\ + ctoi.r ctomn.r cupper.r delete.r docant.r dodash.r dsdbiu.r\ + dsdump.r dsfree.r dsget.r dsinit.r enter.r equal.r error.r\ + errsub.r esc.r fcopy.r filset.r fmtdat.r fold.r gctoi.r getc.r\ + getccl.r getpat.r getwrd.r gfnarg.r index.r insub.r\ + itoc.r length.r locate.r lookup.r lower.r makpat.r maksub.r\ + match.r mktabl.r mntoc.r omatch.r outsub.r patsiz.r prompt.r\ + putc.r putdec.r putint.r putstr.r query.r rmtabl.r scopy.r\ + sctabl.r sdrop.r skipbl.r slstr.r stake.r stclos.r stcopy.r\ + stlu.r strcmp.r strim.r termin.r trmout.r type.r upper.r wkday.r + +FORT= addset.f addstr.f amatch.f catsub.f clower.f concat.f ctoc.f\ + ctoi.f ctomn.f cupper.f delete.f docant.f dodash.f dsdbiu.f\ + dsdump.f dsfree.f dsget.f dsinit.f enter.f equal.f error.f\ + errsub.f esc.f fcopy.f filset.f fmtdat.f fold.f gctoi.f getc.f\ + getccl.f getpat.f getwrd.f gfnarg.f index.f insub.f\ + itoc.f length.f locate.f lookup.f lower.f makpat.f maksub.f\ + match.f mktabl.f mntoc.f omatch.f outsub.f patsiz.f prompt.f\ + putc.f putdec.f putint.f putstr.f query.f rmtabl.f scopy.f\ + sctabl.f sdrop.f skipbl.f slstr.f stake.f stclos.f stcopy.f\ + stlu.f strcmp.f strim.f termin.f trmout.f type.f upper.f wkday.f + +fort: $(SRCS) defs + make fsrc; mv *.f ../ratlibf; touch fort + +fsrc: $(FORT) diff --git a/unix/boot/spp/rpp/ratlibr/addset.r b/unix/boot/spp/rpp/ratlibr/addset.r new file mode 100644 index 00000000..06f9f578 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/addset.r @@ -0,0 +1,18 @@ +include defs + +# addset - put c in string (j) if it fits, increment j + + integer function addset (c, str, j, maxsiz) + integer j, maxsiz + character c, str (maxsiz) + + if (j > maxsiz) + addset = NO + else { + str(j) = c + j = j + 1 + addset = YES + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/addstr.r b/unix/boot/spp/rpp/ratlibr/addstr.r new file mode 100644 index 00000000..2f88c74c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/addstr.r @@ -0,0 +1,19 @@ +include defs + +# addstr - add s to str(j) if it fits, increment j + + integer function addstr (s, str, j, maxsiz) + integer j, maxsiz + character s (ARB), str (maxsiz) + + integer i, addset + + for (i = 1; s (i) != EOS; i = i + 1) + if (addset (s (i), str, j, maxsiz) == NO) { + addstr = NO + return + } + addstr = YES + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/amatch.r b/unix/boot/spp/rpp/ratlibr/amatch.r new file mode 100644 index 00000000..54a2904b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/amatch.r @@ -0,0 +1,55 @@ +include defs + +# amatch --- (non-recursive) look for match starting at lin (from) + + integer function amatch (lin, from, pat, tagbeg, tagend) + character lin (MAXLINE), pat (MAXPAT) + integer from, tagbeg (10), tagend (10) + + integer i, j, offset, stack + integer omatch, patsiz + + for (i = 1; i <= 10; i = i + 1) { + tagbeg (i) = 0 + tagend (i) = 0 + } + tagbeg (1) = from + stack = 0 + offset = from # next unexamined input character + for (j = 1; pat (j) != EOS; j = j + patsiz (pat, j)) + if (pat (j) == CLOSURE) { # a closure entry + stack = j + j = j + CLOSIZE # step over CLOSURE + for (i = offset; lin (i) != EOS; ) # match as many as + if (omatch (lin, i, pat, j) == NO) # possible + break + pat (stack + COUNT) = i - offset + pat (stack + START) = offset + offset = i # character that made us fail + } + else if (pat (j) == START_TAG) { + i = pat (j + 1) + tagbeg (i + 1) = offset + } + else if (pat (j) == STOP_TAG) { + i = pat (j + 1) + tagend (i + 1) = offset + } + else if (omatch (lin, offset, pat, j) == NO) { # non-closure + for ( ; stack > 0; stack = pat (stack + PREVCL)) + if (pat (stack + COUNT) > 0) + break + if (stack <= 0) { # stack is empty + amatch = 0 # return failure + return + } + pat (stack + COUNT) = pat (stack + COUNT) - 1 + j = stack + CLOSIZE + offset = pat (stack + START) + pat (stack + COUNT) + } + # else omatch succeeded + + amatch = offset + tagend (1) = offset + return # success + end diff --git a/unix/boot/spp/rpp/ratlibr/catsub.r b/unix/boot/spp/rpp/ratlibr/catsub.r new file mode 100644 index 00000000..627e998f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/catsub.r @@ -0,0 +1,27 @@ +include defs + +# catsub --- add replacement text to end of new + + subroutine catsub (lin, from, to, sub, new, k, maxnew) + + character lin(MAXLINE) + integer from(10), to(10) + integer maxnew + character sub(maxnew), new(MAXPAT) + integer k + + integer i, j, junk, ri + integer addset + + for (i = 1; sub (i) != EOS; i = i + 1) + if (sub (i) == DITTO) { + i = i + 1 + ri = sub (i) + 1 + for (j = from (ri); j < to (ri); j = j + 1) + junk = addset (lin (j), new, k, maxnew) + } + else + junk = addset (sub (i), new, k, maxnew) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/clower.r b/unix/boot/spp/rpp/ratlibr/clower.r new file mode 100644 index 00000000..0f629ea3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/clower.r @@ -0,0 +1,18 @@ +include defs + +# clower - change letter to lower case + + character function clower(c) + character c + + character k + + if (c >= BIGA & c <= BIGZ) { + k = LETA - BIGA # avoid integer overflow in byte machines + clower = c + k + } + else + clower = c + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/concat.r b/unix/boot/spp/rpp/ratlibr/concat.r new file mode 100644 index 00000000..abe55156 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/concat.r @@ -0,0 +1,15 @@ +include defs + +# concat - concatenate two strings together + + subroutine concat (buf1, buf2, outstr) + character buf1(ARB), buf2(ARB), outstr(ARB) + + integer i + + i = 1 + call stcopy (buf1, 1, outstr, i) + call scopy (buf2, 1, outstr, i) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/ctoc.r b/unix/boot/spp/rpp/ratlibr/ctoc.r new file mode 100644 index 00000000..3b9a22ba --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctoc.r @@ -0,0 +1,18 @@ +include defs + +# ctoc --- convert EOS-terminated string to EOS-terminated string + + integer function ctoc (from, to, len) + integer len + character from (ARB), to (len) + + integer i + + for (i = 1; i < len & from (i) != EOS; i = i + 1) + to (i) = from (i) + + to (i) = EOS + + return (i - 1) + + end diff --git a/unix/boot/spp/rpp/ratlibr/ctoi.r b/unix/boot/spp/rpp/ratlibr/ctoi.r new file mode 100644 index 00000000..54a5769b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctoi.r @@ -0,0 +1,37 @@ +include defs + +# ctoi - convert string at in(i) to integer, increment i + + integer function ctoi(in, i) + character in (ARB) + integer i + + integer d + external index + integer index + + # string digits "0123456789" + character digits(11) + data digits (1) /DIG0/, + digits (2) /DIG1/, + digits (3) /DIG2/, + digits (4) /DIG3/, + digits (5) /DIG4/, + digits (6) /DIG5/, + digits (7) /DIG6/, + digits (8) /DIG7/, + digits (9) /DIG8/, + digits (10) /DIG9/, + digits (11) /EOS/ + + while (in (i) == BLANK | in (i) == TAB) + i = i + 1 + for (ctoi = 0; in (i) != EOS; i = i + 1) { + d = index (digits, in (i)) + if (d == 0) # non-digit + break + ctoi = 10 * ctoi + d - 1 + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/ctomn.r b/unix/boot/spp/rpp/ratlibr/ctomn.r new file mode 100644 index 00000000..ef59e51a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/ctomn.r @@ -0,0 +1,59 @@ +include defs + +# ctomn --- translate ASCII control character to mnemonic string + + integer function ctomn (c, rep) + character c, rep (4) + + integer i + integer length + + character mntext (136) # 4 chars/mnemonic; 32 control chars + SP + DEL + data mntext / _ + BIGN, BIGU, BIGL, EOS, + BIGS, BIGO, BIGH, EOS, + BIGS, BIGT, BIGX, EOS, + BIGE, BIGT, BIGX, EOS, + BIGE, BIGO, BIGT, EOS, + BIGE, BIGN, BIGQ, EOS, + BIGA, BIGC, BIGK, EOS, + BIGB, BIGE, BIGL, EOS, + BIGB, BIGS, EOS, EOS, + BIGH, BIGT, EOS, EOS, + BIGL, BIGF, EOS, EOS, + BIGV, BIGT, EOS, EOS, + BIGF, BIGF, EOS, EOS, + BIGC, BIGR, EOS, EOS, + BIGS, BIGO, EOS, EOS, + BIGS, BIGI, EOS, EOS, + BIGD, BIGL, BIGE, EOS, + BIGD, BIGC, DIG1, EOS, + BIGD, BIGC, DIG2, EOS, + BIGD, BIGC, DIG3, EOS, + BIGD, BIGC, DIG4, EOS, + BIGN, BIGA, BIGK, EOS, + BIGS, BIGY, BIGN, EOS, + BIGE, BIGT, BIGB, EOS, + BIGC, BIGA, BIGN, EOS, + BIGE, BIGM, EOS, EOS, + BIGS, BIGU, BIGB, EOS, + BIGE, BIGS, BIGC, EOS, + BIGF, BIGS, EOS, EOS, + BIGG, BIGS, EOS, EOS, + BIGR, BIGS, EOS, EOS, + BIGU, BIGS, EOS, EOS, + BIGS, BIGP, EOS, EOS, + BIGD, BIGE, BIGL, EOS/ + + i = mod (max(c,0), 128) + if (0 <= i & i <= 32) # non-printing character or space + call scopy (mntext, 4 * i + 1, rep, 1) + elif (i == 127) # rubout (DEL) + call scopy (mntext, 133, rep, 1) + else { # printing character + rep (1) = c + rep (2) = EOS + } + + return (length (rep)) + end diff --git a/unix/boot/spp/rpp/ratlibr/cupper.r b/unix/boot/spp/rpp/ratlibr/cupper.r new file mode 100644 index 00000000..9a39cf21 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/cupper.r @@ -0,0 +1,14 @@ +include defs + +# cupper - change letter to upper case + + character function cupper (c) + character c + + if (c >= LETA & c <= LETZ) + cupper = c + (BIGA - LETA) + else + cupper = c + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/defs b/unix/boot/spp/rpp/ratlibr/defs new file mode 100644 index 00000000..bf040c55 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/defs @@ -0,0 +1,138 @@ +# common definitions for all routines comprising the ratfor preprocessor +#--------------------------------------------------------------- +# The definition STDEFNS defines the file which contains the +# standard definitions to be used when preprocessing a file. +# It is opened and read automatically by the ratfor preprocessor. +# Set STDEFNS to the name of the file in which the standard +# definitions reside. If you don't want the preprocessor to +# automatically open this file, set STDENFS to "". +# +#--------------------------------------------------------------- +# If you want the preprocessor to output upper case only, +# set the following definition: +# +# define (UPPERC,) +# +#--------------------------------------------------------------- +# Some of the buffer sizes and other symbols might have to be +# changed. Especially check the following: +# +# MAXDEF (number of characters in a definition) +# SBUFSIZE (nbr string declarations allowed per module) +# MAXSTRTBL (size of table to buffer string declarations) +# MAXSWITCH (max stack for switch statement) +# +#----------------------------------------------------------------- + + +define (STDEFNS, string defns "") # standard defns file +#define (UPPERC,) # define if Fortran compiler wants upper case +#define (IMPNONE,) # output IMPLICIT NONE in procedures +define (NULL,0) +define (INDENT,3) # number of spaces of indentation +define (MAX_INDENT,30) # maximum column for indentation +define (FIRST_LABEL,100) # first statement label +define (SZ_SPOOLBUF,8) # for breaking continuation cards + +define (RADIX,PERCENT) # % indicates alternate radix +define (TOGGLE,PERCENT) # toggle for literal lines +define (ARGFLAG,DOLLAR) +define (CUTOFF,3) # min nbr of cases to generate branch table + # (for switch statement) +define (DENSITY,2) # reciprocal of density necessary for + # branch table +define (FILLCHAR,DIG0) # used in long-name uniquing +define (MAXIDLENGTH,6) # for Fortran 66 and 77 +define (SZ_SMEM,240) # memory common declarations string + + +# Lexical items (codes are negative to avoid conflict with character values) + +define (LEXBEGIN,-83) +define (LEXBREAK,-79) +define (LEXCASE,-91) +define (LEXDEFAULT,-90) +define (LEXDIGITS,-89) +define (LEXDO,-96) +define (LEXELSE,-87) +define (LEXEND,-82) +define (LEXERRCHK,-84) +define (LEXERROR,-73) +define (LEXFOR,-94) +define (LEXIF,-99) +define (LEXIFELSE,-72) +define (LEXIFERR,-98) +define (LEXIFNOERR,-97) +define (LEXLITERAL,-85) +define (LEXNEXT,-78) +define (LEXOTHER,-80) +define (LEXPOINTER,-88) +define (LEXRBRACE,-74) +define (LEXREPEAT,-93) +define (LEXRETURN,-77) +define (LEXGOTO,-76) +define (LEXSTOP,-71) +define (LEXSTRING,-75) +define (LEXSWITCH,-92) +define (LEXTHEN,-86) +define (LEXUNTIL,-70) +define (LEXWHILE,-95) +define (LSTRIPC,-69) +define (RSTRIPC,-68) +define (LEXDECL,-67) + +define (XPP_DIRECTIVE, -166) + +# Built-in macro functions: + +define (DEFTYPE,-4) +define (MACTYPE,-10) +define (IFTYPE,-11) +define (INCTYPE,-12) +define (SUBTYPE,-13) +define (ARITHTYPE,-14) +define (IFDEFTYPE,-15) +define (IFNOTDEFTYPE,-16) +define (PRAGMATYPE,-17) + + +# Size-limiting definitions: + +define (MEMSIZE,60000) # space allotted to symbol tables and macro text +define (BUFSIZE,4096) # pushback buffer for ngetch and putbak +define (PBPOINT,3192) # point in buffer where pushback begins +define (SBUFSIZE,2048) # buffer for string statements +define (MAXDEF,2048) # max chars in a defn +define (MAXFORSTK,200) # max space for for reinit clauses +define (MAXERRSTK,30) # max nesting of iferr statements +define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) +define (MAXSTACK,100) # max stack depth for parser +define (MAXSWITCH,1000) # max stack for switch statement +define (MAXSWNEST,10) # max nesting of switches in a procedure +define (MAXTOK,100) # max chars in a token +define (NFILES,5) # max number of include file nesting +define (MAXNBRSTR,20) #max nbr string declarations per module +define (CALLSIZE,50) +define (ARGSIZE,100) +define (EVALSIZE,500) + + +# Where to find the common blocks: + +define(COMMON_BLOCKS,"common") + +# Data types, Dynamic Memory common: + +define (XPOINTER,"integer ") + + +# The following external names are redefined to avoid name collisions with +# standard library procedures on some systems. + +define open rfopen +define close rfclos +define flush rfflus +define note rfnote +define seek rfseek +define remove rfrmov +define exit rexit diff --git a/unix/boot/spp/rpp/ratlibr/delete.r b/unix/boot/spp/rpp/ratlibr/delete.r new file mode 100644 index 00000000..f4cadeb2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/delete.r @@ -0,0 +1,21 @@ +include defs + +# delete --- remove a symbol from the symbol table + + subroutine delete (symbol, st) + character symbol (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer stlu + + pointer node, pred + + if (stlu (symbol, node, pred, st) == YES) { + Mem (pred + ST_LINK) = Mem (node + ST_LINK) + call dsfree (node) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/docant.r b/unix/boot/spp/rpp/ratlibr/docant.r new file mode 100644 index 00000000..efa14ccc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/docant.r @@ -0,0 +1,25 @@ +include defs + +# docant +# +# Similar to cant(name), however precede the messge with the name +# of the program that was running when the file could not be +# opened. Helpful in a pipeline to verify which program was not +# able to open a file. +# + subroutine docant(name) + + character name(ARB), prog(FILENAMESIZE) + integer length + integer getarg + + length = getarg(0, prog, FILENAMESIZE) + if (length != EOF) { + call putlin(prog, STDERR) + call putch(COLON, STDERR) + call putch(BLANK, STDERR) + } + call cant(name) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dodash.r b/unix/boot/spp/rpp/ratlibr/dodash.r new file mode 100644 index 00000000..83c4f2bc --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dodash.r @@ -0,0 +1,22 @@ +include defs + +# dodash --- expand array (i-1)-array (i+1) into set (j)... from valid + + subroutine dodash (valid, array, i, set, j, maxset) + integer i, j, maxset + character valid (ARB), array (ARB), set (maxset) + + character esc + + integer junk, k, limit + external index + integer addset, index + + i = i + 1 + j = j - 1 + limit = index (valid, esc (array, i)) + for (k = index (valid, set (j)); k <= limit; k = k + 1) + junk = addset (valid (k), set, j, maxset) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsdbiu.r b/unix/boot/spp/rpp/ratlibr/dsdbiu.r new file mode 100644 index 00000000..99c2acc0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsdbiu.r @@ -0,0 +1,45 @@ +include defs + +# dsdbiu --- dump contents of block-in-use + + subroutine dsdbiu (b, form) + pointer b + character form + + DS_DECL(Mem, 1) + + integer l, s, lmax + + string blanks " " + + call putint (b, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (Mem (b + DS_SIZE), 0, ERROUT) + call remark (" words in use.") + + l = 0 + s = b + Mem (b + DS_SIZE) + if (form == DIGIT) + lmax = 5 + else + lmax = 50 + + for (b = b + DS_OHEAD; b < s; b = b + 1) { + if (l == 0) + call putlin (blanks, ERROUT) + if (form == DIGIT) + call putint (Mem (b), 10, ERROUT) + elif (form == LETTER) + call putch (Mem (b), ERROUT) + l = l + 1 + if (l >= lmax) { + l = 0 + call putch (NEWLINE, ERROUT) + } + } + + if (l != 0) + call putch (NEWLINE, ERROUT) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsdump.r b/unix/boot/spp/rpp/ratlibr/dsdump.r new file mode 100644 index 00000000..276290db --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsdump.r @@ -0,0 +1,34 @@ +include defs + +# dsdump --- produce semi-readable dump of storage + + subroutine dsdump (form) + character form + + DS_DECL(Mem, 1) + + pointer p, t, q + + t = DS_AVAIL + + call remark ("** DYNAMIC STORAGE DUMP **.") + call putint (1, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (DS_OHEAD + 1, 0, ERROUT) + call remark (" words in use.") + + p = Mem (t + DS_LINK) + while (p != LAMBDA) { + call putint (p, 5, ERROUT) + call putch (BLANK, ERROUT) + call putint (Mem (p + DS_SIZE), 0, ERROUT) + call remark (" words available.") + q = p + Mem (p + DS_SIZE) + while (q != Mem (p + DS_LINK) & q < Mem (DS_MEMEND)) + call dsdbiu (q, form) + p = Mem (p + DS_LINK) + } + + call remark ("** END DUMP **.") + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsfree.r b/unix/boot/spp/rpp/ratlibr/dsfree.r new file mode 100644 index 00000000..34cd7e55 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsfree.r @@ -0,0 +1,53 @@ +include defs + +# dsfree --- return a block of storage to the available space list + + subroutine dsfree (block) + pointer block + + DS_DECL(Mem, 1) + + pointer p0, p, q + + integer n, junk + + character con (10) + + p0 = block - DS_OHEAD + n = Mem (p0 + DS_SIZE) + q = DS_AVAIL + + repeat { + p = Mem (q + DS_LINK) + if (p == LAMBDA | p > p0) + break + q = p + } + + if (q + Mem (q + DS_SIZE) > p0) { + call remark ("in dsfree: attempt to free unallocated block.") + call remark ("type 'c' to continue.") + junk = getlin (con, STDIN) + if (con (1) != LETC & con (1) != BIGC) + call endst + return # do not attempt to free the block + } + + if (p0 + n == p & p != LAMBDA) { + n = n + Mem (p + DS_SIZE) + Mem (p0 + DS_LINK) = Mem (p + DS_LINK) + } + else + Mem (p0 + DS_LINK) = p + + if (q + Mem (q + DS_SIZE) == p0) { + Mem (q + DS_SIZE) = Mem (q + DS_SIZE) + n + Mem (q + DS_LINK) = Mem (p0 + DS_LINK) + } + else { + Mem (q + DS_LINK) = p0 + Mem (p0 + DS_SIZE) = n + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/dsget.r b/unix/boot/spp/rpp/ratlibr/dsget.r new file mode 100644 index 00000000..4c62ce62 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsget.r @@ -0,0 +1,50 @@ +include defs + +# dsget --- get pointer to block of at least w available words + + pointer function dsget (w) + integer w + + DS_DECL(Mem, 1) + + pointer p, q, l + + integer n, k, junk + integer getlin + + character c (10) + + n = w + DS_OHEAD + q = DS_AVAIL + + repeat { + p = Mem (q + DS_LINK) + if (p == LAMBDA) { + call remark ("in dsget: out of storage space.") + call remark ("type 'c' or 'i' for char or integer dump.") + junk = getlin (c, STDIN) + if (c (1) == LETC | c (1) == BIGC) + call dsdump (LETTER) + else if (c (1) == LETI | c (1) == BIGI) + call dsdump (DIGIT) + call error ("program terminated.") + } + if (Mem (p + DS_SIZE) >= n) + break + q = p + } + + k = Mem (p + DS_SIZE) - n + if (k >= DS_CLOSE) { + Mem (p + DS_SIZE) = k + l = p + k + Mem (l + DS_SIZE) = n + } + else { + Mem (q + DS_LINK) = Mem (p + DS_LINK) + l = p + } + + return (l + DS_OHEAD) + + end diff --git a/unix/boot/spp/rpp/ratlibr/dsinit.r b/unix/boot/spp/rpp/ratlibr/dsinit.r new file mode 100644 index 00000000..926390b3 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/dsinit.r @@ -0,0 +1,29 @@ +include defs + +# dsinit --- initialize dynamic storage space to w words + + subroutine dsinit (w) + integer w + + DS_DECL(Mem, 1) + + pointer t + + if (w < 2 * DS_OHEAD + 2) + call error ("in dsinit: unreasonably small memory size.") + + # set up avail list: + t = DS_AVAIL + Mem (t + DS_SIZE) = 0 + Mem (t + DS_LINK) = DS_AVAIL + DS_OHEAD + + # set up first block of space: + t = DS_AVAIL + DS_OHEAD + Mem (t + DS_SIZE) = w - DS_OHEAD - 1 # -1 for MEMEND + Mem (t + DS_LINK) = LAMBDA + + # record end of memory: + Mem (DS_MEMEND) = w + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/enter.r b/unix/boot/spp/rpp/ratlibr/enter.r new file mode 100644 index 00000000..56a3d46b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/enter.r @@ -0,0 +1,40 @@ +include defs + +# enter --- place a symbol in the symbol table, updating if already present + + subroutine enter (symbol, info, st) + character symbol (ARB) + integer info (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer i, nodsiz, j + integer stlu, length + + pointer node, pred + pointer dsget + + nodsiz = Mem (st) + + if (stlu (symbol, node, pred, st) == NO) { + node = dsget (1 + nodsiz + length (symbol) + 1) + Mem (node + ST_LINK) = LAMBDA + Mem (pred + ST_LINK) = node + i = 1 + j = node + ST_DATA + nodsiz + while (symbol (i) != EOS) { + Mem (j) = symbol (i) + i = i + 1 + j = j + 1 + } + Mem (j) = EOS + } + + for (i = 1; i <= nodsiz; i = i + 1) { + j = node + ST_DATA + i - 1 + Mem (j) = info (i) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/equal.r b/unix/boot/spp/rpp/ratlibr/equal.r new file mode 100644 index 00000000..0aa24c4c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/equal.r @@ -0,0 +1,15 @@ +include defs + +# equal - compare str1 to str2; return YES if equal, NO if not + + integer function equal (str1, str2) + character str1(ARB), str2(ARB) + + integer i + + for (i = 1; str1 (i) == str2 (i); i = i + 1) + if (str1 (i) == EOS) + return (YES) + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/error.r b/unix/boot/spp/rpp/ratlibr/error.r new file mode 100644 index 00000000..326a8823 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/error.r @@ -0,0 +1,10 @@ +include defs + +# error - print message and terminate execution + + subroutine error (line) + character line (ARB) + + call remark (line) + call endst + end diff --git a/unix/boot/spp/rpp/ratlibr/errsub.r b/unix/boot/spp/rpp/ratlibr/errsub.r new file mode 100644 index 00000000..6e34195a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/errsub.r @@ -0,0 +1,26 @@ +include defs + +# errsub - see if argument is ERROUT substitution + + integer function errsub (arg, file, access) + + character arg (ARB), file (ARB) + integer access + + if (arg (1) == QMARK & arg (2) != QMARK & arg (2) != EOS) { + errsub = YES + access = WRITE + call scopy (arg, 2, file, 1) + } + + else if (arg (1) == QMARK & arg (2) == QMARK & arg (3) != EOS) { + errsub = YES + access = APPEND + call scopy (arg, 3, file, 1) + } + + else + errsub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/esc.r b/unix/boot/spp/rpp/ratlibr/esc.r new file mode 100644 index 00000000..bcb0d3a7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/esc.r @@ -0,0 +1,24 @@ +include defs + +# esc - map array (i) into escaped character if appropriate + + character function esc (array, i) + character array (ARB) + integer i + + if (array (i) != ESCAPE) + esc = array (i) + else if (array (i+1) == EOS) # @ not special at end + esc = ESCAPE + else { + i = i + 1 + if (array (i) == LETN | array (i) == BIGN) + esc = NEWLINE + else if (array (i) == LETT | array (i) == BIGT) + esc = TAB + else + esc = array (i) + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fcopy.r b/unix/boot/spp/rpp/ratlibr/fcopy.r new file mode 100644 index 00000000..755f9ad7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fcopy.r @@ -0,0 +1,16 @@ +include defs + +# fcopy - copy file in to file out + + subroutine fcopy (in, out) + filedes in, out + + character line (MAXLINE) + + integer getlin + + while (getlin (line, in) != EOF) + call putlin (line, out) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/filset.r b/unix/boot/spp/rpp/ratlibr/filset.r new file mode 100644 index 00000000..eba728b9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/filset.r @@ -0,0 +1,35 @@ +include defs + +# filset --- expand set at array (i) into set (j), stop at delim + + subroutine filset (delim, array, i, set, j, maxset) + integer i, j, maxset + character array (ARB), delim, set (maxset) + + character esc + + integer junk + external index + integer addset, index + + string digits "0123456789" + string lowalf "abcdefghijklmnopqrstuvwxyz" + string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + + for ( ; array (i) != delim & array (i) != EOS; i = i + 1) + if (array (i) == ESCAPE) + junk = addset (esc (array, i), set, j, maxset) + else if (array (i) != DASH) + junk = addset (array (i), set, j, maxset) + else if (j <= 1 | array (i + 1) == EOS) # literal - + junk = addset (DASH, set, j, maxset) + else if (index (digits, set (j - 1)) > 0) + call dodash (digits, array, i, set, j, maxset) + else if (index (lowalf, set (j - 1)) > 0) + call dodash (lowalf, array, i, set, j, maxset) + else if (index (upalf, set (j - 1)) > 0) + call dodash (upalf, array, i, set, j, maxset) + else + junk = addset (DASH, set, j, maxset) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fmtdat.r b/unix/boot/spp/rpp/ratlibr/fmtdat.r new file mode 100644 index 00000000..652b6769 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fmtdat.r @@ -0,0 +1,34 @@ +include defs + +# fmtdat - format date and time information + + subroutine fmtdat(date, time, now, form) + character date(ARB), time(ARB) + integer now(7), form + + # at present, simply return mm/dd/yy and hh:mm:ss + # 'form' is reserved for selecting different formats + # when those have been chosen. + + date(1) = now(2) / 10 + DIG0 + date(2) = mod(now(2), 10) + DIG0 + date(3) = SLASH + date(4) = now(3) / 10 + DIG0 + date(5) = mod(now(3), 10) + DIG0 + date(6) = SLASH + date(7) = mod(now(1), 100) / 10 + DIG0 + date(8) = mod(now(1), 10) + DIG0 + date(9) = EOS + + time(1) = now(4) / 10 + DIG0 + time(2) = mod(now(4), 10) + DIG0 + time(3) = COLON + time(4) = now(5) / 10 + DIG0 + time(5) = mod(now(5), 10) + DIG0 + time(6) = COLON + time(7) = now(6) / 10 + DIG0 + time(8) = mod(now(6), 10) + DIG0 + time(9) = EOS + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fold.r b/unix/boot/spp/rpp/ratlibr/fold.r new file mode 100644 index 00000000..d6530e90 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fold.r @@ -0,0 +1,16 @@ +include defs + +# fold - fold all letters in a string to lower case + + subroutine fold (token) + character token (ARB) + + character clower + + integer i + + for (i = 1; token (i) != EOS; i = i + 1) + token (i) = clower (token (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/fort b/unix/boot/spp/rpp/ratlibr/fort new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/fort diff --git a/unix/boot/spp/rpp/ratlibr/gctoi.r b/unix/boot/spp/rpp/ratlibr/gctoi.r new file mode 100644 index 00000000..8efabe4f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/gctoi.r @@ -0,0 +1,58 @@ +include defs + +# gctoi --- convert any radix string to single precision integer + + integer function gctoi (str, i, radix) + character str (ARB) + integer i, radix + + integer base, v, d, j + external index + integer index + + character clower + + logical neg + + string digits "0123456789abcdef" + + v = 0 + base = radix + + while (str (i) == BLANK | str (i) == TAB) + i = i + 1 + + neg = (str (i) == MINUS) + if (str (i) == PLUS | str (i) == MINUS) + i = i + 1 + + if (str (i + 2) == LETR & str (i) == DIG1 & IS_DIGIT(str (i + 1)) + | str (i + 1) == LETR & IS_DIGIT(str (i))) { + base = str (i) - DIG0 + j = i + if (str (i + 1) != LETR) { + j = j + 1 + base = base * 10 + (str (j) - DIG0) + } + if (base < 2 | base > 16) + base = radix + else + i = j + 2 + } + + for (; str (i) != EOS; i = i + 1) { + if (IS_DIGIT(str (i))) + d = str (i) - DIG0 + else + d = index (digits, clower (str (i))) - 1 + if (d < 0 | d >= base) + break + v = v * base + d + } + + if (neg) + return (-v) + else + return (+v) + + end diff --git a/unix/boot/spp/rpp/ratlibr/getc.r b/unix/boot/spp/rpp/ratlibr/getc.r new file mode 100644 index 00000000..afd0fc81 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getc.r @@ -0,0 +1,13 @@ +include defs + +# getc - get character from STDIN + + character function getc (c) + character c + + character getch + + getc = getch (c, STDIN) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/getccl.r b/unix/boot/spp/rpp/ratlibr/getccl.r new file mode 100644 index 00000000..727cc7d6 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getccl.r @@ -0,0 +1,29 @@ +include defs + +# getccl --- expand char class at arg (i) into pat (j) + + integer function getccl (arg, i, pat, j) + character arg (MAXARG), pat (MAXPAT) + integer i, j + + integer jstart, junk + integer addset + + i = i + 1 # skip over [ + if (arg (i) == NOT) { + junk = addset (NCCL, pat, j, MAXPAT) + i = i + 1 + } + else + junk = addset (CCL, pat, j, MAXPAT) + jstart = j + junk = addset (0, pat, j, MAXPAT) # leave room for count + call filset (CCLEND, arg, i, pat, j, MAXPAT) + pat (jstart) = j - jstart - 1 + if (arg (i) == CCLEND) + getccl = OK + else + getccl = ERR + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/getpat.r b/unix/boot/spp/rpp/ratlibr/getpat.r new file mode 100644 index 00000000..ef1dc4a2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getpat.r @@ -0,0 +1,12 @@ +include defs + +# getpat - convert str into pattern + + integer function getpat (str, pat) + character str (ARB), pat (ARB) + + integer makpat + + return (makpat (str, 1, EOS, pat)) + + end diff --git a/unix/boot/spp/rpp/ratlibr/getwrd.r b/unix/boot/spp/rpp/ratlibr/getwrd.r new file mode 100644 index 00000000..ec324af0 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/getwrd.r @@ -0,0 +1,25 @@ +include defs + +# getwrd - get non-blank word from in (i) into out, increment i + + integer function getwrd (in, i, out) + character in (ARB), out (ARB) + integer i + + integer j + + while (in (i) == BLANK | in (i) == TAB) + i = i + 1 + + j = 1 + while (in (i) != EOS & in (i) != BLANK + & in (i) != TAB & in (i) != NEWLINE) { + out (j) = in (i) + i = i + 1 + j = j + 1 + } + out (j) = EOS + + getwrd = j - 1 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/gfnarg.r b/unix/boot/spp/rpp/ratlibr/gfnarg.r new file mode 100644 index 00000000..39409592 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/gfnarg.r @@ -0,0 +1,115 @@ +include defs + +# gfnarg --- get the next file name from the argument list + + integer function gfnarg (name, state) + character name (ARB) + integer state (4) + + integer l + integer getarg, getlin + + filedes fd + filedes open + + string in1 "/dev/stdin1" + string in2 "/dev/stdin2" + string in3 "/dev/stdin3" + + repeat { + + if (state (1) == 1) { + state (1) = 2 # new state + state (2) = 1 # next argument + state (3) = ERR # current input file + state (4) = 0 # input file count + } + + else if (state (1) == 2) { + if (getarg (state (2), name, MAXARG) != EOF) { + state (1) = 2 # stay in same state + state (2) = state (2) + 1 # bump argument count + if (name (1) != MINUS) { + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == EOS) { + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG1 & name (3) == EOS) { + call scopy (in1, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG2 & name (3) == EOS) { + call scopy (in2, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + else if (name (2) == DIG3 & name (3) == EOS) { + call scopy (in3, 1, name, 1) + state (4) = state (4) + 1 # bump input file count + return (OK) + } + + else if (name (2) == LETN | name (2) == BIGN) { + state (1) = 3 # new state + if (name (3) == EOS) + state (3) = STDIN + else if (name (3) == DIG1 & name (4) == EOS) + state (3) = STDIN1 + else if (name (3) == DIG2 & name (4) == EOS) + state (3) = STDIN2 + else if (name (3) == DIG3 & name (4) == EOS) + state (3) = STDIN3 + else { + state (3) = open (name (3), READ) + if (state (3) == ERR) { + call putlin (name, ERROUT) + call remark (": can't open.") + state (1) = 2 + } + } + } + else + return (ERR) + } + + else + state (1) = 4 # EOF state + } + + else if (state (1) == 3) { + l = getlin (name, state (3)) + if (l != EOF) { + name (l) = EOS + state (4) = state (4) + 1 # bump input file count + return (OK) + } + if (fd != ERR & fd != STDIN) + call close (state (3)) + state (1) = 2 + } + + else if (state (1) == 4) { + state (1) = 5 + if (state (4) == 0) {# no input files + call scopy (in1, 1, name, 1) + return (OK) + } + break + } + + else if (state (1) == 5) + break + + else + call error ("in gfnarg: bad state (1) value.") + + } # end of infinite repeat + + name (1) = EOS + return (EOF) + end diff --git a/unix/boot/spp/rpp/ratlibr/index.r b/unix/boot/spp/rpp/ratlibr/index.r new file mode 100644 index 00000000..f0693f02 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/index.r @@ -0,0 +1,14 @@ +include defs + +# index - find character c in string str + + integer function index (str, c) + character str (ARB), c + + for (index = 1; str (index) != EOS; index = index + 1) + if (str (index) == c) + return + + index = 0 + return + end diff --git a/unix/boot/spp/rpp/ratlibr/insub.r b/unix/boot/spp/rpp/ratlibr/insub.r new file mode 100644 index 00000000..7d71b95f --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/insub.r @@ -0,0 +1,16 @@ +include defs + +# insub - determine if argument is STDIN substitution + + integer function insub (arg, file) + character arg (ARB), file (ARB) + + if (arg (1) == LESS & arg (2) != EOS) { + insub = YES + call scopy (arg, 2, file, 1) + } + else + insub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/itoc.r b/unix/boot/spp/rpp/ratlibr/itoc.r new file mode 100644 index 00000000..18d8f4bd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/itoc.r @@ -0,0 +1,50 @@ +include defs + +# itoc - convert integer int to char string in str + + integer function itoc (int, str, size) + integer int, size + character str (ARB) + + integer mod + integer d, i, intval, j, k + + # string digits "0123456789" + character digits (11) + data digits (1) /DIG0/, + digits (2) /DIG1/, + digits (3) /DIG2/, + digits (4) /DIG3/, + digits (5) /DIG4/, + digits (6) /DIG5/, + digits (7) /DIG6/, + digits (8) /DIG7/, + digits (9) /DIG8/, + digits (10) /DIG9/, + digits (11) /EOS/ + + intval = iabs (int) + str (1) = EOS + i = 1 + repeat { # generate digits + i = i + 1 + d = mod (intval, 10) + str (i) = digits (d+1) + intval = intval / 10 + } until (intval == 0 | i >= size) + + if (int < 0 & i < size) { # then sign + i = i + 1 + str (i) = MINUS + } + itoc = i - 1 + + for (j = 1; j < i; j = j + 1) { # then reverse + k = str (i) + str (i) = str (j) + str (j) = k + i = i - 1 + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/length.r b/unix/boot/spp/rpp/ratlibr/length.r new file mode 100644 index 00000000..3abb3a81 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/length.r @@ -0,0 +1,12 @@ +include defs + +# length - compute length of string + + integer function length (str) + character str (ARB) + + for (length = 0; str (length+1) != EOS; length = length + 1) + ; + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/locate.r b/unix/boot/spp/rpp/ratlibr/locate.r new file mode 100644 index 00000000..c8d1365b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/locate.r @@ -0,0 +1,17 @@ +include defs + +# locate --- look for c in char class at pat (offset) + + integer function locate (c, pat, offset) + character c, pat (MAXPAT) + integer offset + + integer i + + # size of class is at pat (offset), characters follow + for (i = offset + pat (offset); i > offset; i = i - 1) + if (c == pat (i)) + return (YES) + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/lookup.r b/unix/boot/spp/rpp/ratlibr/lookup.r new file mode 100644 index 00000000..6cda8f08 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/lookup.r @@ -0,0 +1,30 @@ +include defs + +# lookup --- find a symbol in the symbol table, return its data + + integer function lookup (symbol, info, st) + character symbol (ARB) + integer info (ARB) + pointer st + + DS_DECL(Mem, 1) + + integer i, nodsiz, kluge + integer stlu + + pointer node, pred + + if (stlu (symbol, node, pred, st) == NO) { + lookup = NO + return + } + + nodsiz = Mem (st) + for (i = 1; i <= nodsiz; i = i + 1) { + kluge = node + ST_DATA - 1 + i + info (i) = Mem (kluge) + } + lookup = YES + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/lower.r b/unix/boot/spp/rpp/ratlibr/lower.r new file mode 100644 index 00000000..91161578 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/lower.r @@ -0,0 +1,11 @@ +include defs + +# lower - fold all letters to lower case + + subroutine lower (token) + character token (ARB) + + call fold (token) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/makpat.r b/unix/boot/spp/rpp/ratlibr/makpat.r new file mode 100644 index 00000000..a310ada7 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/makpat.r @@ -0,0 +1,70 @@ +include defs + +# makpat --- make pattern from arg (from), terminate at delim + + integer function makpat (arg, from, delim, pat) + character arg (MAXARG), delim, pat (MAXPAT) + integer from + + character esc + + integer i, j, junk, lastcl, lastj, lj, + tagnst, tagnum, tagstk (9) + integer addset, getccl, stclos + + j = 1 # pat index + lastj = 1 + lastcl = 0 + tagnum = 0 + tagnst = 0 + for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1) { + lj = j + if (arg (i) == ANY) + junk = addset (ANY, pat, j, MAXPAT) + else if (arg (i) == BOL & i == from) + junk = addset (BOL, pat, j, MAXPAT) + else if (arg (i) == EOL & arg (i + 1) == delim) + junk = addset (EOL, pat, j, MAXPAT) + else if (arg (i) == CCL) { + if (getccl (arg, i, pat, j) == ERR) { + makpat = ERR + return + } + } + else if (arg (i) == CLOSURE & i > from) { + lj = lastj + if (pat (lj) == BOL | pat (lj) == EOL | pat (lj) == CLOSURE | + pat (lj) == START_TAG | pat (lj) == STOP_TAG) + break + lastcl = stclos (pat, j, lastj, lastcl) + } + else if (arg (i) == START_TAG) { + if (tagnum >= 9) # too many tagged sub-patterns + break + tagnum = tagnum + 1 + tagnst = tagnst + 1 + tagstk (tagnst) = tagnum + junk = addset (START_TAG, pat, j, MAXPAT) + junk = addset (tagnum, pat, j, MAXPAT) + } + else if (arg (i) == STOP_TAG & tagnst > 0) { + junk = addset (STOP_TAG, pat, j, MAXPAT) + junk = addset (tagstk (tagnst), pat, j, MAXPAT) + tagnst = tagnst - 1 + } + else { + junk = addset (CHAR, pat, j, MAXPAT) + junk = addset (esc (arg, i), pat, j, MAXPAT) + } + lastj = lj + } + if (arg (i) != delim) # terminated early + makpat = ERR + else if (addset (EOS, pat, j, MAXPAT) == NO) # no room + makpat = ERR + else if (tagnst != 0) + makpat = ERR + else + makpat = i + return + end diff --git a/unix/boot/spp/rpp/ratlibr/maksub.r b/unix/boot/spp/rpp/ratlibr/maksub.r new file mode 100644 index 00000000..6dd5e049 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/maksub.r @@ -0,0 +1,34 @@ +include defs + +# maksub --- make substitution string in sub + + integer function maksub (arg, from, delim, sub) + character arg (MAXARG), delim, sub (MAXPAT) + integer from + + character esc, type + + integer i, j, junk + integer addset + + j = 1 + for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1) + if (arg (i) == AND) { + junk = addset (DITTO, sub, j, MAXPAT) + junk = addset (0, sub, j, MAXPAT) + } + else if (arg (i) == ESCAPE & type (arg (i + 1)) == DIGIT) { + i = i + 1 + junk = addset (DITTO, sub, j, MAXPAT) + junk = addset (arg (i) - DIG0, sub, j, MAXPAT) + } + else + junk = addset (esc (arg, i), sub, j, MAXPAT) + if (arg (i) != delim) # missing delimiter + maksub = ERR + else if (addset (EOS, sub, j, MAXPAT) == NO) # no room + maksub = ERR + else + maksub = i + return + end diff --git a/unix/boot/spp/rpp/ratlibr/match.r b/unix/boot/spp/rpp/ratlibr/match.r new file mode 100644 index 00000000..c708f4cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/match.r @@ -0,0 +1,18 @@ +include defs + +# match --- find match anywhere on line + + integer function match (lin, pat) + character lin (MAXLINE), pat (MAXPAT) + + integer i, junk (9) + integer amatch + + for (i = 1; lin (i) != EOS; i = i + 1) + if (amatch (lin, i, pat, junk, junk) > 0) { + match = YES + return + } + match = NO + return + end diff --git a/unix/boot/spp/rpp/ratlibr/mktabl.r b/unix/boot/spp/rpp/ratlibr/mktabl.r new file mode 100644 index 00000000..9269b18c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/mktabl.r @@ -0,0 +1,24 @@ +include defs + +# mktabl --- make a new (empty) symbol table + + pointer function mktabl (nodsiz) + integer nodsiz + + DS_DECL(Mem, 1) + + pointer st + pointer dsget + + integer i + + st = dsget (ST_HTABSIZE + 1) # +1 for record of nodsiz + Mem (st) = nodsiz + mktabl = st + do i = 1, ST_HTABSIZE; { + st = st + 1 + Mem (st) = LAMBDA # null link + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/mntoc.r b/unix/boot/spp/rpp/ratlibr/mntoc.r new file mode 100644 index 00000000..55d3fedd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/mntoc.r @@ -0,0 +1,74 @@ +include defs + +# mntoc --- translate ASCII mnemonic into a character + + character function mntoc (buf, p, defalt) + character buf (ARB), defalt + integer p + + integer i, tp + integer equal + + character c, tmp (MAXLINE) + + character text (170) + data text / _ + ACK, LETA, LETC, LETK, EOS, + BEL, LETB, LETE, LETL, EOS, + BS, LETB, LETS, EOS, EOS, + CAN, LETC, LETA, LETN, EOS, + CR, LETC, LETR, EOS, EOS, + DC1, LETD, LETC, DIG1, EOS, + DC2, LETD, LETC, DIG2, EOS, + DC3, LETD, LETC, DIG3, EOS, + DC4, LETD, LETC, DIG4, EOS, + DEL, LETD, LETE, LETL, EOS, + DLE, LETD, LETL, LETE, EOS, + EM, LETE, LETM, EOS, EOS, + ENQ, LETE, LETN, LETQ, EOS, + EOT, LETE, LETO, LETT, EOS, + ESC, LETE, LETS, LETC, EOS, + ETB, LETE, LETT, LETB, EOS, + ETX, LETE, LETT, LETX, EOS, + FF, LETF, LETF, EOS, EOS, + FS, LETF, LETS, EOS, EOS, + GS, LETG, LETS, EOS, EOS, + HT, LETH, LETT, EOS, EOS, + LF, LETL, LETF, EOS, EOS, + NAK, LETN, LETA, LETK, EOS, + NUL, LETN, LETU, LETL, EOS, + RS, LETR, LETS, EOS, EOS, + SI, LETS, LETI, EOS, EOS, + SO, LETS, LETO, EOS, EOS, + SOH, LETS, LETO, LETH, EOS, + SP, LETS, LETP, EOS, EOS, + STX, LETS, LETT, LETX, EOS, + SUB, LETS, LETU, LETB, EOS, + SYN, LETS, LETY, LETN, EOS, + US, LETU, LETS, EOS, EOS, + VT, LETV, LETT, EOS, EOS/ + + tp = 1 + repeat { + tmp (tp) = buf (p) + tp = tp + 1 + p = p + 1 + } until (! (IS_LETTER(buf (p)) | IS_DIGIT(buf (p))) + | tp >= MAXLINE) + tmp (tp) = EOS + + if (tp == 2) + c = tmp (1) + else { + call lower (tmp) + for (i = 1; i < 170; i = i + 5) # should use binary search here + if (equal (tmp, text (i + 1)) == YES) + break + if (i < 170) + c = text (i) + else + c = defalt + } + + return (c) + end diff --git a/unix/boot/spp/rpp/ratlibr/omatch.r b/unix/boot/spp/rpp/ratlibr/omatch.r new file mode 100644 index 00000000..598a4e24 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/omatch.r @@ -0,0 +1,48 @@ +include defs + +# omatch --- try to match a single pattern at pat (j) + + integer function omatch (lin, i, pat, j) + character lin (MAXLINE), pat (MAXPAT) + integer i, j + + integer bump + integer locate + + omatch = NO + if (lin (i) == EOS) + return + bump = -1 + if (pat (j) == CHAR) { + if (lin (i) == pat (j + 1)) + bump = 1 + } + else if (pat (j) == BOL) { + if (i == 1) + bump = 0 + } + else if (pat (j) == ANY) { + if (lin (i) != NEWLINE) + bump = 1 + } + else if (pat (j) == EOL) { + if (lin (i) == NEWLINE) + bump = 0 + } + else if (pat (j) == CCL) { + if (locate (lin (i), pat, j + 1) == YES) + bump = 1 + } + else if (pat (j) == NCCL) { + if (lin (i) != NEWLINE & locate (lin (i), pat, j + 1) == NO) + bump = 1 + } + else + call error ("in omatch: can't happen.") + if (bump >= 0) { + i = i + bump + omatch = YES + } + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/outsub.r b/unix/boot/spp/rpp/ratlibr/outsub.r new file mode 100644 index 00000000..ac657efe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/outsub.r @@ -0,0 +1,25 @@ +include defs + +# outsub - determine if argument is STDOUT substitution + + integer function outsub (arg, file, access) + character arg (ARB), file (ARB) + integer access + + if (arg (1) == GREATER & arg (2) != GREATER & arg (2) != EOS) { + outsub = YES + access = WRITE + call scopy (arg, 2, file, 1) + } + + else if (arg (1) == GREATER & arg (2) == GREATER & arg (3) != EOS) { + access = APPEND + outsub = YES + call scopy (arg, 3, file, 1) + } + + else + outsub = NO + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/patsiz.r b/unix/boot/spp/rpp/ratlibr/patsiz.r new file mode 100644 index 00000000..54265b64 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/patsiz.r @@ -0,0 +1,21 @@ +include defs + +# patsiz --- returns size of pattern entry at pat (n) + + integer function patsiz (pat, n) + character pat (MAXPAT) + integer n + + if (pat (n) == CHAR | pat (n) == START_TAG | pat (n) == STOP_TAG) + patsiz = 2 + else if (pat (n) == BOL | pat (n) == EOL | pat (n) == ANY) + patsiz = 1 + else if (pat (n) == CCL | pat (n) == NCCL) + patsiz = pat (n + 1) + 2 + else if (pat (n) == CLOSURE) # optional + patsiz = CLOSIZE + else + call error ("in patsiz: can't happen.") + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/prompt.r b/unix/boot/spp/rpp/ratlibr/prompt.r new file mode 100644 index 00000000..2648993c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/prompt.r @@ -0,0 +1,19 @@ +include defs + +# prompt - write to/read from teletype + + subroutine prompt (str, buf, fd) + character str(ARB), buf(ARB) + filedes fd + + integer isatty + + if (isatty(fd) == YES) + { + call putlin (str, fd) + call flush (fd) + } + call getlin (buf, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putc.r b/unix/boot/spp/rpp/ratlibr/putc.r new file mode 100644 index 00000000..3ba16c13 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putc.r @@ -0,0 +1,11 @@ +include defs + +# putc - put character onto STDOUT + + subroutine putc (c) + character c + + call putch (c, STDOUT) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putdec.r b/unix/boot/spp/rpp/ratlibr/putdec.r new file mode 100644 index 00000000..6f7bb195 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putdec.r @@ -0,0 +1,20 @@ +include defs + +# putdec - put decimal integer n in field width >= w + + subroutine putdec(n,w) + integer n, w + + character chars (MAXCHARS) + + integer i, nd + integer itoc + + nd = itoc (n, chars, MAXCHARS) + for (i = nd + 1; i <= w; i = i + 1) + call putc (BLANK) + for (i = 1; i <= nd; i = i + 1) + call putc (chars (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putint.r b/unix/boot/spp/rpp/ratlibr/putint.r new file mode 100644 index 00000000..0fed044b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putint.r @@ -0,0 +1,18 @@ +include defs + +# putint - output integer in specified field + + subroutine putint (n, w, fd) + integer n, w + filedes fd + + character chars (MAXCHARS) + + integer junk + integer itoc + + junk = itoc (n, chars, MAXCHARS) + call putstr (chars, w, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/putstr.r b/unix/boot/spp/rpp/ratlibr/putstr.r new file mode 100644 index 00000000..497e34d9 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/putstr.r @@ -0,0 +1,23 @@ +include defs + +# putstr - output character string in specified field + + subroutine putstr (str, w, fd) + character str (ARB) + integer w + filedes fd + + character length + + integer i, len + + len = length (str) + for (i = len + 1; i <= w; i = i + 1) + call putch (BLANK, fd) + for (i = 1; i <= len; i = i + 1) + call putch (str (i), fd) + for (i = (-w) - len; i > 0; i = i - 1) + call putch (BLANK, fd) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/query.r b/unix/boot/spp/rpp/ratlibr/query.r new file mode 100644 index 00000000..80e049be --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/query.r @@ -0,0 +1,17 @@ +include defs + +# query - print usage message if user has requested one + + subroutine query (mesg) + character mesg (ARB) + + integer getarg + + character arg1 (3), arg2 (1) + + if (getarg (1, arg1, 3) != EOF & getarg (2, arg2, 1) == EOF) + if (arg1 (1) == QMARK & arg1 (2) == EOS) + call error (mesg) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/rmtabl.r b/unix/boot/spp/rpp/ratlibr/rmtabl.r new file mode 100644 index 00000000..16a5d3d5 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/rmtabl.r @@ -0,0 +1,27 @@ +include defs + +# rmtabl --- remove a symbol table, deleting all entries + + subroutine rmtabl (st) + pointer st + + DS_DECL(Mem, 1) + + integer i + + pointer walker, bucket, node + + bucket = st + do i = 1, ST_HTABSIZE; { + bucket = bucket + 1 + walker = Mem (bucket) + while (walker != LAMBDA) { + node = walker + walker = Mem (node + ST_LINK) + call dsfree (node) + } + } + + call dsfree (st) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/scopy.r b/unix/boot/spp/rpp/ratlibr/scopy.r new file mode 100644 index 00000000..0878f45a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/scopy.r @@ -0,0 +1,19 @@ +include defs + +# scopy - copy string at from (i) to to (j) + + subroutine scopy (from, i, to, j) + character from (ARB), to (ARB) + integer i, j + + integer k1, k2 + + k2 = j + for (k1 = i; from (k1) != EOS; k1 = k1 + 1) { + to (k2) = from (k1) + k2 = k2 + 1 + } + to (k2) = EOS + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/sctabl.r b/unix/boot/spp/rpp/ratlibr/sctabl.r new file mode 100644 index 00000000..73b0b308 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/sctabl.r @@ -0,0 +1,59 @@ +include defs + +# sctabl --- scan symbol table, returning next entry or EOF + + integer function sctabl (table, sym, info, posn) + pointer table, posn + character sym (ARB) + integer info (ARB) + + DS_DECL(Mem, 1) + + pointer bucket, walker + pointer dsget + + integer nodsiz, i, j + + if (posn == 0) { # just starting scan? + posn = dsget (2) # get space for position info + Mem (posn) = 1 # get index of first bucket + Mem (posn + 1) = Mem (table + 1) # get pointer to first chain + } + + bucket = Mem (posn) # recover previous position + walker = Mem (posn + 1) + nodsiz = Mem (table) + + repeat { # until the next symbol, or none are left + if (walker != LAMBDA) { # symbol available? + i = walker + ST_DATA + nodsiz + j = 1 + while (Mem (i) != EOS) { + sym (j) = Mem (i) + i = i + 1 + j = j + 1 + } + sym (j) = EOS + for (i = 1; i <= nodsiz; i = i + 1) { + j = walker + ST_DATA + i - 1 + info (i) = Mem (j) + } + Mem (posn) = bucket # save position of next symbol + Mem (posn + 1) = Mem (walker + ST_LINK) + sctabl = 1 # not EOF + return + } + else { + bucket = bucket + 1 + if (bucket > ST_HTABSIZE) + break + j = table + bucket + walker = Mem (j) + } + } + + call dsfree (posn) # throw away position information + posn = 0 + sctabl = EOF + return + end diff --git a/unix/boot/spp/rpp/ratlibr/sdrop.r b/unix/boot/spp/rpp/ratlibr/sdrop.r new file mode 100644 index 00000000..fb3169cd --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/sdrop.r @@ -0,0 +1,20 @@ +include defs + +# sdrop --- drop characters from a string APL-style + + integer function sdrop (from, to, chars) + character from (ARB), to (ARB) + integer chars + + integer len, start + integer ctoc, length, min0 + + len = length (from) + if (chars < 0) + return (ctoc (from, to, len + chars + 1)) + else { + start = min0 (chars, len) + return (ctoc (from (start + 1), to, len + 1)) + } + + end diff --git a/unix/boot/spp/rpp/ratlibr/skipbl.r b/unix/boot/spp/rpp/ratlibr/skipbl.r new file mode 100644 index 00000000..9058d09b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/skipbl.r @@ -0,0 +1,13 @@ +include defs + +# skipbl - skip blanks and tabs at lin(i) + + subroutine skipbl(lin, i) + character lin(ARB) + integer i + + while (lin (i) == BLANK | lin (i) == TAB) + i = i + 1 + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/slstr.r b/unix/boot/spp/rpp/ratlibr/slstr.r new file mode 100644 index 00000000..92d82123 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/slstr.r @@ -0,0 +1,36 @@ +include defs + +# slstr --- slice a substring from a string + + integer function slstr (from, to, first, chars) + character from (ARB), to (ARB) + integer first, chars + + integer len, i, j, k + integer length + + len = length (from) + + i = first + if (i < 1) + i = i + len + 1 + + if (chars < 0) { + i = i + chars + 1 + chars = - chars + } + + j = i + chars - 1 + if (i < 1) + i = 1 + if (j > len) + j = len + + for (k = 0; i <= j; k = k + 1) { + to (k + 1) = from (i) + i = i + 1 + } + to (k + 1) = EOS + + return (k) + end diff --git a/unix/boot/spp/rpp/ratlibr/stake.r b/unix/boot/spp/rpp/ratlibr/stake.r new file mode 100644 index 00000000..52a9a096 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stake.r @@ -0,0 +1,20 @@ +include defs + +# stake --- take characters from a string APL-style + + integer function stake (from, to, chars) + character from (ARB), to (ARB) + integer chars + + integer len, start + integer length, ctoc, max0 + + len = length (from) + if (chars < 0) { + start = max0 (len + chars, 0) + return (ctoc (from (start + 1), to, len + 1)) + } + else + return (ctoc (from, to, chars + 1)) + + end diff --git a/unix/boot/spp/rpp/ratlibr/stclos.r b/unix/boot/spp/rpp/ratlibr/stclos.r new file mode 100644 index 00000000..37cac0c5 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stclos.r @@ -0,0 +1,24 @@ +include defs + +# stclos --- insert closure entry at pat (j) + + integer function stclos (pat, j, lastj, lastcl) + character pat (MAXPAT) + integer j, lastj, lastcl + + integer addset + integer jp, jt, junk + + for (jp = j - 1; jp >= lastj; jp = jp - 1) { # make a hole + jt = jp + CLOSIZE + junk = addset (pat (jp), pat, jt, MAXPAT) + } + j = j + CLOSIZE + stclos = lastj + junk = addset (CLOSURE, pat, lastj, MAXPAT) # put closure in it + junk = addset (0, pat, lastj, MAXPAT) # COUNT + junk = addset (lastcl, pat, lastj, MAXPAT) # PREVCL + junk = addset (0, pat, lastj, MAXPAT) # START + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/stcopy.r b/unix/boot/spp/rpp/ratlibr/stcopy.r new file mode 100644 index 00000000..5c5b2396 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stcopy.r @@ -0,0 +1,17 @@ +include defs + +# stcopy - copy string from in (i) to out (j), updating j, excluding EOS + + subroutine stcopy (in, i, out, j) + character in (ARB), out (ARB) + integer i, j + + integer k + + for (k = i; in (k) != EOS; k = k + 1) { + out (j) = in (k) + j = j + 1 + } + out(j) = EOS + return + end diff --git a/unix/boot/spp/rpp/ratlibr/stlu.r b/unix/boot/spp/rpp/ratlibr/stlu.r new file mode 100644 index 00000000..2f173b1c --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/stlu.r @@ -0,0 +1,36 @@ +include defs + +# stlu --- symbol table lookup primitive + + integer function stlu (symbol, node, pred, st) + character symbol (ARB) + pointer node, pred, st + + DS_DECL(Mem, 1) + + integer hash, i, j, nodsiz + + nodsiz = Mem (st) + + hash = 0 + for (i = 1; symbol (i) != EOS; i = i + 1) + hash = hash + symbol (i) + hash = mod (hash, ST_HTABSIZE) + 1 + + pred = st + hash + node = Mem (pred) + while (node != LAMBDA) { + i = 1 + j = node + ST_DATA + nodsiz + while (symbol (i) == Mem (j)) { + if (symbol (i) == EOS) + return (YES) + i = i + 1 + j = j + 1 + } + pred = node + node = Mem (pred + ST_LINK) + } + + return (NO) + end diff --git a/unix/boot/spp/rpp/ratlibr/strcmp.r b/unix/boot/spp/rpp/ratlibr/strcmp.r new file mode 100644 index 00000000..9bc12c6a --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/strcmp.r @@ -0,0 +1,24 @@ +include defs + +# strcmp - compare 2 strings; return -1 if <, 0 if =, +1 if > + + integer function strcmp (str1, str2) + character str1 (ARB), str2 (ARB) + + integer i + + for (i = 1; str1 (i) == str2 (i); i = i + 1) + if (str1 (i) == EOS) + return (0) + + if (str1 (i) == EOS) + strcmp = -1 + else if (str2 (i) == EOS) + strcmp = + 1 + else if (str1 (i) < str2 (i)) + strcmp = -1 + else + strcmp = +1 + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/strim.r b/unix/boot/spp/rpp/ratlibr/strim.r new file mode 100644 index 00000000..ed082ef2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/strim.r @@ -0,0 +1,18 @@ +include defs + +# strim --- trim trailing blanks and tabs from a string + + integer function strim (str) + character str (ARB) + + integer lnb, i + + lnb = 0 + for (i = 1; str (i) != EOS; i = i + 1) + if (str (i) != BLANK & str (i) != TAB) + lnb = i + + str (lnb + 1) = EOS + return (lnb) + + end diff --git a/unix/boot/spp/rpp/ratlibr/termin.r b/unix/boot/spp/rpp/ratlibr/termin.r new file mode 100644 index 00000000..0eb0c78b --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/termin.r @@ -0,0 +1,12 @@ +include defs + +# termin - pick up name of input channel to users teletype + + subroutine termin (name) + character name (ARB) + + string tname TERMINAL_IN + + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/trmout.r b/unix/boot/spp/rpp/ratlibr/trmout.r new file mode 100644 index 00000000..672bc0fe --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/trmout.r @@ -0,0 +1,12 @@ +include defs + +# trmout - pick up name of output channel to users teletype + + subroutine trmout (name) + character name (ARB) + + string tname TERMINAL_OUT + + call scopy (tname, 1, name, 1) + return + end diff --git a/unix/boot/spp/rpp/ratlibr/type.r b/unix/boot/spp/rpp/ratlibr/type.r new file mode 100644 index 00000000..c98c9655 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/type.r @@ -0,0 +1,99 @@ +include defs + +# type - determine type of character + + character function type (c) + + character c + + if ((LETA <= c & c <= LETZ) | (BIGA <= c & c <= BIGZ)) + type = LETTER + else if (DIG0 <= c & c <= DIG9) + type = DIGIT + else + type = c + + # The original version used a table look-up; you'll have to + # use that method if you have subverted the convention to + # use ASCII characters internally: + # integer index + # character digits(11), lowalf(27), upalf(27) + # data digits(1) /DIG0/ + # data digits(2) /DIG1/ + # data digits(3) /DIG2/ + # data digits(4) /DIG3/ + # data digits(5) /DIG4/ + # data digits(6) /DIG5/ + # data digits(7) /DIG6/ + # data digits(8) /DIG7/ + # data digits(9) /DIG8/ + # data digits(10) /DIG9/ + # data digits(11) /EOS/ + # + # data lowalf(1) /LETA/ + # data lowalf(2) /LETB/ + # data lowalf(3) /LETC/ + # data lowalf(4) /LETD/ + # data lowalf(5) /LETE/ + # data lowalf(6) /LETF/ + # data lowalf(7) /LETG/ + # data lowalf(8) /LETH/ + # data lowalf(9) /LETI/ + # data lowalf(10) /LETJ/ + # data lowalf(11) /LETK/ + # data lowalf(12) /LETL/ + # data lowalf(13) /LETM/ + # data lowalf(14) /LETN/ + # data lowalf(15) /LETO/ + # data lowalf(16) /LETP/ + # data lowalf(17) /LETQ/ + # data lowalf(18) /LETR/ + # data lowalf(19) /LETS/ + # data lowalf(20) /LETT/ + # data lowalf(21) /LETU/ + # data lowalf(22) /LETV/ + # data lowalf(23) /LETW/ + # data lowalf(24) /LETX/ + # data lowalf(25) /LETY/ + # data lowalf(26) /LETZ/ + # data lowalf(27) /EOS/ + # + # data upalf(1) /BIGA/ + # data upalf(2) /BIGB/ + # data upalf(3) /BIGC/ + # data upalf(4) /BIGD/ + # data upalf(5) /BIGE/ + # data upalf(6) /BIGF/ + # data upalf(7) /BIGG/ + # data upalf(8) /BIGH/ + # data upalf(9) /BIGI/ + # data upalf(10) /BIGJ/ + # data upalf(11) /BIGK/ + # data upalf(12) /BIGL/ + # data upalf(13) /BIGM/ + # data upalf(14) /BIGN/ + # data upalf(15) /BIGO/ + # data upalf(16) /BIGP/ + # data upalf(17) /BIGQ/ + # data upalf(18) /BIGR/ + # data upalf(19) /BIGS/ + # data upalf(20) /BIGT/ + # data upalf(21) /BIGU/ + # data upalf(23) /BIGW/ + # data upalf(24) /BIGX/ + # data upalf(25) /BIGY/ + # data upalf(26) /BIGZ/ + # data upalf(27) /EOS/ + # + # if (index(lowalf, c) > 0) + # type = LETTER + # else if (index(upalf,c) >0) + # type = LETTER + # else if (index(digits,c) > 0) + # type = DIGIT + # else + # type = c + + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/upper.r b/unix/boot/spp/rpp/ratlibr/upper.r new file mode 100644 index 00000000..0fc337bb --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/upper.r @@ -0,0 +1,16 @@ +include defs + +# upper - fold all alphas to upper case + + subroutine upper (token) + character token (ARB) + + character cupper + + integer i + + for (i = 1; token (i) != EOS; i = i + 1) + token (i) = cupper (token (i)) + + return + end diff --git a/unix/boot/spp/rpp/ratlibr/wkday.r b/unix/boot/spp/rpp/ratlibr/wkday.r new file mode 100644 index 00000000..027d14a2 --- /dev/null +++ b/unix/boot/spp/rpp/ratlibr/wkday.r @@ -0,0 +1,23 @@ +include defs + +# wkday --- get day-of-week corresponding to month,day,year + + integer function wkday (month, day, year) + integer month, day, year + + integer lmonth, lday, lyear + + lmonth = month - 2 + lday = day + lyear = year + + if (lmonth <= 0) { + lmonth = lmonth + 12 + lyear = lyear - 1 + } + + wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34, + 7) + 1 + + return + end diff --git a/unix/boot/spp/rpp/rpp.c b/unix/boot/spp/rpp/rpp.c new file mode 100644 index 00000000..b9215a9d --- /dev/null +++ b/unix/boot/spp/rpp/rpp.c @@ -0,0 +1,31 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include "ratlibc/ratdef.h" + +int xargc; +char **xargv; + +extern int INITST (void); +extern int RATFOR (void); +extern int ENDST (void); + + +/* RPP -- Second pass of the SPP preprocessor. Converts a Ratfor like + * input language into Fortran. RPP differs from standard tools ratfor + * in a number of ways. Its input language is the output of XPP and + * contains tokens not intended for use in any programming language. + * Support is provided for SPP language features, and the output fortran + * is pretty-printed. + */ +int main (int argc, char *argv[]) +{ + xargc = argc; + xargv = argv; + + INITST(); + RATFOR(); + ENDST(); + + return (0); +} diff --git a/unix/boot/spp/rpp/rppfor/README b/unix/boot/spp/rpp/rppfor/README new file mode 100644 index 00000000..74fcacdc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/README @@ -0,0 +1 @@ +RPP/RPPFOR -- Fortran source for the RPP program. diff --git a/unix/boot/spp/rpp/rppfor/addchr.f b/unix/boot/spp/rpp/rppfor/addchr.f new file mode 100644 index 00000000..f5ed486c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/addchr.f @@ -0,0 +1,10 @@ + subroutine addchr (c, buf, bp, maxsiz) + integer bp, maxsiz + integer c, buf (100) + if (.not.(bp .gt. maxsiz))goto 23000 + call baderr (16Hbuffer overflow.) +23000 continue + buf (bp) = c + bp = bp + 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/allblk.f b/unix/boot/spp/rpp/rppfor/allblk.f new file mode 100644 index 00000000..235267a5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/allblk.f @@ -0,0 +1,15 @@ + integer function allblk (buf) + integer buf (100) + integer i + allblk = 1 + i = 1 +23000 if (.not.(buf (i) .ne. 10 .and. buf (i) .ne. -2))goto 23002 + if (.not.(buf (i) .ne. 32))goto 23003 + allblk = 0 + goto 23002 +23003 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/alldig.f b/unix/boot/spp/rpp/rppfor/alldig.f new file mode 100644 index 00000000..d922e37f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/alldig.f @@ -0,0 +1,18 @@ + integer function alldig (str) + integer str (100) + integer i + alldig = 0 + if (.not.(str (1) .eq. -2))goto 23000 + return +23000 continue + i = 1 +23002 if (.not.(str (i) .ne. -2))goto 23004 + if (.not.(.not.(48.le.str (i).and.str (i).le.57)))goto 23005 + return +23005 continue +23003 i = i + 1 + goto 23002 +23004 continue + alldig = 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/baderr.f b/unix/boot/spp/rpp/rppfor/baderr.f new file mode 100644 index 00000000..8b6564f5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/baderr.f @@ -0,0 +1,5 @@ + subroutine baderr (msg) + integer msg (100) + call synerr (msg) + call endst + end diff --git a/unix/boot/spp/rpp/rppfor/balpar.f b/unix/boot/spp/rpp/rppfor/balpar.f new file mode 100644 index 00000000..2c2b67c9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/balpar.f @@ -0,0 +1,41 @@ + subroutine balpar + integer t, token (100) + integer gettok, gnbtok + integer nlpar + if (.not.(gnbtok (token, 100) .ne. 40))goto 23000 + call synerr (19Hmissing left paren.) + return +23000 continue + call outstr (token) + nlpar = 1 +23002 continue + t = gettok (token, 100) + if (.not.(t .eq. 59 .or. t .eq. 123 .or. t .eq. 125 .or. t .eq. -1 + *))goto 23005 + call pbstr (token) + goto 23004 +23005 continue + if (.not.(t .eq. 10))goto 23007 + token (1) = -2 + goto 23008 +23007 continue + if (.not.(t .eq. 40))goto 23009 + nlpar = nlpar + 1 + goto 23010 +23009 continue + if (.not.(t .eq. 41))goto 23011 + nlpar = nlpar - 1 +23011 continue +23010 continue +23008 continue + if (.not.(t .eq. -9))goto 23013 + call squash (token) +23013 continue + call outstr (token) +23003 if (.not.(nlpar .le. 0))goto 23002 +23004 continue + if (.not.(nlpar .ne. 0))goto 23015 + call synerr (33Hmissing parenthesis in condition.) +23015 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/beginc.f b/unix/boot/spp/rpp/rppfor/beginc.f new file mode 100644 index 00000000..bf6dd872 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/beginc.f @@ -0,0 +1,72 @@ + subroutine beginc + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + body = 1 + ername = 0 + esp = 0 + label = 100 + retlab = labgen (1) + logic0 = 6 + 3 + col = logic0 + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/brknxt.f b/unix/boot/spp/rpp/rppfor/brknxt.f new file mode 100644 index 00000000..7bc70a77 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/brknxt.f @@ -0,0 +1,108 @@ + subroutine brknxt (sp, lextyp, labval, token) + integer labval (100), lextyp (100), sp, token + integer i, n + integer alldig, ctoi + integer t, ptoken (100) + integer gnbtok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + n = 0 + t = gnbtok (ptoken, 100) + if (.not.(alldig (ptoken) .eq. 1))goto 23000 + i = 1 + n = ctoi (ptoken, i) - 1 + goto 23001 +23000 continue + if (.not.(t .ne. 59))goto 23002 + call pbstr (ptoken) +23002 continue +23001 continue + i = sp +23004 if (.not.(i .gt. 0))goto 23006 + if (.not.(lextyp (i) .eq. -95 .or. lextyp (i) .eq. -96 .or. lextyp + * (i) .eq. -94 .or. lextyp (i) .eq. -93))goto 23007 + if (.not.(n .gt. 0))goto 23009 + n = n - 1 + goto 23005 +23009 continue + if (.not.(token .eq. -79))goto 23011 + call outgo (labval (i) + 1) + goto 23012 +23011 continue + call outgo (labval (i)) +23012 continue +23010 continue + xfer = 1 + return +23007 continue +23005 i = i - 1 + goto 23004 +23006 continue + if (.not.(token .eq. -79))goto 23013 + call synerr (14Hillegal break.) + goto 23014 +23013 continue + call synerr (13Hillegal next.) +23014 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/cascod.f b/unix/boot/spp/rpp/rppfor/cascod.f new file mode 100644 index 00000000..e6b256fe --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/cascod.f @@ -0,0 +1,146 @@ + subroutine cascod (lab, token) + integer lab, token + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, l, lb, ub, i, j, junk + integer caslab, labgen, gnbtok + integer tok (100) + if (.not.(swtop .le. 0))goto 23000 + call synerr (24Hillegal case or default.) + return +23000 continue + call indent (-1) + call outgo (lab + 1) + xfer = 1 + l = labgen (1) + if (.not.(token .eq. -91))goto 23002 +23004 if (.not.(caslab (lb, t) .ne. -1))goto 23005 + ub = lb + if (.not.(t .eq. 45))goto 23006 + junk = caslab (ub, t) +23006 continue + if (.not.(lb .gt. ub))goto 23008 + call synerr (28Hillegal range in case label.) + ub = lb +23008 continue + if (.not.(swlast + 3 .gt. 1000))goto 23010 + call baderr (22Hswitch table overflow.) +23010 continue + i = swtop + 3 +23012 if (.not.(i .lt. swlast))goto 23014 + if (.not.(lb .le. swstak (i)))goto 23015 + goto 23014 +23015 continue + if (.not.(lb .le. swstak (i+1)))goto 23017 + call synerr (21Hduplicate case label.) +23017 continue +23016 continue +23013 i = i + 3 + goto 23012 +23014 continue + if (.not.(i .lt. swlast .and. ub .ge. swstak (i)))goto 23019 + call synerr (21Hduplicate case label.) +23019 continue + j = swlast +23021 if (.not.(j .gt. i))goto 23023 + swstak (j+2) = swstak (j-1) +23022 j = j - 1 + goto 23021 +23023 continue + swstak (i) = lb + swstak (i + 1) = ub + swstak (i + 2) = l + swstak (swtop + 1) = swstak (swtop + 1) + 1 + swlast = swlast + 3 + if (.not.(t .eq. 58))goto 23024 + goto 23005 +23024 continue + if (.not.(t .ne. 44))goto 23026 + call synerr (20Hillegal case syntax.) +23026 continue +23025 continue + goto 23004 +23005 continue + goto 23003 +23002 continue + t = gnbtok (tok, 100) + if (.not.(swstak (swtop + 2) .ne. 0))goto 23028 + call error (38Hmultiple defaults in switch statement.) + goto 23029 +23028 continue + swstak (swtop + 2) = l +23029 continue +23003 continue + if (.not.(t .eq. -1))goto 23030 + call synerr (15Hunexpected EOF.) + goto 23031 +23030 continue + if (.not.(t .ne. 58))goto 23032 + call error (39Hmissing colon in case or default label.) +23032 continue +23031 continue + xfer = 0 + call outcon (l) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/caslab.f b/unix/boot/spp/rpp/rppfor/caslab.f new file mode 100644 index 00000000..0262fadc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/caslab.f @@ -0,0 +1,54 @@ + integer function caslab (n, t) + integer n, t + integer tok(100) + integer i, s, lev + integer gnbtok, ctoi + caslab=0 + t = gnbtok (tok, 100) +23000 if (.not.(t .eq. 10))goto 23001 + t = gnbtok (tok, 100) + goto 23000 +23001 continue + if (.not.(t .eq. -1))goto 23002 + caslab=(t) + return +23002 continue + lev=0 +23004 if (.not.(t .eq. 40))goto 23006 + lev = lev + 1 +23005 t = gnbtok (tok, 100) + goto 23004 +23006 continue + if (.not.(t .eq. 45))goto 23007 + s = -1 + goto 23008 +23007 continue + s = +1 +23008 continue + if (.not.(t .eq. 45 .or. t .eq. 43))goto 23009 + t = gnbtok (tok, 100) +23009 continue + if (.not.(t .ne. 48))goto 23011 + goto 99 +c goto 23012 +23011 continue + i = 1 + n = s * ctoi (tok, i) +23012 continue + t=gnbtok(tok,100) +23013 if (.not.(t .eq. 41))goto 23015 + lev = lev - 1 +23014 t=gnbtok(tok,100) + goto 23013 +23015 continue + if (.not.(lev .ne. 0))goto 23016 + goto 99 +23016 continue +23018 if (.not.(t .eq. 10))goto 23019 + t = gnbtok (tok, 100) + goto 23018 +23019 continue + return +99 call synerr (19HInvalid case label.) + n = 0 + end diff --git a/unix/boot/spp/rpp/rppfor/declco.f b/unix/boot/spp/rpp/rppfor/declco.f new file mode 100644 index 00000000..683bd901 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/declco.f @@ -0,0 +1,120 @@ + subroutine declco (id) + integer id(100) + integer newid(100), tok, tokbl + integer junk, ludef, equal, gettok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer xptyp(9) + integer xpntr(7) + integer xfunc(7) + integer xsubr(7) + data xptyp(1)/105/,xptyp(2)/110/,xptyp(3)/116/,xptyp(4)/101/,xptyp + *(5)/103/,xptyp(6)/101/,xptyp(7)/114/,xptyp(8)/32/,xptyp(9)/-2/ + data xpntr(1)/120/,xpntr(2)/36/,xpntr(3)/112/,xpntr(4)/110/,xpntr( + *5)/116/,xpntr(6)/114/,xpntr(7)/-2/ + data xfunc(1)/120/,xfunc(2)/36/,xfunc(3)/102/,xfunc(4)/117/,xfunc( + *5)/110/,xfunc(6)/99/,xfunc(7)/-2/ + data xsubr(1)/120/,xsubr(2)/36/,xsubr(3)/115/,xsubr(4)/117/,xsubr( + *5)/98/,xsubr(6)/114/,xsubr(7)/-2/ + if (.not.(ludef (id, newid, xpptbl) .eq. 1))goto 23000 + if (.not.(equal (id, xpntr) .eq. 1))goto 23002 + tokbl = gettok (newid, 100) + if (.not.(tokbl .eq. 32))goto 23004 + tok = gettok (newid, 100) + goto 23005 +23004 continue + tok = tokbl +23005 continue + if (.not.(tok .eq. -166 .and. equal (newid, xfunc) .eq. 1))goto 2 + *3006 + call outtab + call outstr (xptyp) + junk = ludef (newid, newid, xpptbl) + call outstr (newid) + call eatup + call outdon + call poicod (0) + goto 23007 +23006 continue + call pbstr (newid) + call poicod (1) +23007 continue + goto 23003 +23002 continue + if (.not.(equal (id, xsubr) .eq. 1))goto 23008 + call outtab + call outstr (newid) + call eatup + call outdon + goto 23009 +23008 continue + call outtab + call outstr (newid) + call outch (32) +23009 continue +23003 continue + goto 23001 +23000 continue + call synerr (32HInvalid x$type type declaration.) +23001 continue + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/deftok.f b/unix/boot/spp/rpp/rppfor/deftok.f new file mode 100644 index 00000000..edd7213a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/deftok.f @@ -0,0 +1,237 @@ + integer function deftok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, c, defn (2048), mdefn (2048) + integer gtok + integer equal + integer ap, argstk (100), callst (50), nlb, plev (50), ifl + integer ludef, push, ifparm + integer balp(3) + integer pswrg(22) + data balp(1)/40/,balp(2)/41/,balp(3)/-2/ + data pswrg(1)/115/,pswrg(2)/119/,pswrg(3)/105/,pswrg(4)/116/,pswrg + *(5)/99/,pswrg(6)/104/,pswrg(7)/95/,pswrg(8)/110/,pswrg(9)/111/,psw + *rg(10)/95/,pswrg(11)/114/,pswrg(12)/97/,pswrg(13)/110/,pswrg(14)/1 + *03/,pswrg(15)/101/,pswrg(16)/95/,pswrg(17)/99/,pswrg(18)/104/,pswr + *g(19)/101/,pswrg(20)/99/,pswrg(21)/107/,pswrg(22)/-2/ + cp = 0 + ap = 1 + ep = 1 + t = gtok (token, toksiz) +23000 if (.not.(t .ne. -1))goto 23002 + if (.not.(t .eq. -9))goto 23003 + if (.not.(ludef (token, defn, deftbl) .eq. 0))goto 23005 + if (.not.(cp .eq. 0))goto 23007 + goto 23002 +23007 continue + call puttok (token) +23008 continue + goto 23006 +23005 continue + if (.not.(defn (1) .eq. -4))goto 23009 + call getdef (token, toksiz, defn, 2048) + call entdef (token, defn, deftbl) + goto 23010 +23009 continue + if (.not.(defn (1) .eq. -15 .or. defn (1) .eq. -16))goto 23011 + c = defn (1) + call getdef (token, toksiz, defn, 2048) + ifl = ludef (token, mdefn, deftbl) + if (.not.((ifl .eq. 1 .and. c .eq. -15) .or. (ifl .eq. 0 .and. c . + *eq. -16)))goto 23013 + call pbstr (defn) +23013 continue + goto 23012 +23011 continue + if (.not.(defn(1) .eq. -17 .and. cp .eq. 0))goto 23015 + if (.not.(gtok (defn, 2048) .eq. 32))goto 23017 + if (.not.(gtok (defn, 2048) .eq. -9))goto 23019 + if (.not.(equal (defn, pswrg) .eq. 1))goto 23021 + swinrg = 1 + goto 23022 +23021 continue + goto 10 +23022 continue + goto 23020 +23019 continue +10 call pbstr (defn) + call putbak (32) + goto 23002 +23020 continue + goto 23018 +23017 continue + call pbstr (defn) + goto 23002 +23018 continue + goto 23016 +23015 continue + cp = cp + 1 + if (.not.(cp .gt. 50))goto 23023 + call baderr (20Hcall stack overflow.) +23023 continue + callst (cp) = ap + ap = push (ep, argstk, ap) + call puttok (defn) + call putchr (-2) + ap = push (ep, argstk, ap) + call puttok (token) + call putchr (-2) + ap = push (ep, argstk, ap) + t = gtok (token, toksiz) + if (.not.(t .eq. 32))goto 23025 + t = gtok (token, toksiz) + call pbstr (token) + if (.not.(t .ne. 40))goto 23027 + call putbak (32) +23027 continue + goto 23026 +23025 continue + call pbstr (token) +23026 continue + if (.not.(t .ne. 40))goto 23029 + call pbstr (balp) + goto 23030 +23029 continue + if (.not.(ifparm (defn) .eq. 0))goto 23031 + call pbstr (balp) +23031 continue +23030 continue + plev (cp) = 0 +23016 continue +23012 continue +23010 continue +23006 continue + goto 23004 +23003 continue + if (.not.(t .eq. -69))goto 23033 + nlb = 1 +23035 continue + t = gtok (token, toksiz) + if (.not.(t .eq. -69))goto 23038 + nlb = nlb + 1 + goto 23039 +23038 continue + if (.not.(t .eq. -68))goto 23040 + nlb = nlb - 1 + if (.not.(nlb .eq. 0))goto 23042 + goto 23037 +23042 continue + goto 23041 +23040 continue + if (.not.(t .eq. -1))goto 23044 + call baderr (14HEOF in string.) +23044 continue +23041 continue +23039 continue + call puttok (token) +23036 goto 23035 +23037 continue + goto 23034 +23033 continue + if (.not.(cp .eq. 0))goto 23046 + goto 23002 +23046 continue + if (.not.(t .eq. 40))goto 23048 + if (.not.(plev (cp) .gt. 0))goto 23050 + call puttok (token) +23050 continue + plev (cp) = plev (cp) + 1 + goto 23049 +23048 continue + if (.not.(t .eq. 41))goto 23052 + plev (cp) = plev (cp) - 1 + if (.not.(plev (cp) .gt. 0))goto 23054 + call puttok (token) + goto 23055 +23054 continue + call putchr (-2) + call evalr (argstk, callst (cp), ap - 1) + ap = callst (cp) + ep = argstk (ap) + cp = cp - 1 +23055 continue + goto 23053 +23052 continue + if (.not.(t .eq. 44 .and. plev (cp) .eq. 1))goto 23056 + call putchr (-2) + ap = push (ep, argstk, ap) + goto 23057 +23056 continue + call puttok (token) +23057 continue +23053 continue +23049 continue +23047 continue +23034 continue +23004 continue +23001 t = gtok (token, toksiz) + goto 23000 +23002 continue + deftok = t + if (.not.(t .eq. -9))goto 23058 + call fold (token) +23058 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doarth.f b/unix/boot/spp/rpp/rppfor/doarth.f new file mode 100644 index 00000000..6d45409d --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doarth.f @@ -0,0 +1,93 @@ + subroutine doarth (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer k, l + integer ctoi + integer op + k = argstk (i + 2) + l = argstk (i + 4) + op = evalst (argstk (i + 3)) + if (.not.(op .eq. 43))goto 23000 + call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) + goto 23001 +23000 continue + if (.not.(op .eq. 45))goto 23002 + call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) + goto 23003 +23002 continue + if (.not.(op .eq. 42 ))goto 23004 + call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) + goto 23005 +23004 continue + if (.not.(op .eq. 47 ))goto 23006 + call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) + goto 23007 +23006 continue + call remark (11Harith error) +23007 continue +23005 continue +23003 continue +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/docode.f b/unix/boot/spp/rpp/rppfor/docode.f new file mode 100644 index 00000000..0d5dbdb9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/docode.f @@ -0,0 +1,87 @@ + subroutine docode (lab) + integer lab + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gnbtok + integer lexstr (100) + integer sdo(3) + data sdo(1)/100/,sdo(2)/111/,sdo(3)/-2/ + xfer = 0 + call outtab + call outstr (sdo) + call outch (32) + lab = labgen (2) + if (.not.(gnbtok (lexstr, 100) .eq. 48))goto 23000 + call outstr (lexstr) + goto 23001 +23000 continue + call pbstr (lexstr) + call outnum (lab) +23001 continue + call outch (32) + call eatup + call outdwe + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doif.f b/unix/boot/spp/rpp/rppfor/doif.f new file mode 100644 index 00000000..3eabc389 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doif.f @@ -0,0 +1,81 @@ + subroutine doif (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer a2, a3, a4, a5 + integer equal + if (.not.(j - i .lt. 5))goto 23000 + return +23000 continue + a2 = argstk (i + 2) + a3 = argstk (i + 3) + a4 = argstk (i + 4) + a5 = argstk (i + 5) + if (.not.(equal (evalst (a2), evalst (a3)) .eq. 1))goto 23002 + call pbstr (evalst (a4)) + goto 23003 +23002 continue + call pbstr (evalst (a5)) +23003 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/doincr.f b/unix/boot/spp/rpp/rppfor/doincr.f new file mode 100644 index 00000000..8bcc3e14 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/doincr.f @@ -0,0 +1,70 @@ + subroutine doincr (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer k + integer ctoi + k = argstk (i + 2) + call pbnum (ctoi (evalst, k) + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/domac.f b/unix/boot/spp/rpp/rppfor/domac.f new file mode 100644 index 00000000..b954ee64 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/domac.f @@ -0,0 +1,72 @@ + subroutine domac (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer a2, a3 + if (.not.(j - i .gt. 2))goto 23000 + a2 = argstk (i + 2) + a3 = argstk (i + 3) + call entdef (evalst (a2), evalst (a3), deftbl) +23000 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/dostat.f b/unix/boot/spp/rpp/rppfor/dostat.f new file mode 100644 index 00000000..038f5b72 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/dostat.f @@ -0,0 +1,7 @@ + subroutine dostat (lab) + integer lab + call indent (-1) + call outcon (lab) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/dosub.f b/unix/boot/spp/rpp/rppfor/dosub.f new file mode 100644 index 00000000..c0efa5cb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/dosub.f @@ -0,0 +1,90 @@ + subroutine dosub (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ap, fc, k, nc + integer ctoi, length + if (.not.(j - i .lt. 3))goto 23000 + return +23000 continue + if (.not.(j - i .lt. 4))goto 23002 + nc = 100 + goto 23003 +23002 continue + k = argstk (i + 4) + nc = ctoi (evalst, k) +23003 continue + k = argstk (i + 3) + ap = argstk (i + 2) + fc = ap + ctoi (evalst, k) - 1 + if (.not.(fc .ge. ap .and. fc .lt. ap + length (evalst (ap))))goto + * 23004 + k = fc + min0(nc, length (evalst (fc))) - 1 +23006 if (.not.(k .ge. fc))goto 23008 + call putbak (evalst (k)) +23007 k = k - 1 + goto 23006 +23008 continue +23004 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/eatup.f b/unix/boot/spp/rpp/rppfor/eatup.f new file mode 100644 index 00000000..65ba16b3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/eatup.f @@ -0,0 +1,127 @@ + subroutine eatup + integer ptoken (100), t, token (100) + integer gettok + integer nlpar, equal + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serror(6) + data serror(1)/101/,serror(2)/114/,serror(3)/114/,serror(4)/111/,s + *error(5)/114/,serror(6)/-2/ + nlpar = 0 + token(1) = -2 +23000 continue + call outstr (token) + t = gettok (token, 100) +23001 if (.not.(t .ne. 32 .and. t .ne. 9))goto 23000 +23002 continue + if (.not.(t .eq. -9))goto 23003 + if (.not.(equal (token, serror) .eq. 1))goto 23005 + ername = 1 +23005 continue +23003 continue + goto 10 +23007 continue + t = gettok (token, 100) +10 if (.not.(t .eq. 59 .or. t .eq. 10))goto 23010 + goto 23009 +23010 continue + if (.not.(t .eq. 125 .or. t .eq. 123))goto 23012 + call pbstr (token) + goto 23009 +23012 continue + if (.not.(t .eq. -1))goto 23014 + call synerr (15Hunexpected EOF.) + call pbstr (token) + goto 23009 +23014 continue + if (.not.(t .eq. 44 .or. t .eq. 43 .or. t .eq. 45 .or. t .eq. 42 . + *or. (t .eq. 47 .and. body .eq. 1) .or. t .eq. 40 .or. t .eq. 38 .o + *r. t .eq. 124 .or. t .eq. 33 .or. t .eq. 126 .or. t .eq. 126 .or. + *t .eq. 94 .or. t .eq. 61 .or. t .eq. 95))goto 23016 +23018 if (.not.(gettok (ptoken, 100) .eq. 10))goto 23019 + goto 23018 +23019 continue + call pbstr (ptoken) + if (.not.(t .eq. 95))goto 23020 + token (1) = -2 +23020 continue +23016 continue + if (.not.(t .eq. 40))goto 23022 + nlpar = nlpar + 1 + goto 23023 +23022 continue + if (.not.(t .eq. 41))goto 23024 + nlpar = nlpar - 1 +23024 continue +23023 continue + if (.not.(t .eq. -9))goto 23026 + call squash (token) +23026 continue + call outstr (token) +23008 if (.not.(nlpar .lt. 0))goto 23007 +23009 continue + if (.not.(nlpar .ne. 0))goto 23028 + call synerr (23Hunbalanced parentheses.) +23028 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/elseif.f b/unix/boot/spp/rpp/rppfor/elseif.f new file mode 100644 index 00000000..d0ecab46 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/elseif.f @@ -0,0 +1,8 @@ + subroutine elseif (lab) + integer lab + call outgo (lab+1) + call indent (-1) + call outcon (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/endcod.f b/unix/boot/spp/rpp/rppfor/endcod.f new file mode 100644 index 00000000..da8bfffc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/endcod.f @@ -0,0 +1,96 @@ + subroutine endcod (endstr) + integer endstr(1) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sret(7) + integer sepro(12) + data sret(1)/114/,sret(2)/101/,sret(3)/116/,sret(4)/117/,sret(5)/1 + *14/,sret(6)/110/,sret(7)/-2/ + data sepro(1)/99/,sepro(2)/97/,sepro(3)/108/,sepro(4)/108/,sepro(5 + *)/32/,sepro(6)/122/,sepro(7)/122/,sepro(8)/101/,sepro(9)/112/,sepr + *o(10)/114/,sepro(11)/111/,sepro(12)/-2/ + if (.not.(esp .ne. 0))goto 23000 + call synerr (36HUnmatched 'iferr' or 'then' keyword.) +23000 continue + esp = 0 + body = 0 + ername = 0 + if (.not.(errtbl .ne. 0))goto 23002 + call rmtabl (errtbl) +23002 continue + errtbl = 0 + memflg = 0 + if (.not.(retlab .ne. 0))goto 23004 + call outnum (retlab) +23004 continue + call outtab + call outstr (sepro) + call outdon + call outtab + call outstr (sret) + call outdon + col = 6 + call outtab + call outstr (endstr) + call outdon + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/entdef.f b/unix/boot/spp/rpp/rppfor/entdef.f new file mode 100644 index 00000000..ccbb82a3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entdef.f @@ -0,0 +1,12 @@ + subroutine entdef (name, defn, table) + integer name (100), defn (100) + integer table + integer lookup + integer text + integer sdupl + if (.not.(lookup (name, text, table) .eq. 1))goto 23000 + call dsfree (text) +23000 continue + call enter (name, sdupl (defn), table) + return + end diff --git a/unix/boot/spp/rpp/rppfor/entdkw.f b/unix/boot/spp/rpp/rppfor/entdkw.f new file mode 100644 index 00000000..d8ac6ea9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entdkw.f @@ -0,0 +1,14 @@ + subroutine entdkw + integer deft(2), prag(2) + integer defnam(7) + integer prgnam(7) + data defnam(1)/100/,defnam(2)/101/,defnam(3)/102/,defnam(4)/105/,d + *efnam(5)/110/,defnam(6)/101/,defnam(7)/-2/ + data prgnam(1)/112/,prgnam(2)/114/,prgnam(3)/97/,prgnam(4)/103/,pr + *gnam(5)/109/,prgnam(6)/97/,prgnam(7)/-2/ + data deft (1), deft (2) /-4, -2/ + data prag (1), prag (2) /-17, -2/ + call ulstal (defnam, deft) + call ulstal (prgnam, prag) + return + end diff --git a/unix/boot/spp/rpp/rppfor/entfkw.f b/unix/boot/spp/rpp/rppfor/entfkw.f new file mode 100644 index 00000000..ba484c96 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entfkw.f @@ -0,0 +1,69 @@ + subroutine entfkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sequiv(12) + data sequiv(1)/101/,sequiv(2)/113/,sequiv(3)/117/,sequiv(4)/105/,s + *equiv(5)/118/,sequiv(6)/97/,sequiv(7)/108/,sequiv(8)/101/,sequiv(9 + *)/110/,sequiv(10)/99/,sequiv(11)/101/,sequiv(12)/-2/ + call enter (sequiv, 0, fkwtbl) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/entrkw.f b/unix/boot/spp/rpp/rppfor/entrkw.f new file mode 100644 index 00000000..5deaa3de --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entrkw.f @@ -0,0 +1,151 @@ + subroutine entrkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sif(3) + integer selse(5) + integer swhile(6) + integer sdo(3) + integer sbreak(6) + integer snext(5) + integer sfor(4) + integer srept(7) + integer suntil(6) + integer sret(7) + integer sstr(7) + integer sswtch(7) + integer scase(5) + integer sdeflt(8) + integer send(4) + integer serrc0(7) + integer siferr(6) + integer sifno0(8) + integer sthen(5) + integer sbegin(6) + integer spoint(8) + integer sgoto(5) + data sif(1)/105/,sif(2)/102/,sif(3)/-2/ + data selse(1)/101/,selse(2)/108/,selse(3)/115/,selse(4)/101/,selse + *(5)/-2/ + data swhile(1)/119/,swhile(2)/104/,swhile(3)/105/,swhile(4)/108/,s + *while(5)/101/,swhile(6)/-2/ + data sdo(1)/100/,sdo(2)/111/,sdo(3)/-2/ + data sbreak(1)/98/,sbreak(2)/114/,sbreak(3)/101/,sbreak(4)/97/,sbr + *eak(5)/107/,sbreak(6)/-2/ + data snext(1)/110/,snext(2)/101/,snext(3)/120/,snext(4)/116/,snext + *(5)/-2/ + data sfor(1)/102/,sfor(2)/111/,sfor(3)/114/,sfor(4)/-2/ + data srept(1)/114/,srept(2)/101/,srept(3)/112/,srept(4)/101/,srept + *(5)/97/,srept(6)/116/,srept(7)/-2/ + data suntil(1)/117/,suntil(2)/110/,suntil(3)/116/,suntil(4)/105/,s + *until(5)/108/,suntil(6)/-2/ + data sret(1)/114/,sret(2)/101/,sret(3)/116/,sret(4)/117/,sret(5)/1 + *14/,sret(6)/110/,sret(7)/-2/ + data sstr(1)/115/,sstr(2)/116/,sstr(3)/114/,sstr(4)/105/,sstr(5)/1 + *10/,sstr(6)/103/,sstr(7)/-2/ + data sswtch(1)/115/,sswtch(2)/119/,sswtch(3)/105/,sswtch(4)/116/,s + *swtch(5)/99/,sswtch(6)/104/,sswtch(7)/-2/ + data scase(1)/99/,scase(2)/97/,scase(3)/115/,scase(4)/101/,scase(5 + *)/-2/ + data sdeflt(1)/100/,sdeflt(2)/101/,sdeflt(3)/102/,sdeflt(4)/97/,sd + *eflt(5)/117/,sdeflt(6)/108/,sdeflt(7)/116/,sdeflt(8)/-2/ + data send(1)/101/,send(2)/110/,send(3)/100/,send(4)/-2/ + data serrc0(1)/101/,serrc0(2)/114/,serrc0(3)/114/,serrc0(4)/99/,se + *rrc0(5)/104/,serrc0(6)/107/,serrc0(7)/-2/ + data siferr(1)/105/,siferr(2)/102/,siferr(3)/101/,siferr(4)/114/,s + *iferr(5)/114/,siferr(6)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/110/,sifno0(4)/111/,s + *ifno0(5)/101/,sifno0(6)/114/,sifno0(7)/114/,sifno0(8)/-2/ + data sthen(1)/116/,sthen(2)/104/,sthen(3)/101/,sthen(4)/110/,sthen + *(5)/-2/ + data sbegin(1)/98/,sbegin(2)/101/,sbegin(3)/103/,sbegin(4)/105/,sb + *egin(5)/110/,sbegin(6)/-2/ + data spoint(1)/112/,spoint(2)/111/,spoint(3)/105/,spoint(4)/110/,s + *point(5)/116/,spoint(6)/101/,spoint(7)/114/,spoint(8)/-2/ + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/-2/ + call enter (sif, -99, rkwtbl) + call enter (selse, -87, rkwtbl) + call enter (swhile, -95, rkwtbl) + call enter (sdo, -96, rkwtbl) + call enter (sbreak, -79, rkwtbl) + call enter (snext, -78, rkwtbl) + call enter (sfor, -94, rkwtbl) + call enter (srept, -93, rkwtbl) + call enter (suntil, -70, rkwtbl) + call enter (sret, -77, rkwtbl) + call enter (sstr, -75, rkwtbl) + call enter (sswtch, -92, rkwtbl) + call enter (scase, -91, rkwtbl) + call enter (sdeflt, -90, rkwtbl) + call enter (send, -82, rkwtbl) + call enter (serrc0, -84, rkwtbl) + call enter (siferr, -98, rkwtbl) + call enter (sifno0, -97, rkwtbl) + call enter (sthen, -86, rkwtbl) + call enter (sbegin, -83, rkwtbl) + call enter (spoint, -88, rkwtbl) + call enter (sgoto, -76, rkwtbl) + return + end +c sifno0 sifnoerr +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/entxkw.f b/unix/boot/spp/rpp/rppfor/entxkw.f new file mode 100644 index 00000000..e8b97b69 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/entxkw.f @@ -0,0 +1,172 @@ + subroutine entxkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sbool(7) + integer schar(7) + integer sshort(8) + integer sint(6) + integer slong(7) + integer sreal(7) + integer sdble(7) + integer scplx(7) + integer spntr(7) + integer sfchr(7) + integer sfunc(7) + integer ssubr(7) + integer sextn(7) + integer dbool(8) + integer dchar(10) + integer dshort(10) +C integer dint(10) +C integer dlong(10) +C integer dpntr(10) + integer dint(8) + integer dlong(8) + integer dpntr(8) + integer dreal(5) + integer ddble(17) + integer dcplx(8) + integer dfchr(10) + integer dfunc(9) + integer dsubr(11) + integer dextn(9) + data sbool(1)/120/,sbool(2)/36/,sbool(3)/98/,sbool(4)/111/,sbool(5 + *)/111/,sbool(6)/108/,sbool(7)/-2/ + data schar(1)/120/,schar(2)/36/,schar(3)/99/,schar(4)/104/,schar(5 + *)/97/,schar(6)/114/,schar(7)/-2/ + data sshort(1)/120/,sshort(2)/36/,sshort(3)/115/,sshort(4)/104/,ss + *hort(5)/111/,sshort(6)/114/,sshort(7)/116/,sshort(8)/-2/ + data sint(1)/120/,sint(2)/36/,sint(3)/105/,sint(4)/110/,sint(5)/11 + *6/,sint(6)/-2/ + data slong(1)/120/,slong(2)/36/,slong(3)/108/,slong(4)/111/,slong( + *5)/110/,slong(6)/103/,slong(7)/-2/ + data sreal(1)/120/,sreal(2)/36/,sreal(3)/114/,sreal(4)/101/,sreal( + *5)/97/,sreal(6)/108/,sreal(7)/-2/ + data sdble(1)/120/,sdble(2)/36/,sdble(3)/100/,sdble(4)/98/,sdble(5 + *)/108/,sdble(6)/101/,sdble(7)/-2/ + data scplx(1)/120/,scplx(2)/36/,scplx(3)/99/,scplx(4)/112/,scplx(5 + *)/108/,scplx(6)/120/,scplx(7)/-2/ + data spntr(1)/120/,spntr(2)/36/,spntr(3)/112/,spntr(4)/110/,spntr( + *5)/116/,spntr(6)/114/,spntr(7)/-2/ + data sfchr(1)/120/,sfchr(2)/36/,sfchr(3)/102/,sfchr(4)/99/,sfchr(5 + *)/104/,sfchr(6)/114/,sfchr(7)/-2/ + data sfunc(1)/120/,sfunc(2)/36/,sfunc(3)/102/,sfunc(4)/117/,sfunc( + *5)/110/,sfunc(6)/99/,sfunc(7)/-2/ + data ssubr(1)/120/,ssubr(2)/36/,ssubr(3)/115/,ssubr(4)/117/,ssubr( + *5)/98/,ssubr(6)/114/,ssubr(7)/-2/ + data sextn(1)/120/,sextn(2)/36/,sextn(3)/101/,sextn(4)/120/,sextn( + *5)/116/,sextn(6)/110/,sextn(7)/-2/ + data dbool(1)/108/,dbool(2)/111/,dbool(3)/103/,dbool(4)/105/,dbool + *(5)/99/,dbool(6)/97/,dbool(7)/108/,dbool(8)/-2/ + data dchar(1)/105/,dchar(2)/110/,dchar(3)/116/,dchar(4)/101/,dchar + *(5)/103/,dchar(6)/101/,dchar(7)/114/,dchar(8)/42/,dchar(9)/50/,dch + *ar(10)/-2/ + data dshort(1)/105/,dshort(2)/110/,dshort(3)/116/,dshort(4)/101/,d + *short(5)/103/,dshort(6)/101/,dshort(7)/114/,dshort(8)/42/,dshort(9 + *)/50/,dshort(10)/-2/ +C data dint(1)/105/,dint(2)/110/,dint(3)/116/,dint(4)/101/,dint(5)/1 +C *03/,dint(6)/101/,dint(7)/114/,dint(8)/42/,dint(9)/56/,dint(10)/-2/ + data dint(1)/105/,dint(2)/110/,dint(3)/116/,dint(4)/101/,dint(5)/1 + *03/,dint(6)/101/,dint(7)/114/,dint(8)/-2/ +C data dlong(1)/105/,dlong(2)/110/,dlong(3)/116/,dlong(4)/101/,dlong +C *(5)/103/,dlong(6)/101/,dlong(7)/114/,dlong(8)/42/,dlong(9)/52/,dlo +C *ng(10)/-2/ + data dlong(1)/105/,dlong(2)/110/,dlong(3)/116/,dlong(4)/101/,dlong + *(5)/103/,dlong(6)/101/,dlong(7)/114/,dlong(8)/-2/ +C data dpntr(1)/105/,dpntr(2)/110/,dpntr(3)/116/,dpntr(4)/101/,dpntr +C *(5)/103/,dpntr(6)/101/,dpntr(7)/114/,dpntr(8)/42/,dpntr(9)/56/,dpn +C *tr(10)/-2/ + data dpntr(1)/105/,dpntr(2)/110/,dpntr(3)/116/,dpntr(4)/101/,dpntr + *(5)/103/,dpntr(6)/101/,dpntr(7)/114/,dpntr(8)/-2/ + data dreal(1)/114/,dreal(2)/101/,dreal(3)/97/,dreal(4)/108/,dreal( + *5)/-2/ + data ddble(1)/100/,ddble(2)/111/,ddble(3)/117/,ddble(4)/98/,ddble( + *5)/108/,ddble(6)/101/,ddble(7)/32/,ddble(8)/112/,ddble(9)/114/,ddb + *le(10)/101/,ddble(11)/99/,ddble(12)/105/,ddble(13)/115/,ddble(14)/ + *105/,ddble(15)/111/,ddble(16)/110/,ddble(17)/-2/ + data dcplx(1)/99/,dcplx(2)/111/,dcplx(3)/109/,dcplx(4)/112/,dcplx( + *5)/108/,dcplx(6)/101/,dcplx(7)/120/,dcplx(8)/-2/ + data dfchr(1)/99/,dfchr(2)/104/,dfchr(3)/97/,dfchr(4)/114/,dfchr(5 + *)/97/,dfchr(6)/99/,dfchr(7)/116/,dfchr(8)/101/,dfchr(9)/114/,dfchr + *(10)/-2/ + data dfunc(1)/102/,dfunc(2)/117/,dfunc(3)/110/,dfunc(4)/99/,dfunc( + *5)/116/,dfunc(6)/105/,dfunc(7)/111/,dfunc(8)/110/,dfunc(9)/-2/ + data dsubr(1)/115/,dsubr(2)/117/,dsubr(3)/98/,dsubr(4)/114/,dsubr( + *5)/111/,dsubr(6)/117/,dsubr(7)/116/,dsubr(8)/105/,dsubr(9)/110/,ds + *ubr(10)/101/,dsubr(11)/-2/ + data dextn(1)/101/,dextn(2)/120/,dextn(3)/116/,dextn(4)/101/,dextn + *(5)/114/,dextn(6)/110/,dextn(7)/97/,dextn(8)/108/,dextn(9)/-2/ + call entdef (sbool, dbool, xpptbl) + call entdef (schar, dchar, xpptbl) + call entdef (sshort, dshort, xpptbl) + call entdef (sint, dint, xpptbl) + call entdef (slong, dlong, xpptbl) + call entdef (spntr, dpntr, xpptbl) + call entdef (sreal, dreal, xpptbl) + call entdef (sdble, ddble, xpptbl) + call entdef (scplx, dcplx, xpptbl) + call entdef (sfchr, dfchr, xpptbl) + call entdef (sfunc, dfunc, xpptbl) + call entdef (ssubr, dsubr, xpptbl) + call entdef (sextn, dextn, xpptbl) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/errchk.f b/unix/boot/spp/rpp/rppfor/errchk.f new file mode 100644 index 00000000..140ae204 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errchk.f @@ -0,0 +1,124 @@ + subroutine errchk + integer tok, lastt0, gnbtok, token(100) + integer ntok + integer mktabl + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serrc0(27) + integer serrd0(31) + data serrc0(1)/108/,serrc0(2)/111/,serrc0(3)/103/,serrc0(4)/105/,s + *errc0(5)/99/,serrc0(6)/97/,serrc0(7)/108/,serrc0(8)/32/,serrc0(9)/ + *120/,serrc0(10)/101/,serrc0(11)/114/,serrc0(12)/102/,serrc0(13)/10 + *8/,serrc0(14)/103/,serrc0(15)/44/,serrc0(16)/32/,serrc0(17)/120/,s + *errc0(18)/101/,serrc0(19)/114/,serrc0(20)/112/,serrc0(21)/97/,serr + *c0(22)/100/,serrc0(23)/40/,serrc0(24)/56/,serrc0(25)/52/,serrc0(26 + *)/41/,serrc0(27)/-2/ + data serrd0(1)/99/,serrd0(2)/111/,serrd0(3)/109/,serrd0(4)/109/,se + *rrd0(5)/111/,serrd0(6)/110/,serrd0(7)/32/,serrd0(8)/47/,serrd0(9)/ + *120/,serrd0(10)/101/,serrd0(11)/114/,serrd0(12)/99/,serrd0(13)/111 + */,serrd0(14)/109/,serrd0(15)/47/,serrd0(16)/32/,serrd0(17)/120/,se + *rrd0(18)/101/,serrd0(19)/114/,serrd0(20)/102/,serrd0(21)/108/,serr + *d0(22)/103/,serrd0(23)/44/,serrd0(24)/32/,serrd0(25)/120/,serrd0(2 + *6)/101/,serrd0(27)/114/,serrd0(28)/112/,serrd0(29)/97/,serrd0(30)/ + *100/,serrd0(31)/-2/ + ntok = 0 + tok = 0 +23000 continue + lastt0 = tok + tok = gnbtok (token, 100) + I23003=(tok) + goto 23003 +23005 continue + if (.not.(errtbl .eq. 0))goto 23006 + errtbl = mktabl(0) + call outtab + call outstr (serrc0) + call outdon + call outtab + call outstr (serrd0) + call outdon +23006 continue + call enter (token, 0, errtbl) + goto 23004 +23008 continue + goto 23004 +23009 continue + if (.not.(lastt0 .ne. 44))goto 23010 + goto 23002 +23010 continue + goto 23004 +23012 continue + call synerr (35HSyntax error in ERRCHK declaration.) + goto 23004 +23003 continue + if (I23003.eq.-9)goto 23005 + if (I23003.eq.10)goto 23009 + if (I23003.eq.44)goto 23008 + goto 23012 +23004 continue +23001 goto 23000 +23002 continue + end +c lastt0 last_tok +c logic0 logical_column +c serrc0 serrcom1 +c serrd0 serrcom2 diff --git a/unix/boot/spp/rpp/rppfor/errgo.f b/unix/boot/spp/rpp/rppfor/errgo.f new file mode 100644 index 00000000..040a5ce7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errgo.f @@ -0,0 +1,84 @@ + subroutine errgo + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer serrc0(13) + data serrc0(1)/105/,serrc0(2)/102/,serrc0(3)/32/,serrc0(4)/40/,ser + *rc0(5)/120/,serrc0(6)/101/,serrc0(7)/114/,serrc0(8)/102/,serrc0(9) + */108/,serrc0(10)/103/,serrc0(11)/41/,serrc0(12)/32/,serrc0(13)/-2/ + if (.not.(ername .eq. 1))goto 23000 + call outtab + if (.not.(esp .gt. 0))goto 23002 + if (.not.(errstk(esp) .gt. 0))goto 23004 + call outstr (serrc0) + call ogotos (errstk(esp)+2, 0) +23004 continue + goto 23003 +23002 continue + call outstr (serrc0) + call ogotos (retlab, 0) + call outdon +23003 continue + ername = 0 +23000 continue + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/errorc.f b/unix/boot/spp/rpp/rppfor/errorc.f new file mode 100644 index 00000000..d587a001 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/errorc.f @@ -0,0 +1,73 @@ + subroutine errorc (str) + integer str(1) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + xfer = 1 + call outstr (str) + call balpar + ername = 0 + call outdon + call outtab + call ogotos (retlab, 0) + call outdon + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/evalr.f b/unix/boot/spp/rpp/rppfor/evalr.f new file mode 100644 index 00000000..f471c0b0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/evalr.f @@ -0,0 +1,134 @@ + subroutine evalr (argstk, i, j) + integer argstk (100), i, j + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer argno, k, m, n, t, td, instr0, delim + external index + integer index, length + integer digits(11) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + t = argstk (i) + td = evalst (t) + if (.not.(td .eq. -10))goto 23000 + call domac (argstk, i, j) + goto 23001 +23000 continue + if (.not.(td .eq. -12))goto 23002 + call doincr (argstk, i, j) + goto 23003 +23002 continue + if (.not.(td .eq. -13))goto 23004 + call dosub (argstk, i, j) + goto 23005 +23004 continue + if (.not.(td .eq. -11))goto 23006 + call doif (argstk, i, j) + goto 23007 +23006 continue + if (.not.(td .eq. -14))goto 23008 + call doarth (argstk, i, j) + goto 23009 +23008 continue + instr0 = 0 + k = t + length (evalst (t)) - 1 +23010 if (.not.(k .gt. t))goto 23012 + if (.not.(evalst(k) .eq. 39 .or. evalst(k) .eq. 34))goto 23013 + if (.not.(instr0 .eq. 0))goto 23015 + delim = evalst(k) + instr0 = 1 + goto 23016 +23015 continue + instr0 = 0 +23016 continue + call putbak (evalst(k)) + goto 23014 +23013 continue + if (.not.(evalst(k-1) .ne. 36 .or. instr0 .eq. 1))goto 23017 + call putbak (evalst (k)) + goto 23018 +23017 continue + argno = index (digits, evalst (k)) - 1 + if (.not.(argno .ge. 0 .and. argno .lt. j - i))goto 23019 + n = i + argno + 1 + m = argstk (n) + call pbstr (evalst (m)) +23019 continue + k = k - 1 +23018 continue +23014 continue +23011 k = k - 1 + goto 23010 +23012 continue + if (.not.(k .eq. t))goto 23021 + call putbak (evalst (k)) +23021 continue +23009 continue +23007 continue +23005 continue +23003 continue +23001 continue + return + end +c logic0 logical_column +c instr0 in_string diff --git a/unix/boot/spp/rpp/rppfor/finit.f b/unix/boot/spp/rpp/rppfor/finit.f new file mode 100644 index 00000000..eef0ee6e --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/finit.f @@ -0,0 +1,79 @@ + subroutine finit + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + outp = 0 + level = 1 + linect (1) = 0 + sbp = 1 + fnamp = 2 + fnames (1) = -2 + bp = 3192 + buf (bp) = -2 + fordep = 0 + fcname (1) = -2 + swtop = 0 + swlast = 1 + swvnum = 0 + swvlev = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/forcod.f b/unix/boot/spp/rpp/rppfor/forcod.f new file mode 100644 index 00000000..3d855456 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/forcod.f @@ -0,0 +1,183 @@ + subroutine forcod (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, token (100) + integer gettok, gnbtok + integer i, j, nlpar + integer length, labgen + integer ifnot(10) + integer serrc0(22) + data ifnot(1)/105/,ifnot(2)/102/,ifnot(3)/32/,ifnot(4)/40/,ifnot(5 + *)/46/,ifnot(6)/110/,ifnot(7)/111/,ifnot(8)/116/,ifnot(9)/46/,ifnot + *(10)/-2/ + data serrc0(1)/46/,serrc0(2)/97/,serrc0(3)/110/,serrc0(4)/100/,ser + *rc0(5)/46/,serrc0(6)/40/,serrc0(7)/46/,serrc0(8)/110/,serrc0(9)/11 + *1/,serrc0(10)/116/,serrc0(11)/46/,serrc0(12)/120/,serrc0(13)/101/, + *serrc0(14)/114/,serrc0(15)/102/,serrc0(16)/108/,serrc0(17)/103/,se + *rrc0(18)/41/,serrc0(19)/41/,serrc0(20)/41/,serrc0(21)/32/,serrc0(2 + *2)/-2/ + lab = labgen (3) + call outcon (0) + if (.not.(gnbtok (token, 100) .ne. 40))goto 23000 + call synerr (19Hmissing left paren.) + return +23000 continue + if (.not.(gnbtok (token, 100) .ne. 59))goto 23002 + call pbstr (token) + call outtab + call eatup + call outdwe +23002 continue + if (.not.(gnbtok (token, 100) .eq. 59))goto 23004 + call outcon (lab) + goto 23005 +23004 continue + call pbstr (token) + call outnum (lab) + call outtab + call outstr (ifnot) + call outch (40) + nlpar = 0 +23006 if (.not.(nlpar .ge. 0))goto 23007 + t = gettok (token, 100) + if (.not.(t .eq. 59))goto 23008 + goto 23007 +23008 continue + if (.not.(t .eq. 40))goto 23010 + nlpar = nlpar + 1 + goto 23011 +23010 continue + if (.not.(t .eq. 41))goto 23012 + nlpar = nlpar - 1 +23012 continue +23011 continue + if (.not.(t .eq. -1))goto 23014 + call pbstr (token) + return +23014 continue + if (.not.(t .eq. -9))goto 23016 + call squash (token) +23016 continue + if (.not.(t .ne. 10 .and. t .ne. 95))goto 23018 + call outstr (token) +23018 continue + goto 23006 +23007 continue + if (.not.(ername .eq. 1))goto 23020 + call outstr (serrc0) + goto 23021 +23020 continue + call outch (41) + call outch (41) + call outch (32) +23021 continue + call outgo (lab+2) + if (.not.(nlpar .lt. 0))goto 23022 + call synerr (19Hinvalid for clause.) +23022 continue +23005 continue + fordep = fordep + 1 + j = 1 + i = 1 +23024 if (.not.(i .lt. fordep))goto 23026 + j = j + length (forstk (j)) + 1 +23025 i = i + 1 + goto 23024 +23026 continue + forstk (j) = -2 + nlpar = 0 + t = gnbtok (token, 100) + call pbstr (token) +23027 if (.not.(nlpar .ge. 0))goto 23028 + t = gettok (token, 100) + if (.not.(t .eq. 40))goto 23029 + nlpar = nlpar + 1 + goto 23030 +23029 continue + if (.not.(t .eq. 41))goto 23031 + nlpar = nlpar - 1 +23031 continue +23030 continue + if (.not.(t .eq. -1))goto 23033 + call pbstr (token) + goto 23028 +23033 continue + if (.not.(nlpar .ge. 0 .and. t .ne. 10 .and. t .ne. 95))goto 23035 + if (.not.(t .eq. -9))goto 23037 + call squash (token) +23037 continue + if (.not.(j + length (token) .ge. 200))goto 23039 + call baderr (20Hfor clause too long.) +23039 continue + call scopy (token, 1, forstk, j) + j = j + length (token) +23035 continue + goto 23027 +23028 continue + lab = lab + 1 + call indent (1) + call errgo + return + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/fors.f b/unix/boot/spp/rpp/rppfor/fors.f new file mode 100644 index 00000000..cde5f501 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/fors.f @@ -0,0 +1,87 @@ + subroutine fors (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i, j + integer length + xfer = 0 + call outnum (lab) + j = 1 + i = 1 +23000 if (.not.(i .lt. fordep))goto 23002 + j = j + length (forstk (j)) + 1 +23001 i = i + 1 + goto 23000 +23002 continue + if (.not.(length (forstk (j)) .gt. 0))goto 23003 + call outtab + call outstr (forstk (j)) + call outdon +23003 continue + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + fordep = fordep - 1 + ername = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/getdef.f b/unix/boot/spp/rpp/rppfor/getdef.f new file mode 100644 index 00000000..06644ec7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/getdef.f @@ -0,0 +1,136 @@ + subroutine getdef (token, toksiz, defn, defsiz) + integer token (100), defn (2048) + integer toksiz, defsiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c, t, ptoken (100) + integer gtok, ngetch + integer i, nlpar + call skpblk + c = gtok (ptoken, 100) + if (.not.(c .eq. 40))goto 23000 + t = 40 + goto 23001 +23000 continue + t = 32 + call pbstr (ptoken) +23001 continue + call skpblk + if (.not.(gtok (token, toksiz) .ne. -9))goto 23002 + call baderr (22Hnon-alphanumeric name.) +23002 continue + call skpblk + c = gtok (ptoken, 100) + if (.not.(t .eq. 32))goto 23004 + call pbstr (ptoken) + i = 1 +23006 continue + c = ngetch (c) + if (.not.(i .gt. defsiz))goto 23009 + call baderr (20Hdefinition too long.) +23009 continue + defn (i) = c + i = i + 1 +23007 if (.not.(c .eq. 35 .or. c .eq. 10 .or. c .eq. -1))goto 23006 +23008 continue + if (.not.(c .eq. 35))goto 23011 + call putbak (c) +23011 continue + goto 23005 +23004 continue + if (.not.(t .eq. 40))goto 23013 + if (.not.(c .ne. 44))goto 23015 + call baderr (24Hmissing comma in define.) +23015 continue + nlpar = 0 + i = 1 +23017 if (.not.(nlpar .ge. 0))goto 23019 + if (.not.(i .gt. defsiz))goto 23020 + call baderr (20Hdefinition too long.) + goto 23021 +23020 continue + if (.not.(ngetch (defn (i)) .eq. -1))goto 23022 + call baderr (20Hmissing right paren.) + goto 23023 +23022 continue + if (.not.(defn (i) .eq. 40))goto 23024 + nlpar = nlpar + 1 + goto 23025 +23024 continue + if (.not.(defn (i) .eq. 41))goto 23026 + nlpar = nlpar - 1 +23026 continue +23025 continue +23023 continue +23021 continue +23018 i = i + 1 + goto 23017 +23019 continue + goto 23014 +23013 continue + call baderr (19Hgetdef is confused.) +23014 continue +23005 continue + defn (i - 1) = -2 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gettok.f b/unix/boot/spp/rpp/rppfor/gettok.f new file mode 100644 index 00000000..ed74b2f7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gettok.f @@ -0,0 +1,104 @@ + integer function gettok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer equal + integer t, deftok + integer ssubr(7) + integer sfunc(7) + data ssubr(1)/120/,ssubr(2)/36/,ssubr(3)/115/,ssubr(4)/117/,ssubr( + *5)/98/,ssubr(6)/114/,ssubr(7)/-2/ + data sfunc(1)/120/,sfunc(2)/36/,sfunc(3)/102/,sfunc(4)/117/,sfunc( + *5)/110/,sfunc(6)/99/,sfunc(7)/-2/ + gettok = deftok (token, toksiz) + if (.not.(gettok .ne. -1))goto 23000 + if (.not.(gettok .eq. -166))goto 23002 + if (.not.(equal (token, sfunc) .eq. 1))goto 23004 + call skpblk + t = deftok (fcname, 30) + call pbstr (fcname) + if (.not.(t .ne. -9))goto 23006 + call synerr (22HMissing function name.) +23006 continue + call putbak (32) + swvnum = 0 + swvlev = 0 + return +23004 continue + if (.not.(equal (token, ssubr) .eq. 1))goto 23008 + swvnum = 0 + swvlev = 0 + return +23008 continue + return +23009 continue +23005 continue +23002 continue + return +23000 continue + token (1) = -1 + token (2) = -2 + gettok = -1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gnbtok.f b/unix/boot/spp/rpp/rppfor/gnbtok.f new file mode 100644 index 00000000..ac234f7f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gnbtok.f @@ -0,0 +1,73 @@ + integer function gnbtok (token, toksiz) + integer token (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gettok + call skpblk +23000 continue + gnbtok = gettok (token, toksiz) +23001 if (.not.(gnbtok .ne. 32))goto 23000 +23002 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gocode.f b/unix/boot/spp/rpp/rppfor/gocode.f new file mode 100644 index 00000000..627bc5d9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gocode.f @@ -0,0 +1,83 @@ + subroutine gocode + integer token (100), t + integer gnbtok + integer ctoi, i + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + t = gnbtok (token, 100) + if (.not.(t .ne. 48))goto 23000 + call synerr (23HInvalid label for goto.) + goto 23001 +23000 continue + call outtab + i = 1 + call ogotos (ctoi(token,i), 0) +23001 continue + xfer = 1 + t=gnbtok(token,100) +23002 if (.not.(t .eq. 10))goto 23004 +23003 t=gnbtok(token,100) + goto 23002 +23004 continue + call pbstr (token) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/gtok.f b/unix/boot/spp/rpp/rppfor/gtok.f new file mode 100644 index 00000000..5b021e8b --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/gtok.f @@ -0,0 +1,213 @@ + integer function gtok (lexstr, toksiz) + integer lexstr (100) + integer toksiz + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c + integer ngetch + integer i + c = ngetch (lexstr (1)) + if (.not.(c .eq. 32 .or. c .eq. 9))goto 23000 + lexstr (1) = 32 +23002 if (.not.(c .eq. 32 .or. c .eq. 9))goto 23003 + c = ngetch (c) + goto 23002 +23003 continue + if (.not.(c .eq. 35))goto 23004 +23006 if (.not.(ngetch (c) .ne. 10))goto 23007 + goto 23006 +23007 continue +23004 continue + if (.not.(c .ne. 10))goto 23008 + call putbak (c) + goto 23009 +23008 continue + lexstr (1) = 10 +23009 continue + lexstr (2) = -2 + gtok = lexstr (1) + return +23000 continue + i = 1 + if (.not.(((65.le.c.and.c.le.90).or.(97.le.c.and.c.le.122))))goto + *23010 + gtok = -9 + if (.not.(c .eq. 120))goto 23012 + c = ngetch (lexstr(2)) + if (.not.(c .eq. 36))goto 23014 + gtok = -166 + i = 2 + goto 23015 +23014 continue + call putbak (c) +23015 continue +23012 continue +23016 if (.not.(i .lt. toksiz - 2))goto 23018 + c = ngetch (lexstr(i+1)) + if (.not.(.not.((65.le.c.and.c.le.90).or.(97.le.c.and.c.le.122)) . + *and. .not.(48.le.c.and.c.le.57) .and. c .ne. 95))goto 23019 + goto 23018 +23019 continue +23017 i=i+1 + goto 23016 +23018 continue + call putbak (c) + goto 23011 +23010 continue + if (.not.((48.le.c.and.c.le.57)))goto 23021 + i=1 +23023 if (.not.(i .lt. toksiz - 2))goto 23025 + c = ngetch (lexstr (i + 1)) + if (.not.(.not.(48.le.c.and.c.le.57)))goto 23026 + goto 23025 +23026 continue +23024 i=i+1 + goto 23023 +23025 continue + call putbak (c) + gtok = 48 + goto 23022 +23021 continue + if (.not.(c .eq. 91))goto 23028 + lexstr (1) = 123 + gtok = 123 + goto 23029 +23028 continue + if (.not.(c .eq. 93))goto 23030 + lexstr (1) = 125 + gtok = 125 + goto 23031 +23030 continue + if (.not.(c .eq. 36))goto 23032 + if (.not.(ngetch (lexstr (2)) .eq. 40))goto 23034 + i = 2 + gtok = -69 + goto 23035 +23034 continue + if (.not.(lexstr (2) .eq. 41))goto 23036 + i = 2 + gtok = -68 + goto 23037 +23036 continue + call putbak (lexstr (2)) + gtok = 36 +23037 continue +23035 continue + goto 23033 +23032 continue + if (.not.(c .eq. 39 .or. c .eq. 34))goto 23038 + gtok = c + i = 2 +23040 if (.not.(ngetch (lexstr (i)) .ne. lexstr (1)))goto 23042 + if (.not.(lexstr (i) .eq. 95))goto 23043 + if (.not.(ngetch (c) .eq. 10))goto 23045 +23047 if (.not.(c .eq. 10 .or. c .eq. 32 .or. c .eq. 9))goto 23048 + c = ngetch (c) + goto 23047 +23048 continue + lexstr (i) = c + goto 23046 +23045 continue + call putbak (c) +23046 continue +23043 continue + if (.not.(lexstr (i) .eq. 10 .or. i .ge. toksiz - 1))goto 23049 + call synerr (14Hmissing quote.) + lexstr (i) = lexstr (1) + call putbak (10) + goto 23042 +23049 continue +23041 i = i + 1 + goto 23040 +23042 continue + goto 23039 +23038 continue + if (.not.(c .eq. 35))goto 23051 +23053 if (.not.(ngetch (lexstr (1)) .ne. 10))goto 23054 + goto 23053 +23054 continue + gtok = 10 + goto 23052 +23051 continue + if (.not.(c .eq. 62 .or. c .eq. 60 .or. c .eq. 126 .or. c .eq. 33 + *.or. c .eq. 126 .or. c .eq. 94 .or. c .eq. 61 .or. c .eq. 38 .or. + *c .eq. 124))goto 23055 + call relate (lexstr, i) + gtok = c + goto 23056 +23055 continue + gtok = c +23056 continue +23052 continue +23039 continue +23033 continue +23031 continue +23029 continue +23022 continue +23011 continue + if (.not.(i .ge. toksiz - 1))goto 23057 + call synerr (15Htoken too long.) +23057 continue + lexstr (i + 1) = -2 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ifcode.f b/unix/boot/spp/rpp/rppfor/ifcode.f new file mode 100644 index 00000000..8fbf5763 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifcode.f @@ -0,0 +1,71 @@ + subroutine ifcode (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer labgen + xfer = 0 + lab = labgen (2) + call ifgo (lab) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/iferrc.f b/unix/boot/spp/rpp/rppfor/iferrc.f new file mode 100644 index 00000000..f7abae81 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/iferrc.f @@ -0,0 +1,168 @@ + subroutine iferrc (lab, sense) + integer lab, sense + integer labgen, nlpar + integer t, gettok, gnbtok, token(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer errpsh(12) + integer siferr(20) + integer sifno0(15) + data errpsh(1)/99/,errpsh(2)/97/,errpsh(3)/108/,errpsh(4)/108/,err + *psh(5)/32/,errpsh(6)/120/,errpsh(7)/101/,errpsh(8)/114/,errpsh(9)/ + *112/,errpsh(10)/115/,errpsh(11)/104/,errpsh(12)/-2/ + data siferr(1)/105/,siferr(2)/102/,siferr(3)/32/,siferr(4)/40/,sif + *err(5)/46/,siferr(6)/110/,siferr(7)/111/,siferr(8)/116/,siferr(9)/ + *46/,siferr(10)/120/,siferr(11)/101/,siferr(12)/114/,siferr(13)/112 + */,siferr(14)/111/,siferr(15)/112/,siferr(16)/40/,siferr(17)/41/,si + *ferr(18)/41/,siferr(19)/32/,siferr(20)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/32/,sifno0(4)/40/,sif + *no0(5)/120/,sifno0(6)/101/,sifno0(7)/114/,sifno0(8)/112/,sifno0(9) + */111/,sifno0(10)/112/,sifno0(11)/40/,sifno0(12)/41/,sifno0(13)/41/ + *,sifno0(14)/32/,sifno0(15)/-2/ + xfer = 0 + lab = labgen (3) + call outtab + call outstr (errpsh) + call outdon + I23000=(gnbtok (token, 100)) + goto 23000 +23002 continue + call outtab + goto 23001 +23003 continue + call pbstr (token) + esp = esp + 1 + if (.not.(esp .ge. 30))goto 23004 + call baderr (35HIferr statements nested too deeply.) +23004 continue + errstk(esp) = lab + return +23006 continue + call synerr (19HMissing left paren.) + return +23000 continue + if (I23000.eq.40)goto 23002 + if (I23000.eq.123)goto 23003 + goto 23006 +23001 continue + nlpar = 1 + token(1) = -2 + esp = esp + 1 + if (.not.(esp .ge. 30))goto 23007 + call baderr (35HIferr statements nested too deeply.) +23007 continue + errstk(esp) = 0 +23009 continue + call outstr (token) + t = gettok (token, 100) + if (.not.(t .eq. 59 .or. t .eq. 123 .or. t .eq. 125 .or. t .eq. -1 + *))goto 23012 + call pbstr (token) + goto 23011 +23012 continue + if (.not.(t .eq. 10))goto 23014 + token (1) = -2 + goto 23015 +23014 continue + if (.not.(t .eq. 40))goto 23016 + nlpar = nlpar + 1 + goto 23017 +23016 continue + if (.not.(t .eq. 41))goto 23018 + nlpar = nlpar - 1 + goto 23019 +23018 continue + if (.not.(t .eq. 59))goto 23020 + call outdon + call outtab + goto 23021 +23020 continue + if (.not.(t .eq. -9))goto 23022 + call squash (token) +23022 continue +23021 continue +23019 continue +23017 continue +23015 continue +23010 if (.not.(nlpar .le. 0))goto 23009 +23011 continue + esp = esp - 1 + ername = 0 + if (.not.(nlpar .ne. 0))goto 23024 + call synerr (33HMissing parenthesis in condition.) + goto 23025 +23024 continue + call outdon +23025 continue + call outtab + if (.not.(sense .eq. 1))goto 23026 + call outstr (siferr) + goto 23027 +23026 continue + call outstr (sifno0) +23027 continue + call outgo (lab) + call indent (1) + return + end +c sifno0 sifnoerr +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ifgo.f b/unix/boot/spp/rpp/rppfor/ifgo.f new file mode 100644 index 00000000..5f2bb654 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifgo.f @@ -0,0 +1,88 @@ + subroutine ifgo (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ifnot(10) + integer serrc0(21) + data ifnot(1)/105/,ifnot(2)/102/,ifnot(3)/32/,ifnot(4)/40/,ifnot(5 + *)/46/,ifnot(6)/110/,ifnot(7)/111/,ifnot(8)/116/,ifnot(9)/46/,ifnot + *(10)/-2/ + data serrc0(1)/46/,serrc0(2)/97/,serrc0(3)/110/,serrc0(4)/100/,ser + *rc0(5)/46/,serrc0(6)/40/,serrc0(7)/46/,serrc0(8)/110/,serrc0(9)/11 + *1/,serrc0(10)/116/,serrc0(11)/46/,serrc0(12)/120/,serrc0(13)/101/, + *serrc0(14)/114/,serrc0(15)/102/,serrc0(16)/108/,serrc0(17)/103/,se + *rrc0(18)/41/,serrc0(19)/41/,serrc0(20)/32/,serrc0(21)/-2/ + call outtab + call outstr (ifnot) + call balpar + if (.not.(ername .eq. 1))goto 23000 + call outstr (serrc0) + goto 23001 +23000 continue + call outch (41) + call outch (32) +23001 continue + call outgo (lab) + call errgo + end +c logic0 logical_column +c serrc0 serrchk diff --git a/unix/boot/spp/rpp/rppfor/ifparm.f b/unix/boot/spp/rpp/rppfor/ifparm.f new file mode 100644 index 00000000..4334a444 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ifparm.f @@ -0,0 +1,26 @@ + integer function ifparm (strng) + integer strng (100) + integer c + external index + integer i, index, type + c = strng (1) + if (.not.(c .eq. -12 .or. c .eq. -13 .or. c .eq. -11 .or. c .eq. - + *14 .or. c .eq. -10))goto 23000 + ifparm = 1 + goto 23001 +23000 continue + ifparm = 0 + i = 1 +23002 if (.not.(index (strng (i), 36) .gt. 0))goto 23004 + i = i + index (strng (i), 36) + if (.not.(type (strng (i)) .eq. 48))goto 23005 + if (.not.(type (strng (i + 1)) .ne. 48))goto 23007 + ifparm = 1 + goto 23004 +23007 continue +23005 continue +23003 goto 23002 +23004 continue +23001 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/indent.f b/unix/boot/spp/rpp/rppfor/indent.f new file mode 100644 index 00000000..40b99b9f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/indent.f @@ -0,0 +1,68 @@ + subroutine indent (nleve0) + integer nleve0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + logic0 = logic0 + (nleve0 * 3) + col = max0(6, min0(30, logic0)) + end +c logic0 logical_column +c nleve0 nlevels diff --git a/unix/boot/spp/rpp/rppfor/initkw.f b/unix/boot/spp/rpp/rppfor/initkw.f new file mode 100644 index 00000000..c5acfec0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/initkw.f @@ -0,0 +1,86 @@ + subroutine initkw + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer mktabl + call dsinit (60000) + deftbl = mktabl (1) + call entdkw + rkwtbl = mktabl (1) + call entrkw + fkwtbl = mktabl (0) + call entfkw + namtbl = mktabl (1) + xpptbl = mktabl (1) + call entxkw + gentbl = mktabl (0) + errtbl = 0 + label = 100 + smem(1) = -2 + body = 0 + dbgout = 0 + dbglev = 0 + memflg = 0 + swinrg = 0 + col = 6 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/labelc.f b/unix/boot/spp/rpp/rppfor/labelc.f new file mode 100644 index 00000000..24d88008 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/labelc.f @@ -0,0 +1,75 @@ + subroutine labelc (lexstr) + integer lexstr (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer length, l + xfer = 0 + l = length (lexstr) + if (.not.(l .ge. 3 .and. l .lt. 4))goto 23000 + call synerr (53HWarning: statement labels 100 and above are reserv + *ed.) +23000 continue + call outstr (lexstr) + call outtab + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/labgen.f b/unix/boot/spp/rpp/rppfor/labgen.f new file mode 100644 index 00000000..ab7538f4 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/labgen.f @@ -0,0 +1,68 @@ + integer function labgen (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + labgen = label + label = label + (n / 10 + 1) * 10 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/lex.f b/unix/boot/spp/rpp/rppfor/lex.f new file mode 100644 index 00000000..6f2243f4 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/lex.f @@ -0,0 +1,119 @@ + integer function lex (lexstr) + integer lexstr (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer gnbtok, t, c + integer lookup, n + integer sdefa0(8) + data sdefa0(1)/100/,sdefa0(2)/101/,sdefa0(3)/102/,sdefa0(4)/97/,sd + *efa0(5)/117/,sdefa0(6)/108/,sdefa0(7)/116/,sdefa0(8)/-2/ + lex = gnbtok (lexstr, 100) +23000 if (.not.(lex .eq. 10))goto 23002 +23001 lex = gnbtok (lexstr, 100) + goto 23000 +23002 continue + if (.not.(lex .eq. -1 .or. lex .eq. 59 .or. lex .eq. 123 .or. lex + *.eq. 125))goto 23003 + return +23003 continue + if (.not.(lex .eq. 48))goto 23005 + lex = -89 + goto 23006 +23005 continue + if (.not.(lex .eq. 37))goto 23007 + lex = -85 + goto 23008 +23007 continue + if (.not.(lex .eq. -166))goto 23009 + lex = -67 + goto 23010 +23009 continue + if (.not.(lookup (lexstr, lex, rkwtbl) .eq. 1))goto 23011 + if (.not.(lex .eq. -90))goto 23013 + n = -1 +23015 continue + c = ngetch (c) + n = n + 1 +23016 if (.not.(c .ne. 32 .and. c .ne. 9))goto 23015 +23017 continue + call putbak (c) + t = gnbtok (lexstr, 100) + call pbstr (lexstr) + if (.not.(n .gt. 0))goto 23018 + call putbak (32) +23018 continue + call scopy (sdefa0, 1, lexstr, 1) + if (.not.(t .ne. 58))goto 23020 + lex = -80 +23020 continue +23013 continue + goto 23012 +23011 continue + lex = -80 +23012 continue +23010 continue +23008 continue +23006 continue + return + end +c logic0 logical_column +c sdefa0 sdefault diff --git a/unix/boot/spp/rpp/rppfor/litral.f b/unix/boot/spp/rpp/rppfor/litral.f new file mode 100644 index 00000000..25bb6d3f --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/litral.f @@ -0,0 +1,76 @@ + subroutine litral + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ngetch + if (.not.(outp .gt. 0))goto 23000 + call outdwe +23000 continue + outp = 1 +23002 if (.not.(ngetch (outbuf (outp)) .ne. 10))goto 23004 +23003 outp = outp + 1 + goto 23002 +23004 continue + outp = outp - 1 + call outdwe + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/lndict.f b/unix/boot/spp/rpp/rppfor/lndict.f new file mode 100644 index 00000000..c2c4c1c3 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/lndict.f @@ -0,0 +1,86 @@ + subroutine lndict + integer sym (100), c + integer sctabl, length + integer posn, locn + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + posn = 0 +23000 if (.not.(sctabl (namtbl, sym, locn, posn) .ne. -1))goto 23001 + if (.not.(length(sym) .gt. 6))goto 23002 + call outch (99) + call outtab +23004 if (.not.(mem (locn) .ne. -2))goto 23006 + c = mem (locn) + call outch (c) +23005 locn = locn + 1 + goto 23004 +23006 continue + call outch (32) + call outch (32) + call outstr (sym) + call outdon +23002 continue + goto 23000 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ludef.f b/unix/boot/spp/rpp/rppfor/ludef.f new file mode 100644 index 00000000..3db6c8fe --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ludef.f @@ -0,0 +1,84 @@ + integer function ludef (id, defn, table) + integer id (100), defn (100) + integer table + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i + integer lookup + integer locn + ludef = lookup (id, locn, table) + if (.not.(ludef .eq. 1))goto 23000 + i = 1 +23002 if (.not.(mem (locn) .ne. -2))goto 23004 + defn (i) = mem (locn) + i = i + 1 +23003 locn = locn + 1 + goto 23002 +23004 continue + defn (i) = -2 + goto 23001 +23000 continue + defn (1) = -2 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/mapid.f b/unix/boot/spp/rpp/rppfor/mapid.f new file mode 100644 index 00000000..982651ee --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/mapid.f @@ -0,0 +1,13 @@ + subroutine mapid (name) + integer name(100) + integer i + i=1 +23000 if (.not.(name(i) .ne. -2))goto 23002 +23001 i=i+1 + goto 23000 +23002 continue + if (.not.(i-1 .gt. 6))goto 23003 + name(6) = name(i-1) + name(6+1) = -2 +23003 continue + end diff --git a/unix/boot/spp/rpp/rppfor/mkpkg.sh b/unix/boot/spp/rpp/rppfor/mkpkg.sh new file mode 100644 index 00000000..14896773 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/mkpkg.sh @@ -0,0 +1,22 @@ +# Fortran source for RPP preprocessor. + +$F77 -c $HSI_FF addchr.f allblk.f alldig.f baderr.f balpar.f beginc.f +$F77 -c $HSI_FF brknxt.f cascod.f caslab.f declco.f deftok.f doarth.f +$F77 -c $HSI_FF docode.f doif.f doincr.f domac.f dostat.f dosub.f +$F77 -c $HSI_FF eatup.f elseif.f endcod.f entdef.f entdkw.f entfkw.f +$F77 -c $HSI_FF entrkw.f entxkw.f errchk.f errgo.f errorc.f evalr.f +$F77 -c $HSI_FF finit.f forcod.f fors.f getdef.f gettok.f gnbtok.f +$F77 -c $HSI_FF gocode.f gtok.f ifcode.f iferrc.f ifgo.f ifparm.f +$F77 -c $HSI_FF indent.f initkw.f labelc.f labgen.f lex.f litral.f +$F77 -c $HSI_FF lndict.f ludef.f mapid.f ngetch.f ogotos.f otherc.f +$F77 -c $HSI_FF outch.f outcon.f outdon.f outdwe.f outgo.f outnum.f +$F77 -c $HSI_FF outstr.f outtab.f parse.f pbnum.f pbstr.f poicod.f +$F77 -c $HSI_FF push.f putbak.f putchr.f puttok.f ratfor.f relate.f +$F77 -c $HSI_FF repcod.f retcod.f sdupl.f skpblk.f squash.f strdcl.f +$F77 -c $HSI_FF swcode.f swend.f swvar.f synerr.f thenco.f ulstal.f +$F77 -c $HSI_FF uniqid.f unstak.f untils.f whilec.f whiles.f + +ar rv librpp.a *.o +$RANLIB librpp.a +mv -f librpp.a .. +rm *.o diff --git a/unix/boot/spp/rpp/rppfor/ngetch.f b/unix/boot/spp/rpp/rppfor/ngetch.f new file mode 100644 index 00000000..998e707a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ngetch.f @@ -0,0 +1,94 @@ + integer function ngetch (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer getlin, n, i + if (.not.(buf (bp) .eq. -2))goto 23000 + if (.not.(getlin (buf (3192), infile (level)) .eq. -1))goto 23002 + c = -1 + goto 23003 +23002 continue + c = buf (3192) + bp = 3192 + 1 + if (.not.(c .eq. 35))goto 23004 + if (.not.(buf(bp) .eq. 33 .and. buf(bp+1) .eq. 35))goto 23006 + n = 0 + i=bp+3 +23008 if (.not.(buf(i) .ge. 48 .and. buf(i) .le. 57))goto 23010 + n = n * 10 + buf(i) - 48 +23009 i=i+1 + goto 23008 +23010 continue + linect (level) = n - 1 +23006 continue +23004 continue + linect (level) = linect (level) + 1 +23003 continue + goto 23001 +23000 continue + c = buf (bp) + bp = bp + 1 +23001 continue + ngetch=(c) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ogotos.f b/unix/boot/spp/rpp/rppfor/ogotos.f new file mode 100644 index 00000000..48ce0314 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ogotos.f @@ -0,0 +1,78 @@ + subroutine ogotos (n, error0) + integer n, error0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer sgoto(6) + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/32/,sgoto(6)/-2/ + call outtab + call outstr (sgoto) + call outnum (n) + if (.not.(error0 .eq. 1))goto 23000 + call outdwe + goto 23001 +23000 continue + call outdon +23001 continue + end +c logic0 logical_column +c error0 error_check diff --git a/unix/boot/spp/rpp/rppfor/otherc.f b/unix/boot/spp/rpp/rppfor/otherc.f new file mode 100644 index 00000000..f745eabb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/otherc.f @@ -0,0 +1,75 @@ + subroutine otherc (lexstr) + integer lexstr(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + xfer = 0 + call outtab + if (.not.(((65.le.lexstr (1).and.lexstr (1).le.90).or.(97.le.lexst + *r (1).and.lexstr (1).le.122))))goto 23000 + call squash (lexstr) +23000 continue + call outstr (lexstr) + call eatup + call outdwe + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outch.f b/unix/boot/spp/rpp/rppfor/outch.f new file mode 100644 index 00000000..526af517 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outch.f @@ -0,0 +1,120 @@ + subroutine outch (c) + integer c, splbuf(8+1) + integer i, ip, op, index + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + external index + integer break0(10) + data break0(1)/32/,break0(2)/41/,break0(3)/44/,break0(4)/46/,break + *0(5)/43/,break0(6)/45/,break0(7)/42/,break0(8)/47/,break0(9)/40/,b + *reak0(10)/-2/ + if (.not.(outp .ge. 72))goto 23000 + if (.not.(index (break0, c) .gt. 0))goto 23002 + ip = outp + goto 23003 +23002 continue + ip=outp +23004 if (.not.(ip .ge. 1))goto 23006 + if (.not.(index (break0, outbuf(ip)) .gt. 0))goto 23007 + goto 23006 +23007 continue +23005 ip=ip-1 + goto 23004 +23006 continue +23003 continue + if (.not.(ip .ne. outp .and. (outp-ip) .lt. 8))goto 23009 + op = 1 + i=ip+1 +23011 if (.not.(i .le. outp))goto 23013 + splbuf(op) = outbuf(i) + op = op + 1 +23012 i=i+1 + goto 23011 +23013 continue + splbuf(op) = -2 + outp = ip + goto 23010 +23009 continue + splbuf(1) = -2 +23010 continue + call outdon + op=1 +23014 if (.not.(op .lt. col))goto 23016 + outbuf(op) = 32 +23015 op=op+1 + goto 23014 +23016 continue + outbuf(6) = 42 + outp = col + ip=1 +23017 if (.not.(splbuf(ip) .ne. -2))goto 23019 + outp = outp + 1 + outbuf(outp) = splbuf(ip) +23018 ip=ip+1 + goto 23017 +23019 continue +23000 continue + outp = outp + 1 + outbuf(outp) = c + end +c logic0 logical_column +c break0 break_chars diff --git a/unix/boot/spp/rpp/rppfor/outcon.f b/unix/boot/spp/rpp/rppfor/outcon.f new file mode 100644 index 00000000..3c25b6ff --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outcon.f @@ -0,0 +1,80 @@ + subroutine outcon (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer contin(9) + data contin(1)/99/,contin(2)/111/,contin(3)/110/,contin(4)/116/,co + *ntin(5)/105/,contin(6)/110/,contin(7)/117/,contin(8)/101/,contin(9 + *)/-2/ + xfer = 0 + if (.not.(n .le. 0 .and. outp .eq. 0))goto 23000 + return +23000 continue + if (.not.(n .gt. 0))goto 23002 + call outnum (n) +23002 continue + call outtab + call outstr (contin) + call outdon + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outdon.f b/unix/boot/spp/rpp/rppfor/outdon.f new file mode 100644 index 00000000..d3582ff9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outdon.f @@ -0,0 +1,118 @@ + subroutine outdon + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer allblk + integer itoc, ip, op, i + integer obuf(80) + integer sline0(7) + data sline0(1)/35/,sline0(2)/108/,sline0(3)/105/,sline0(4)/110/,sl + *ine0(5)/101/,sline0(6)/32/,sline0(7)/-2/ + if (.not.(dbgout .eq. 1))goto 23000 + if (.not.(body .eq. 1 .or. dbglev .ne. level))goto 23002 + op = 1 + ip=1 +23004 if (.not.(sline0(ip) .ne. -2))goto 23006 + obuf(op) = sline0(ip) + op = op + 1 +23005 ip=ip+1 + goto 23004 +23006 continue + op = op + itoc (linect, obuf(op), 80-op+1) + obuf(op) = 32 + op = op + 1 + obuf(op) = 34 + op = op + 1 + i=fnamp-1 +23007 if (.not.(i .ge. 1))goto 23009 + if (.not.(fnames(i-1) .eq. -2 .or. i .eq. 1))goto 23010 + ip=i +23012 if (.not.(fnames(ip) .ne. -2))goto 23014 + obuf(op) = fnames(ip) + op = op + 1 +23013 ip=ip+1 + goto 23012 +23014 continue + goto 23009 +23010 continue +23008 i=i-1 + goto 23007 +23009 continue + obuf(op) = 34 + op = op + 1 + obuf(op) = 10 + op = op + 1 + obuf(op) = -2 + op = op + 1 + call putlin (obuf, 1) + dbglev = level +23002 continue +23000 continue + outbuf (outp + 1) = 10 + outbuf (outp + 2) = -2 + if (.not.(allblk (outbuf) .eq. 0))goto 23015 + call putlin (outbuf, 1) +23015 continue + outp = 0 + return + end +c logic0 logical_column +c sline0 s_line diff --git a/unix/boot/spp/rpp/rppfor/outdwe.f b/unix/boot/spp/rpp/rppfor/outdwe.f new file mode 100644 index 00000000..6b006269 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outdwe.f @@ -0,0 +1,4 @@ + subroutine outdwe + call outdon + call errgo + end diff --git a/unix/boot/spp/rpp/rppfor/outgo.f b/unix/boot/spp/rpp/rppfor/outgo.f new file mode 100644 index 00000000..2f4ff64c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outgo.f @@ -0,0 +1,69 @@ + subroutine outgo (n) + integer n + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(xfer .eq. 1))goto 23000 + return +23000 continue + call ogotos (n, 0) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/outnum.f b/unix/boot/spp/rpp/rppfor/outnum.f new file mode 100644 index 00000000..8c7e7029 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outnum.f @@ -0,0 +1,22 @@ + subroutine outnum (n) + integer n + integer chars (20) + integer i, m + m = iabs (n) + i = 0 +23000 continue + i = i + 1 + chars (i) = mod (m, 10) + 48 + m = m / 10 +23001 if (.not.(m .eq. 0 .or. i .ge. 20))goto 23000 +23002 continue + if (.not.(n .lt. 0))goto 23003 + call outch (45) +23003 continue +23005 if (.not.(i .gt. 0))goto 23007 + call outch (chars (i)) +23006 i = i - 1 + goto 23005 +23007 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/outstr.f b/unix/boot/spp/rpp/rppfor/outstr.f new file mode 100644 index 00000000..28230330 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outstr.f @@ -0,0 +1,30 @@ + subroutine outstr (str) + integer str (100) + integer c + integer i, j + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + c = str (i) + if (.not.(c .ne. 39 .and. c .ne. 34))goto 23003 + call outch (c) + goto 23004 +23003 continue + i = i + 1 + j = i +23005 if (.not.(str (j) .ne. c))goto 23007 +23006 j = j + 1 + goto 23005 +23007 continue + call outnum (j - i) + call outch (72) +23008 if (.not.(i .lt. j))goto 23010 + call outch (str (i)) +23009 i = i + 1 + goto 23008 +23010 continue +23004 continue +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/outtab.f b/unix/boot/spp/rpp/rppfor/outtab.f new file mode 100644 index 00000000..17b0aa8c --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/outtab.f @@ -0,0 +1,69 @@ + subroutine outtab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem +23000 if (.not.(outp .lt. col))goto 23001 + call outch (32) + goto 23000 +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/parse.f b/unix/boot/spp/rpp/rppfor/parse.f new file mode 100644 index 00000000..5876293a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/parse.f @@ -0,0 +1,257 @@ + subroutine parse + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lexstr(100) + integer lab, labval(100), lextyp(100), sp, token, i, t + integer lex + logical pushs0 + sp = 1 + lextyp(1) = -1 + token = lex(lexstr) +23000 if (.not.(token .ne. -1))goto 23002 + pushs0 = .false. + I23003=(token) + goto 23003 +23005 continue + call ifcode (lab) + pushs0 = .true. + goto 23004 +23006 continue + call iferrc (lab, 1) + pushs0 = .true. + goto 23004 +23007 continue + call iferrc (lab, 0) + pushs0 = .true. + goto 23004 +23008 continue + call docode (lab) + pushs0 = .true. + goto 23004 +23009 continue + call whilec (lab) + pushs0 = .true. + goto 23004 +23010 continue + call forcod (lab) + pushs0 = .true. + goto 23004 +23011 continue + call repcod (lab) + pushs0 = .true. + goto 23004 +23012 continue + call swcode (lab) + pushs0 = .true. + goto 23004 +23013 continue + i=sp +23014 if (.not.(i .gt. 0))goto 23016 + if (.not.(lextyp(i) .eq. -92))goto 23017 + goto 23016 +23017 continue +23015 i=i-1 + goto 23014 +23016 continue + if (.not.(i .eq. 0))goto 23019 + call synerr (24Hillegal case or default.) + goto 23020 +23019 continue + call cascod (labval (i), token) +23020 continue + goto 23004 +23021 continue + call labelc (lexstr) + pushs0 = .true. + goto 23004 +23022 continue + t = lextyp(sp) + if (.not.(t .eq. -99 .or. t .eq. -98 .or. t .eq. -97))goto 23023 + call elseif (labval(sp)) + goto 23024 +23023 continue + call synerr (13HIllegal else.) +23024 continue + t = lex (lexstr) + call pbstr (lexstr) + if (.not.(t .eq. -99 .or. t .eq. -98 .or. t .eq. -97))goto 23025 + call indent (-1) + token = -72 +23025 continue + pushs0 = .true. + goto 23004 +23027 continue + if (.not.(lextyp(sp) .eq. -98 .or. lextyp(sp) .eq. -97))goto 23028 + call thenco (lextyp(sp), labval(sp)) + lab = labval(sp) + token = lextyp(sp) + sp = sp - 1 + goto 23029 +23028 continue + call synerr (41HIllegal 'then' clause in iferr statement.) +23029 continue + pushs0 = .true. + goto 23004 +23030 continue + call litral + goto 23004 +23031 continue + call errchk + goto 23004 +23032 continue + call beginc + goto 23004 +23033 continue + call endcod (lexstr) + if (.not.(sp .ne. 1))goto 23034 + call synerr (31HMissing right brace or 'begin'.) + sp = 1 +23034 continue + goto 23004 +23036 continue + if (.not.(token .eq. 123))goto 23037 + pushs0 = .true. + goto 23038 +23037 continue + if (.not.(token .eq. -67))goto 23039 + call declco (lexstr) +23039 continue +23038 continue + goto 23004 +23003 continue + I23003=I23003+100 + if (I23003.lt.1.or.I23003.gt.18)goto 23036 + goto (23005,23006,23007,23008,23009,23010,23011,23012,23013,23013, + *23021,23036,23022,23027,23030,23031,23032,23033),I23003 +23004 continue + if (.not.(pushs0))goto 23041 + if (.not.(body .eq. 0))goto 23043 + call synerr (24HMissing 'begin' keyword.) + call beginc +23043 continue + sp = sp + 1 + if (.not.(sp .gt. 100))goto 23045 + call baderr (25HStack overflow in parser.) +23045 continue + lextyp(sp) = token + labval(sp) = lab + goto 23042 +23041 continue + if (.not.(token .ne. -91 .and. token .ne. -90))goto 23047 + if (.not.(token .eq. 125))goto 23049 + token = -74 +23049 continue + I23051=(token) + goto 23051 +23053 continue + call otherc (lexstr) + goto 23052 +23054 continue + call brknxt (sp, lextyp, labval, token) + goto 23052 +23055 continue + call retcod + goto 23052 +23056 continue + call gocode + goto 23052 +23057 continue + if (.not.(body .eq. 0))goto 23058 + call strdcl + goto 23059 +23058 continue + call otherc (lexstr) +23059 continue + goto 23052 +23060 continue + if (.not.(lextyp(sp) .eq. 123))goto 23061 + sp = sp - 1 + goto 23062 +23061 continue + if (.not.(lextyp(sp) .eq. -92))goto 23063 + call swend (labval(sp)) + sp = sp - 1 + goto 23064 +23063 continue + call synerr (20HIllegal right brace.) +23064 continue +23062 continue + goto 23052 +23051 continue + I23051=I23051+81 + if (I23051.lt.1.or.I23051.gt.7)goto 23052 + goto (23053,23054,23054,23055,23056,23057,23060),I23051 +23052 continue + token = lex (lexstr) + call pbstr (lexstr) + call unstak (sp, lextyp, labval, token) +23047 continue +23042 continue +23001 token = lex(lexstr) + goto 23000 +23002 continue + if (.not.(sp .ne. 1))goto 23065 + call synerr (15Hunexpected EOF.) +23065 continue + end +c pushs0 push_stack +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/pbnum.f b/unix/boot/spp/rpp/rppfor/pbnum.f new file mode 100644 index 00000000..bf477107 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/pbnum.f @@ -0,0 +1,17 @@ + subroutine pbnum (n) + integer n + integer m, num + integer mod + integer digits(11) + data digits(1)/48/,digits(2)/49/,digits(3)/50/,digits(4)/51/,digit + *s(5)/52/,digits(6)/53/,digits(7)/54/,digits(8)/55/,digits(9)/56/,d + *igits(10)/57/,digits(11)/-2/ + num = n +23000 continue + m = mod (num, 10) + call putbak (digits (m + 1)) + num = num / 10 +23001 if (.not.(num .eq. 0))goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/pbstr.f b/unix/boot/spp/rpp/rppfor/pbstr.f new file mode 100644 index 00000000..da3a12a9 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/pbstr.f @@ -0,0 +1,75 @@ + subroutine pbstr (s) + integer s(100) + integer lenstr, i + integer length + lenstr = length (s) + if (.not.(s(1) .eq. 46 .and. s(lenstr) .eq. 46))goto 23000 + if (.not.(lenstr .eq. 4))goto 23002 + if (.not.(s(2) .eq. 103))goto 23004 + if (.not.(s(3) .eq. 116))goto 23006 + call putbak (62) + return +23006 continue + if (.not.(s(3) .eq. 101))goto 23008 + call putbak (61) + call putbak (62) + return +23008 continue +23007 continue + goto 23005 +23004 continue + if (.not.(s(2) .eq. 108))goto 23010 + if (.not.(s(3) .eq. 116))goto 23012 + call putbak (60) + return +23012 continue + if (.not.(s(3) .eq. 101))goto 23014 + call putbak (61) + call putbak (60) + return +23014 continue +23013 continue + goto 23011 +23010 continue + if (.not.(s(2) .eq. 101 .and. s(3) .eq. 113))goto 23016 + call putbak (61) + call putbak (61) + return +23016 continue + if (.not.(s(2) .eq. 110 .and. s(3) .eq. 101))goto 23018 + call putbak (61) + call putbak (33) + return +23018 continue + if (.not.(s(2) .eq. 111 .and. s(3) .eq. 114))goto 23020 + call putbak (124) + return +23020 continue +23019 continue +23017 continue +23011 continue +23005 continue + goto 23003 +23002 continue + if (.not.(lenstr .eq. 5))goto 23022 + if (.not.(s(2) .eq. 110 .and. s(3) .eq. 111 .and. s(4) .eq. 116))g + *oto 23024 + call putbak (33) + return +23024 continue + if (.not.(s(2) .eq. 97 .and. s(3) .eq. 110 .and. s(4) .eq. 100))go + *to 23026 + call putbak (38) + return +23026 continue +23025 continue +23022 continue +23003 continue +23000 continue + i=lenstr +23028 if (.not.(i .gt. 0))goto 23030 + call putbak (s(i)) +23029 i=i-1 + goto 23028 +23030 continue + end diff --git a/unix/boot/spp/rpp/rppfor/poicod.f b/unix/boot/spp/rpp/rppfor/poicod.f new file mode 100644 index 00000000..834d1644 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/poicod.f @@ -0,0 +1,172 @@ + subroutine poicod (decla0) + integer decla0 + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer spoin0(9) + integer p1(16) + integer p2(18) + integer p3(18) +C integer p4(18) +C integer p5(18) +C integer p6(25) + integer p4(16) + integer p5(16) + integer p6(13) + integer p7(25) + integer p8(16) + integer p9(61) + integer pa(18) + +C data spoin0(1)/105/,spoin0(2)/110/,spoin0(3)/116/,spoin0(4)/101/,s +C *poin0(5)/103/,spoin0(6)/101/,spoin0(7)/114/,spoin0(8)/42/,spoin0(9 +C *)/56/,spoin0(10)/32/,spoin0(11)/-2/ + data spoin0(1)/105/,spoin0(2)/110/,spoin0(3)/116/,spoin0(4)/101/,s + *poin0(5)/103/,spoin0(6)/101/,spoin0(7)/114/,spoin0(8)/32/,spoin0(9 + *)/-2/ + + data p1(1)/108/,p1(2)/111/,p1(3)/103/,p1(4)/105/,p1(5)/99/,p1(6)/9 + *7/,p1(7)/108/,p1(8)/32/,p1(9)/77/,p1(10)/101/,p1(11)/109/,p1(12)/9 + *8/,p1(13)/40/,p1(14)/49/,p1(15)/41/,p1(16)/-2/ + data p2(1)/105/,p2(2)/110/,p2(3)/116/,p2(4)/101/,p2(5)/103/,p2(6)/ + *101/,p2(7)/114/,p2(8)/42/,p2(9)/50/,p2(10)/32/,p2(11)/77/,p2(12)/1 + *01/,p2(13)/109/,p2(14)/99/,p2(15)/40/,p2(16)/49/,p2(17)/41/,p2(18) + */-2/ + data p3(1)/105/,p3(2)/110/,p3(3)/116/,p3(4)/101/,p3(5)/103/,p3(6)/ + *101/,p3(7)/114/,p3(8)/42/,p3(9)/50/,p3(10)/32/,p3(11)/77/,p3(12)/1 + *01/,p3(13)/109/,p3(14)/115/,p3(15)/40/,p3(16)/49/,p3(17)/41/,p3(18 + *)/-2/ + + data p4(1)/105/,p4(2)/110/,p4(3)/116/,p4(4)/101/,p4(5)/103/,p4(6)/ + *101/,p4(7)/114/,p4(8)/32/,p4(9)/77/,p4(10)/101/,p4(11)/109/,p4(12) + */105/,p4(13)/40/,p4(14)/49/,p4(15)/41/,p4(16)/-2/ + data p5(1)/105/,p5(2)/110/,p5(3)/116/,p5(4)/101/,p5(5)/103/,p5(6)/ + *101/,p5(7)/114/,p5(8)/32/,p5(9)/77/,p5(10)/101/,p5(11)/109/,p5(12) + */108/,p5(13)/40/,p5(14)/49/,p5(15)/41/,p5(16)/-2/ + +C data p4(1)/105/,p4(2)/110/,p4(3)/116/,p4(4)/101/,p4(5)/103/,p4(6)/ +C *101/,p4(7)/114/,p4(8)/42/,p4(9)/56/,p4(10)/32/,p4(11)/77/,p4(12)/1 +C *01/,p4(13)/109/,p4(14)/105/,p4(15)/40/,p4(16)/49/,p4(17)/41/,p4(18 +C *)/-2/ +C data p5(1)/105/,p5(2)/110/,p5(3)/116/,p5(4)/101/,p5(5)/103/,p5(6)/ +C *101/,p5(7)/114/,p5(8)/42/,p5(9)/56/,p5(10)/32/,p5(11)/77/,p5(12)/1 +C *01/,p5(13)/109/,p5(14)/108/,p5(15)/40/,p5(16)/49/,p5(17)/41/,p5(18 +C *)/-2/ +C data p6(1)/100/,p6(2)/111/,p6(3)/117/,p6(4)/98/,p6(5)/108/,p6(6)/1 +C *01/,p6(7)/32/,p6(8)/112/,p6(9)/114/,p6(10)/101/,p6(11)/99/,p6(12)/ +C *105/,p6(13)/115/,p6(14)/105/,p6(15)/111/,p6(16)/110/,p6(17)/32/,p6 +C *(18)/77/,p6(19)/101/,p6(20)/109/,p6(21)/114/,p6(22)/40/,p6(23)/49/ +C *,p6(24)/41/,p6(25)/-2/ + + data p6(1)/114/,p6(2)/101/,p6(3)/97/,p6(4)/108/,p6(5)/32/,p6(6)/77 + */,p6(7)/101/,p6(8)/109/,p6(9)/114/,p6(10)/40/,p6(11)/49/,p6(12)/41 + */,p6(13)/-2/ + + data p7(1)/100/,p7(2)/111/,p7(3)/117/,p7(4)/98/,p7(5)/108/,p7(6)/1 + *01/,p7(7)/32/,p7(8)/112/,p7(9)/114/,p7(10)/101/,p7(11)/99/,p7(12)/ + *105/,p7(13)/115/,p7(14)/105/,p7(15)/111/,p7(16)/110/,p7(17)/32/,p7 + *(18)/77/,p7(19)/101/,p7(20)/109/,p7(21)/100/,p7(22)/40/,p7(23)/49/ + *,p7(24)/41/,p7(25)/-2/ + data p8(1)/99/,p8(2)/111/,p8(3)/109/,p8(4)/112/,p8(5)/108/,p8(6)/1 + *01/,p8(7)/120/,p8(8)/32/,p8(9)/77/,p8(10)/101/,p8(11)/109/,p8(12)/ + *120/,p8(13)/40/,p8(14)/49/,p8(15)/41/,p8(16)/-2/ + data p9(1)/101/,p9(2)/113/,p9(3)/117/,p9(4)/105/,p9(5)/118/,p9(6)/ + *97/,p9(7)/108/,p9(8)/101/,p9(9)/110/,p9(10)/99/,p9(11)/101/,p9(12) + */32/,p9(13)/40/,p9(14)/77/,p9(15)/101/,p9(16)/109/,p9(17)/98/,p9(1 + *8)/44/,p9(19)/32/,p9(20)/77/,p9(21)/101/,p9(22)/109/,p9(23)/99/,p9 + *(24)/44/,p9(25)/32/,p9(26)/77/,p9(27)/101/,p9(28)/109/,p9(29)/115/ + *,p9(30)/44/,p9(31)/32/,p9(32)/77/,p9(33)/101/,p9(34)/109/,p9(35)/1 + *05/,p9(36)/44/,p9(37)/32/,p9(38)/77/,p9(39)/101/,p9(40)/109/,p9(41 + *)/108/,p9(42)/44/,p9(43)/32/,p9(44)/77/,p9(45)/101/,p9(46)/109/,p9 + *(47)/114/,p9(48)/44/,p9(49)/32/,p9(50)/77/,p9(51)/101/,p9(52)/109/ + *,p9(53)/100/,p9(54)/44/,p9(55)/32/,p9(56)/77/,p9(57)/101/,p9(58)/1 + *09/,p9(59)/120/,p9(60)/41/,p9(61)/-2/ + data pa(1)/99/,pa(2)/111/,pa(3)/109/,pa(4)/109/,pa(5)/111/,pa(6)/1 + *10/,pa(7)/32/,pa(8)/47/,pa(9)/77/,pa(10)/101/,pa(11)/109/,pa(12)/4 + *7/,pa(13)/32/,pa(14)/77/,pa(15)/101/,pa(16)/109/,pa(17)/100/,pa(18 + *)/-2/ + if (.not.(memflg .eq. 0))goto 23000 + call poidec (p1) + call poidec (p2) + call poidec (p3) + call poidec (p4) + call poidec (p5) + call poidec (p6) + call poidec (p7) + call poidec (p8) + call poidec (p9) + call poidec (pa) + memflg = 1 +23000 continue + if (.not.(decla0 .eq. 1))goto 23002 + call outtab + call outstr (spoin0) +23002 continue + end + subroutine poidec (str) + integer str + call outtab + call outstr (str) + call outdon + end +c logic0 logical_column +c decla0 declare_variable +c spoin0 spointer diff --git a/unix/boot/spp/rpp/rppfor/push.f b/unix/boot/spp/rpp/rppfor/push.f new file mode 100644 index 00000000..2329f6c5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/push.f @@ -0,0 +1,9 @@ + integer function push (ep, argstk, ap) + integer ap, argstk (100), ep + if (.not.(ap .gt. 100))goto 23000 + call baderr (19Harg stack overflow.) +23000 continue + argstk (ap) = ep + push = ap + 1 + return + end diff --git a/unix/boot/spp/rpp/rppfor/putbak.f b/unix/boot/spp/rpp/rppfor/putbak.f new file mode 100644 index 00000000..b4252a1e --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/putbak.f @@ -0,0 +1,73 @@ + subroutine putbak (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(bp .le. 1))goto 23000 + call baderr (32Htoo many characters pushed back.) + goto 23001 +23000 continue + bp = bp - 1 + buf (bp) = c +23001 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/putchr.f b/unix/boot/spp/rpp/rppfor/putchr.f new file mode 100644 index 00000000..b502f58a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/putchr.f @@ -0,0 +1,71 @@ + subroutine putchr (c) + integer c + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(ep .gt. 500))goto 23000 + call baderr (26Hevaluation stack overflow.) +23000 continue + evalst (ep) = c + ep = ep + 1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/puttok.f b/unix/boot/spp/rpp/rppfor/puttok.f new file mode 100644 index 00000000..41d4df64 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/puttok.f @@ -0,0 +1,11 @@ + subroutine puttok (str) + integer str (100) + integer i + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + call putchr (str (i)) +23001 i = i + 1 + goto 23000 +23002 continue + return + end diff --git a/unix/boot/spp/rpp/rppfor/ratfor.f b/unix/boot/spp/rpp/rppfor/ratfor.f new file mode 100644 index 00000000..7891bd68 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ratfor.f @@ -0,0 +1,128 @@ + subroutine ratfor + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer i, n + integer getarg, rfopen + integer arg (30) + integer defns(1) + data defns(1)/-2/ + call initkw + if (.not.(defns (1) .ne. -2))goto 23000 + infile (1) = rfopen(defns, 1) + if (.not.(infile (1) .eq. -3))goto 23002 + call remark (37Hcan't open standard definitions file.) + goto 23003 +23002 continue + call finit + call parse + call rfclos(infile (1)) +23003 continue +23000 continue + n = 1 + i=1 +23004 if (.not.(getarg(i,arg,30) .ne. -1))goto 23006 + n = n + 1 + call query (37Husage: ratfor [-g] [files] >outfile.) + if (.not.(arg(1) .eq. 45 .and. arg(2) .eq. 103 .and. arg(3) .eq. - + *2))goto 23007 + dbgout = 1 + goto 23005 +23007 continue + if (.not.(arg(1) .eq. 45 .and. arg(2) .eq. -2))goto 23009 + infile(1) = 0 + call finit + goto 23010 +23009 continue + infile(1) = rfopen(arg, 1) + if (.not.(infile(1) .eq. -3))goto 23011 + call cant (arg) + goto 23012 +23011 continue + call finit + call scopy (arg, 1, fnames, 1) + fnamp=1 +23013 if (.not.(fnames(fnamp) .ne. -2))goto 23015 + if (.not.(fnames(fnamp) .eq. 46 .and. fnames(fnamp+1) .eq. 114))go + *to 23016 + fnames(fnamp+1) = 120 +23016 continue +23014 fnamp=fnamp+1 + goto 23013 +23015 continue +23012 continue +23010 continue +23008 continue + call parse + if (.not.(infile (1) .ne. 0))goto 23018 + call rfclos(infile (1)) +23018 continue +23005 i=i+1 + goto 23004 +23006 continue + if (.not.(n .eq. 1))goto 23020 + infile (1) = 0 + call finit + call parse +23020 continue + call lndict + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/relate.f b/unix/boot/spp/rpp/rppfor/relate.f new file mode 100644 index 00000000..36c3e196 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/relate.f @@ -0,0 +1,66 @@ + subroutine relate (token, last) + integer token (100) + integer last + integer ngetch + integer length + if (.not.(ngetch (token (2)) .ne. 61))goto 23000 + call putbak (token (2)) + token (3) = 116 + goto 23001 +23000 continue + token (3) = 101 +23001 continue + token (4) = 46 + token (5) = -2 + token (6) = -2 + if (.not.(token (1) .eq. 62))goto 23002 + token (2) = 103 + goto 23003 +23002 continue + if (.not.(token (1) .eq. 60))goto 23004 + token (2) = 108 + goto 23005 +23004 continue + if (.not.(token (1) .eq. 126 .or. token (1) .eq. 33 .or. token (1) + * .eq. 94 .or. token (1) .eq. 126))goto 23006 + if (.not.(token (2) .ne. 61))goto 23008 + token (3) = 111 + token (4) = 116 + token (5) = 46 +23008 continue + token (2) = 110 + goto 23007 +23006 continue + if (.not.(token (1) .eq. 61))goto 23010 + if (.not.(token (2) .ne. 61))goto 23012 + token (2) = -2 + last = 1 + return +23012 continue + token (2) = 101 + token (3) = 113 + goto 23011 +23010 continue + if (.not.(token (1) .eq. 38))goto 23014 + token (2) = 97 + token (3) = 110 + token (4) = 100 + token (5) = 46 + goto 23015 +23014 continue + if (.not.(token (1) .eq. 124))goto 23016 + token (2) = 111 + token (3) = 114 + goto 23017 +23016 continue + token (2) = -2 +23017 continue +23015 continue +23011 continue +23007 continue +23005 continue +23003 continue + token (1) = 46 + last = length (token) + return + end diff --git a/unix/boot/spp/rpp/rppfor/repcod.f b/unix/boot/spp/rpp/rppfor/repcod.f new file mode 100644 index 00000000..3279d58a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/repcod.f @@ -0,0 +1,10 @@ + subroutine repcod (lab) + integer lab + integer labgen + call outcon (0) + lab = labgen (3) + call outcon (lab) + lab = lab + 1 + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rppfor/retcod.f b/unix/boot/spp/rpp/rppfor/retcod.f new file mode 100644 index 00000000..1aa43aee --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/retcod.f @@ -0,0 +1,88 @@ + subroutine retcod + integer token (100), t + integer gnbtok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + t = gnbtok (token, 100) + if (.not.(t .ne. 10 .and. t .ne. 59 .and. t .ne. 125))goto 23000 + call pbstr (token) + call outtab + call scopy (fcname, 1, token, 1) + call squash (token) + call outstr (token) + call outch (32) + call outch (61) + call outch (32) + call eatup + call outdon + goto 23001 +23000 continue + if (.not.(t .eq. 125))goto 23002 + call pbstr (token) +23002 continue +23001 continue + call outtab + call ogotos (retlab, 0) + xfer = 1 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/sdupl.f b/unix/boot/spp/rpp/rppfor/sdupl.f new file mode 100644 index 00000000..0d35237a --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/sdupl.f @@ -0,0 +1,20 @@ + integer function sdupl (str) + integer str (100) + integer mem( 60000) + common/cdsmem/mem + integer i + integer length + integer j + integer dsget + j = dsget (length (str) + 1) + sdupl = j + i = 1 +23000 if (.not.(str (i) .ne. -2))goto 23002 + mem (j) = str (i) + j = j + 1 +23001 i = i + 1 + goto 23000 +23002 continue + mem (j) = -2 + return + end diff --git a/unix/boot/spp/rpp/rppfor/skpblk.f b/unix/boot/spp/rpp/rppfor/skpblk.f new file mode 100644 index 00000000..47c2b0aa --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/skpblk.f @@ -0,0 +1,73 @@ + subroutine skpblk + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer c + integer ngetch + c = ngetch (c) +23000 if (.not.(c .eq. 32 .or. c .eq. 9))goto 23002 +23001 c = ngetch (c) + goto 23000 +23002 continue + call putbak (c) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/squash.f b/unix/boot/spp/rpp/rppfor/squash.f new file mode 100644 index 00000000..d0e654f0 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/squash.f @@ -0,0 +1,104 @@ + subroutine squash (id) + integer id(100) + integer junk, i, j + integer lookup, ludef + integer newid(100), recdid(100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + if (.not.(body .eq. 1 .and. errtbl .ne. 0 .and. ername .eq. 0))got + *o 23000 + if (.not.(lookup (id, junk, errtbl) .eq. 1))goto 23002 + ername = 1 +23002 continue +23000 continue + j = 1 + i=1 +23004 if (.not.(id(i) .ne. -2))goto 23006 + if (.not.(((65.le.id(i).and.id(i).le.90).or.(97.le.id(i).and.id(i) + *.le.122)) .or. (48.le.id(i).and.id(i).le.57)))goto 23007 + newid(j) = id(i) + j = j + 1 +23007 continue +23005 i=i+1 + goto 23004 +23006 continue + newid(j) = -2 + if (.not.(i-1 .lt. 6 .and. i .eq. j))goto 23009 + return +23009 continue + if (.not.(lookup (id, junk, fkwtbl) .eq. 1))goto 23011 + return +23011 continue + if (.not.(ludef (id, recdid, namtbl) .eq. 1))goto 23013 + call scopy (recdid, 1, id, 1) + return +23013 continue + call mapid (newid) + if (.not.(lookup (newid, junk, gentbl) .eq. 1))goto 23015 + call synerr (39HWarning: identifier mapping not unique.) + call uniqid (newid) +23015 continue + call entdef (newid, id, gentbl) + call entdef (id, newid, namtbl) + call scopy (newid, 1, id, 1) + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/strdcl.f b/unix/boot/spp/rpp/rppfor/strdcl.f new file mode 100644 index 00000000..5ebcaeba --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/strdcl.f @@ -0,0 +1,170 @@ + subroutine strdcl + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer t, token (100), dchar (100) + integer gnbtok + integer i, j, k, n, len + integer length, ctoi, lex + integer char(11) + integer dat(6) + integer eoss(3) + data char(1)/105/,char(2)/110/,char(3)/116/,char(4)/101/,char(5)/1 + *03/,char(6)/101/,char(7)/114/,char(8)/42/,char(9)/50/,char(10)/47/ + *,char(11)/-2/ + data dat(1)/100/,dat(2)/97/,dat(3)/116/,dat(4)/97/,dat(5)/32/,dat( + *6)/-2/ + data eoss(1)/48/,eoss(2)/47/,eoss(3)/-2/ + t = gnbtok (token, 100) + if (.not.(t .ne. -9))goto 23000 + call synerr (21Hmissing string token.) +23000 continue + call squash (token) + call outtab + call pbstr (char) +23002 continue + t = gnbtok (dchar, 100) + if (.not.(t .eq. 47))goto 23005 + goto 23004 +23005 continue + call outstr (dchar) +23003 goto 23002 +23004 continue + call outch (32) + call outstr (token) + call addstr (token, sbuf, sbp, 2048) + call addchr (-2, sbuf, sbp, 2048) + if (.not.(gnbtok (token, 100) .ne. 40))goto 23007 + len = length (token) + 1 + if (.not.(token (1) .eq. 39 .or. token (1) .eq. 34))goto 23009 + len = len - 2 +23009 continue + goto 23008 +23007 continue + t = gnbtok (token, 100) + i = 1 + len = ctoi (token, i) + if (.not.(token (i) .ne. -2))goto 23011 + call synerr (20Hinvalid string size.) +23011 continue + if (.not.(gnbtok (token, 100) .ne. 41))goto 23013 + call synerr (20Hmissing right paren.) + goto 23014 +23013 continue + t = gnbtok (token, 100) +23014 continue +23008 continue + call outch (40) + call outnum (len) + call outch (41) + call outdon + if (.not.(token (1) .eq. 39 .or. token (1) .eq. 34))goto 23015 + len = length (token) + token (len) = -2 + call addstr (token (2), sbuf, sbp, 2048) + goto 23016 +23015 continue + call addstr (token, sbuf, sbp, 2048) +23016 continue + call addchr (-2, sbuf, sbp, 2048) + t = lex (token) + call pbstr (token) + if (.not.(t .ne. -75))goto 23017 + i = 1 +23019 if (.not.(i .lt. sbp))goto 23021 + call outtab + call outstr (dat) + k = 1 + j = i + length (sbuf (i)) + 1 +23022 continue + if (.not.(k .gt. 1))goto 23025 + call outch (44) +23025 continue + call outstr (sbuf (i)) + call outch (40) + call outnum (k) + call outch (41) + call outch (47) + if (.not.(sbuf (j) .eq. -2))goto 23027 + goto 23024 +23027 continue + n = sbuf (j) + call outnum (n) + call outch (47) + k = k + 1 +23023 j = j + 1 + goto 23022 +23024 continue + call pbstr (eoss) +23029 continue + t = gnbtok (token, 100) + call outstr (token) +23030 if (.not.(t .eq. 47))goto 23029 +23031 continue + call outdon +23020 i = j + 1 + goto 23019 +23021 continue + sbp = 1 +23017 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swcode.f b/unix/boot/spp/rpp/rppfor/swcode.f new file mode 100644 index 00000000..22617fdc --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swcode.f @@ -0,0 +1,99 @@ + subroutine swcode (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer tok (100) + integer labgen, gnbtok + lab = labgen (2) + swvnum = swvnum + 1 + swvlev = swvlev + 1 + if (.not.(swvlev .gt. 10))goto 23000 + call baderr (27Hswitches nested too deeply.) +23000 continue + swvstk(swvlev) = swvnum + if (.not.(swlast + 3 .gt. 1000))goto 23002 + call baderr (22Hswitch table overflow.) +23002 continue + swstak (swlast) = swtop + swstak (swlast + 1) = 0 + swstak (swlast + 2) = 0 + swtop = swlast + swlast = swlast + 3 + xfer = 0 + call outtab + call swvar (swvnum) + call outch (61) + call balpar + call outdwe + call outgo (lab) + call indent (1) + xfer = 1 +23004 if (.not.(gnbtok (tok, 100) .eq. 10))goto 23005 + goto 23004 +23005 continue + if (.not.(tok (1) .ne. 123))goto 23006 + call synerr (39Hmissing left brace in switch statement.) + call pbstr (tok) +23006 continue + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swend.f b/unix/boot/spp/rpp/rppfor/swend.f new file mode 100644 index 00000000..02070f32 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swend.f @@ -0,0 +1,187 @@ + subroutine swend (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lb, ub, n, i, j, swn + integer sif(5) + integer slt(10) + integer sgt(5) + integer sgoto(7) + integer seq(5) + integer sge(5) + integer sle(5) + integer sand(6) + data sif(1)/105/,sif(2)/102/,sif(3)/32/,sif(4)/40/,sif(5)/-2/ + data slt(1)/46/,slt(2)/108/,slt(3)/116/,slt(4)/46/,slt(5)/49/,slt( + *6)/46/,slt(7)/111/,slt(8)/114/,slt(9)/46/,slt(10)/-2/ + data sgt(1)/46/,sgt(2)/103/,sgt(3)/116/,sgt(4)/46/,sgt(5)/-2/ + data sgoto(1)/103/,sgoto(2)/111/,sgoto(3)/116/,sgoto(4)/111/,sgoto + *(5)/32/,sgoto(6)/40/,sgoto(7)/-2/ + data seq(1)/46/,seq(2)/101/,seq(3)/113/,seq(4)/46/,seq(5)/-2/ + data sge(1)/46/,sge(2)/103/,sge(3)/101/,sge(4)/46/,sge(5)/-2/ + data sle(1)/46/,sle(2)/108/,sle(3)/101/,sle(4)/46/,sle(5)/-2/ + data sand(1)/46/,sand(2)/97/,sand(3)/110/,sand(4)/100/,sand(5)/46/ + *,sand(6)/-2/ + swn = swvstk(swvlev) + swvlev = max0(0, swvlev - 1) + lb = swstak (swtop + 3) + ub = swstak (swlast - 2) + n = swstak (swtop + 1) + call outgo (lab + 1) + if (.not.(swstak (swtop + 2) .eq. 0))goto 23000 + swstak (swtop + 2) = lab + 1 +23000 continue + xfer = 0 + call indent (-1) + call outcon (lab) + call indent (1) + if (.not.(n .ge. 3 .and. ub - lb + 1 .lt. 2 * n))goto 23002 + if (.not.(lb .ne. 1))goto 23004 + call outtab + call swvar (swn) + call outch (61) + call swvar (swn) + if (.not.(lb .lt. 1))goto 23006 + call outch (43) +23006 continue + call outnum (-lb + 1) + call outdon +23004 continue + if (.not.(swinrg .eq. 0))goto 23008 + call outtab + call outstr (sif) + call swvar (swn) + call outstr (slt) + call swvar (swn) + call outstr (sgt) + call outnum (ub - lb + 1) + call outch (41) + call outch (32) + call outgo (swstak (swtop + 2)) +23008 continue + call outtab + call outstr (sgoto) + j = lb + i = swtop + 3 +23010 if (.not.(i .lt. swlast))goto 23012 +23013 if (.not.(j .lt. swstak (i)))goto 23015 + call outnum (swstak (swtop + 2)) + call outch (44) +23014 j = j + 1 + goto 23013 +23015 continue + j = swstak (i + 1) - swstak (i) +23016 if (.not.(j .ge. 0))goto 23018 + call outnum (swstak (i + 2)) +23017 j = j - 1 + goto 23016 +23018 continue + j = swstak (i + 1) + 1 + if (.not.(i .lt. swlast - 3))goto 23019 + call outch (44) +23019 continue +23011 i = i + 3 + goto 23010 +23012 continue + call outch (41) + call outch (44) + call swvar (swn) + call outdon + goto 23003 +23002 continue + if (.not.(n .gt. 0))goto 23021 + i = swtop + 3 +23023 if (.not.(i .lt. swlast))goto 23025 + call outtab + call outstr (sif) + call swvar (swn) + if (.not.(swstak (i) .eq. swstak (i+1)))goto 23026 + call outstr (seq) + call outnum (swstak (i)) + goto 23027 +23026 continue + call outstr (sge) + call outnum (swstak (i)) + call outstr (sand) + call swvar (swn) + call outstr (sle) + call outnum (swstak (i + 1)) +23027 continue + call outch (41) + call outch (32) + call outgo (swstak (i + 2)) +23024 i = i + 3 + goto 23023 +23025 continue + if (.not.(lab + 1 .ne. swstak (swtop + 2)))goto 23028 + call outgo (swstak (swtop + 2)) +23028 continue +23021 continue +23003 continue + call indent (-1) + call outcon (lab + 1) + swlast = swtop + swtop = swstak (swtop) + swinrg = 0 + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/swvar.f b/unix/boot/spp/rpp/rppfor/swvar.f new file mode 100644 index 00000000..948e43ab --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/swvar.f @@ -0,0 +1,21 @@ + subroutine swvar (lab) + integer lab, i, labnum, ndigi0 + call outch (115) + call outch (119) + labnum = lab + ndigi0=0 +23000 if (.not.(labnum .gt. 0))goto 23002 + ndigi0 = ndigi0 + 1 +23001 labnum=labnum/10 + goto 23000 +23002 continue + i=3 +23003 if (.not.(i .le. 6 - ndigi0))goto 23005 + call outch (48) +23004 i=i+1 + goto 23003 +23005 continue + call outnum (lab) + return + end +c ndigi0 ndigits diff --git a/unix/boot/spp/rpp/rppfor/synerr.f b/unix/boot/spp/rpp/rppfor/synerr.f new file mode 100644 index 00000000..818171e5 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/synerr.f @@ -0,0 +1,98 @@ + subroutine synerr (msg) + integer msg + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer lc (20) + integer i, junk + integer itoc + integer of(5) + integer errmsg(100) + data of(1)/32/,of(2)/111/,of(3)/102/,of(4)/32/,of(5)/-2/ + data errmsg(1)/69/,errmsg(2)/114/,errmsg(3)/114/,errmsg(4)/111/,er + *rmsg(5)/114/,errmsg(6)/32/,errmsg(7)/111/,errmsg(8)/110/,errmsg(9) + */32/,errmsg(10)/108/,errmsg(11)/105/,errmsg(12)/110/,errmsg(13)/10 + *1/,errmsg(14)/32/,errmsg(15)/-2/ + call putlin (errmsg, 2) + if (.not.(level .ge. 1))goto 23000 + i = level + goto 23001 +23000 continue + i = 1 +23001 continue + junk = itoc (linect (i), lc, 20) + call putlin (lc, 2) + i = fnamp - 1 +23002 if (.not.(i .ge. 1))goto 23004 + if (.not.(fnames (i - 1) .eq. -2 .or. i .eq. 1))goto 23005 + call putlin (of, 2) + call putlin (fnames (i), 2) + goto 23004 +23005 continue +23003 i = i - 1 + goto 23002 +23004 continue + call putch (58, 2) + call putch (32, 2) + call remark (msg) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/thenco.f b/unix/boot/spp/rpp/rppfor/thenco.f new file mode 100644 index 00000000..bb6060d7 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/thenco.f @@ -0,0 +1,90 @@ + subroutine thenco (tok, lab) + integer lab, tok + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer siferr(20) + integer sifno0(15) + data siferr(1)/105/,siferr(2)/102/,siferr(3)/32/,siferr(4)/40/,sif + *err(5)/46/,siferr(6)/110/,siferr(7)/111/,siferr(8)/116/,siferr(9)/ + *46/,siferr(10)/120/,siferr(11)/101/,siferr(12)/114/,siferr(13)/112 + */,siferr(14)/111/,siferr(15)/112/,siferr(16)/40/,siferr(17)/41/,si + *ferr(18)/41/,siferr(19)/32/,siferr(20)/-2/ + data sifno0(1)/105/,sifno0(2)/102/,sifno0(3)/32/,sifno0(4)/40/,sif + *no0(5)/120/,sifno0(6)/101/,sifno0(7)/114/,sifno0(8)/112/,sifno0(9) + */111/,sifno0(10)/112/,sifno0(11)/40/,sifno0(12)/41/,sifno0(13)/41/ + *,sifno0(14)/32/,sifno0(15)/-2/ + xfer = 0 + call outnum (lab+2) + call outtab + if (.not.(tok .eq. -98))goto 23000 + call outstr (siferr) + goto 23001 +23000 continue + call outstr (sifno0) +23001 continue + call outgo (lab) + esp = esp - 1 + call indent (1) + return + end +c sifno0 sifnoerr +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/ulstal.f b/unix/boot/spp/rpp/rppfor/ulstal.f new file mode 100644 index 00000000..fe59090b --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/ulstal.f @@ -0,0 +1,69 @@ + subroutine ulstal (name, defn) + integer name (100), defn (100) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call entdef (name, defn, deftbl) + call upper (name) + call entdef (name, defn, deftbl) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/uniqid.f b/unix/boot/spp/rpp/rppfor/uniqid.f new file mode 100644 index 00000000..d843f0eb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/uniqid.f @@ -0,0 +1,116 @@ + subroutine uniqid (id) + integer id (100) + integer i, j, junk, idchl + external index + integer lookup, index, length + integer start (6) + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer idch(37) + data idch(1)/48/,idch(2)/49/,idch(3)/50/,idch(4)/51/,idch(5)/52/,i + *dch(6)/53/,idch(7)/54/,idch(8)/55/,idch(9)/56/,idch(10)/57/,idch(1 + *1)/97/,idch(12)/98/,idch(13)/99/,idch(14)/100/,idch(15)/101/,idch( + *16)/102/,idch(17)/103/,idch(18)/104/,idch(19)/105/,idch(20)/106/,i + *dch(21)/107/,idch(22)/108/,idch(23)/109/,idch(24)/110/,idch(25)/11 + *1/,idch(26)/112/,idch(27)/113/,idch(28)/114/,idch(29)/115/,idch(30 + *)/116/,idch(31)/117/,idch(32)/118/,idch(33)/119/,idch(34)/120/,idc + *h(35)/121/,idch(36)/122/,idch(37)/-2/ + i = 1 +23000 if (.not.(id (i) .ne. -2))goto 23002 +23001 i = i + 1 + goto 23000 +23002 continue +23003 if (.not.(i .le. 6))goto 23005 + id (i) = 48 +23004 i = i + 1 + goto 23003 +23005 continue + i = 6 + 1 + id (i) = -2 + id (i - 1) = 48 + if (.not.(lookup (id, junk, gentbl) .eq. 1))goto 23006 + idchl = length (idch) + i = 2 +23008 if (.not.(i .lt. 6))goto 23010 + start (i) = id (i) +23009 i = i + 1 + goto 23008 +23010 continue +23011 continue + i = 6 - 1 +23014 if (.not.(i .gt. 1))goto 23016 + j = mod (index (idch, id (i)), idchl) + 1 + id (i) = idch (j) + if (.not.(id (i) .ne. start (i)))goto 23017 + goto 23016 +23017 continue +23015 i = i - 1 + goto 23014 +23016 continue + if (.not.(i .eq. 1))goto 23019 + call baderr (30Hcannot make identifier unique.) +23019 continue +23012 if (.not.(lookup (id, junk, gentbl) .eq. 0))goto 23011 +23013 continue +23006 continue + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/unstak.f b/unix/boot/spp/rpp/rppfor/unstak.f new file mode 100644 index 00000000..c602dc06 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/unstak.f @@ -0,0 +1,58 @@ + subroutine unstak (sp, lextyp, labval, token) + integer labval(100), lextyp(100) + integer sp, token, type +23000 if (.not.(sp .gt. 1))goto 23002 + type = lextyp(sp) + if (.not.((type .eq. -98 .or. type .eq. -97) .and. token .eq. -86) + *)goto 23003 + goto 23002 +23003 continue + if (.not.(type .eq. -99 .or. type .eq. -98 .or. type .eq. -97))got + *o 23005 + type = 999 +23005 continue + if (.not.(type .eq. 123 .or. type .eq. -92))goto 23007 + goto 23002 +23007 continue + if (.not.(type .eq. 999 .and. token .eq. -87))goto 23009 + goto 23002 +23009 continue + if (.not.(type .eq. 999))goto 23011 + call indent (-1) + call outcon (labval(sp)) + goto 23012 +23011 continue + if (.not.(type .eq. -87 .or. type .eq. -72))goto 23013 + if (.not.(sp .gt. 2))goto 23015 + sp = sp - 1 +23015 continue + if (.not.(type .ne. -72))goto 23017 + call indent (-1) +23017 continue + call outcon (labval(sp) + 1) + goto 23014 +23013 continue + if (.not.(type .eq. -96))goto 23019 + call dostat (labval(sp)) + goto 23020 +23019 continue + if (.not.(type .eq. -95))goto 23021 + call whiles (labval(sp)) + goto 23022 +23021 continue + if (.not.(type .eq. -94))goto 23023 + call fors (labval(sp)) + goto 23024 +23023 continue + if (.not.(type .eq. -93))goto 23025 + call untils (labval(sp), token) +23025 continue +23024 continue +23022 continue +23020 continue +23014 continue +23012 continue +23001 sp=sp-1 + goto 23000 +23002 continue + end diff --git a/unix/boot/spp/rpp/rppfor/untils.f b/unix/boot/spp/rpp/rppfor/untils.f new file mode 100644 index 00000000..050e25fb --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/untils.f @@ -0,0 +1,80 @@ + subroutine untils (lab, token) + integer lab, token + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + integer ptoken (100) + integer junk + integer lex + xfer = 0 + call outnum (lab) + if (.not.(token .eq. -70))goto 23000 + junk = lex (ptoken) + call ifgo (lab - 1) + goto 23001 +23000 continue + call outgo (lab - 1) +23001 continue + call indent (-1) + call outcon (lab + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/whilec.f b/unix/boot/spp/rpp/rppfor/whilec.f new file mode 100644 index 00000000..1f830d00 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/whilec.f @@ -0,0 +1,72 @@ + subroutine whilec (lab) + integer lab + integer labgen + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call outcon (0) + lab = labgen (2) + call outnum (lab) + call ifgo (lab + 1) + call indent (1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rppfor/whiles.f b/unix/boot/spp/rpp/rppfor/whiles.f new file mode 100644 index 00000000..baa84531 --- /dev/null +++ b/unix/boot/spp/rpp/rppfor/whiles.f @@ -0,0 +1,69 @@ + subroutine whiles (lab) + integer lab + common /cdefio/ bp, buf (4096) + integer bp + integer buf + common /cfname/ fcname (30) + integer fcname + common /cfor/ fordep, forstk (200) + integer fordep + integer forstk + common /cgoto/ xfer + integer xfer + common /clabel/ label, retlab, memflg, col, logic0 + integer label + integer retlab + integer memflg + integer col + integer logic0 + common /cline/ dbgout, dbglev, level, linect (5), infile (5), fnam + *p, fnames ( 150) + integer dbgout + integer dbglev + integer level + integer linect + integer infile + integer fnamp + integer fnames + common /cmacro/ cp, ep, evalst (500), deftbl + integer cp + integer ep + integer evalst + integer deftbl + common /coutln/ outp, outbuf (74) + integer outp + integer outbuf + common /csbuf/ sbp, sbuf(2048), smem(240) + integer sbp + integer sbuf + integer smem + common /cswtch/ swtop, swlast, swstak(1000), swvnum, swvlev, swvst + *k(10), swinrg + integer swtop + integer swlast + integer swstak + integer swvnum + integer swvlev + integer swvstk + integer swinrg + common /ckword/ rkwtbl + integer rkwtbl + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + integer fkwtbl + integer namtbl + integer gentbl + integer errtbl + integer xpptbl + common /erchek/ ername, body, esp, errstk(30) + integer ername + integer body + integer esp + integer errstk + integer mem( 60000) + common/cdsmem/mem + call outgo (lab) + call indent (-1) + call outcon (lab + 1) + return + end +c logic0 logical_column diff --git a/unix/boot/spp/rpp/rpprat/Makefile b/unix/boot/spp/rpp/rpprat/Makefile new file mode 100644 index 00000000..b09289f7 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/Makefile @@ -0,0 +1,44 @@ +# Ratfor source for the SPP preprocessor. A TOOLS compatible ratfor compiler +# is required to compile this. The original UNIX ratfor compiler may not do +# the job. + +.r.f: + /usr/local/bin/ratfor $*.r > $*.f + +SRCS= addchr.r allblk.r alldig.r baderr.r balpar.r beginc.r brknxt.r\ + cascod.r caslab.r declco.r deftok.r doarth.r docode.r doif.r\ + doincr.r domac.r dostat.r dosub.r eatup.r elseif.r endcod.r\ + entdef.r entdkw.r entfkw.r entrkw.r entxkw.r errchk.r errgo.r\ + errorc.r evalr.r finit.r forcod.r fors.r getdef.r gettok.r\ + gnbtok.r gocode.r gtok.r ifcode.r iferrc.r ifgo.r ifparm.r\ + indent.r initkw.r labelc.r labgen.r lex.r litral.r lndict.r\ + ludef.r mapid.r ngetch.r ogotos.r otherc.r outch.r outcon.r\ + outdon.r outdwe.r outgo.r outnum.r outstr.r outtab.r parse.r\ + pbnum.r pbstr.r poicod.r push.r putbak.r putchr.r puttok.r\ + ratfor.r relate.r repcod.r retcod.r sdupl.r skpblk.r squash.r\ + strdcl.r swcode.r swend.r swvar.r synerr.r thenco.r ulstal.r\ + uniqid.r unstak.r untils.r whilec.r whiles.r + +FORT= addchr.f allblk.f alldig.f baderr.f balpar.f beginc.f brknxt.f\ + cascod.f caslab.f declco.f deftok.f doarth.f docode.f doif.f\ + doincr.f domac.f dostat.f dosub.f eatup.f elseif.f endcod.f\ + entdef.f entdkw.f entfkw.f entrkw.f entxkw.f errchk.f errgo.f\ + errorc.f evalr.f finit.f forcod.f fors.f getdef.f gettok.f\ + gnbtok.f gocode.f gtok.f ifcode.f iferrc.f ifgo.f ifparm.f\ + indent.f initkw.f labelc.f labgen.f lex.f litral.f lndict.f\ + ludef.f mapid.f ngetch.f ogotos.f otherc.f outch.f outcon.f\ + outdon.f outdwe.f outgo.f outnum.f outstr.f outtab.f parse.f\ + pbnum.f pbstr.f poicod.f push.f putbak.f putchr.f puttok.f\ + ratfor.f relate.f repcod.f retcod.f sdupl.f skpblk.f squash.f\ + strdcl.f swcode.f swend.f swvar.f synerr.f thenco.f ulstal.f\ + uniqid.f unstak.f untils.f whilec.f whiles.f + +# NOTE -- After regenerating the fortran CASLAB.F, comment out the unreachable +# goto on line 32, generated due to a bug in the ratfor. + +fort: $(SRCS) common defs + make fsrc; mv *.f ../rppfor; touch fort + (cd ../rppfor; sed -e 's/ goto 23012/c goto 23012/'\ + < caslab.f > temp; mv temp caslab.f) + +fsrc: $(FORT) diff --git a/unix/boot/spp/rpp/rpprat/addchr.r b/unix/boot/spp/rpp/rpprat/addchr.r new file mode 100644 index 00000000..74695f93 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/addchr.r @@ -0,0 +1,15 @@ +#-h- addchr 254 local 12/01/80 15:53:44 +# addchr - put c in buf (bp) if it fits, increment bp + include defs + + subroutine addchr (c, buf, bp, maxsiz) + integer bp, maxsiz + character c, buf (ARB) + + if (bp > maxsiz) + call baderr ("buffer overflow.") + buf (bp) = c + bp = bp + 1 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/allblk.r b/unix/boot/spp/rpp/rpprat/allblk.r new file mode 100644 index 00000000..34b83451 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/allblk.r @@ -0,0 +1,22 @@ +#-h- allblk 486 local 12/01/80 15:53:44 +# allblk - determine if line consists of all blanks + include defs + +# this routine is called by outdon, and is here to fix +# a bug which sometimes occurs if two or more includes precede the +# first line of executable code. Could not trace down the cause + + integer function allblk (buf) + character buf (ARB) + + integer i + + allblk = YES + for (i = 1; buf (i) != NEWLINE & buf (i) != EOS; i = i + 1) + if (buf (i) != BLANK) { + allblk = NO + break + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/alldig.r b/unix/boot/spp/rpp/rpprat/alldig.r new file mode 100644 index 00000000..bac06161 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/alldig.r @@ -0,0 +1,17 @@ +#-h- alldig 306 local 12/01/80 15:53:45 +# alldig - return YES if str is all digits + include defs + + integer function alldig (str) + character str (ARB) + integer i + + alldig = NO + if (str (1) == EOS) + return + for (i = 1; str (i) != EOS; i = i + 1) + if (!IS_DIGIT(str (i))) + return + alldig = YES + return + end diff --git a/unix/boot/spp/rpp/rpprat/baderr.r b/unix/boot/spp/rpp/rpprat/baderr.r new file mode 100644 index 00000000..51164a8d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/baderr.r @@ -0,0 +1,12 @@ +#-h- baderr 144 local 12/01/80 15:53:45 +# baderr --- report fatal error message, then die + include defs + + subroutine baderr (msg) + + character msg (ARB) +# character*(*) msg + + call synerr (msg) + call endst + end diff --git a/unix/boot/spp/rpp/rpprat/balpar.r b/unix/boot/spp/rpp/rpprat/balpar.r new file mode 100644 index 00000000..8e0388b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/balpar.r @@ -0,0 +1,40 @@ +#-h- balpar 854 local 12/01/80 15:53:46 +# balpar - copy balanced paren string + include defs + + subroutine balpar + + character t, token (MAXTOK) + character gettok, gnbtok + + integer nlpar + + if (gnbtok (token, MAXTOK) != LPAREN) { + call synerr ("missing left paren.") + return + } + call outstr (token) + nlpar = 1 + repeat { + t = gettok (token, MAXTOK) + if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) { + call pbstr (token) + break + } + if (t == NEWLINE) # delete newlines + token (1) = EOS + else if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + # else nothing special + call outstr (token) + } until (nlpar <= 0) + + if (nlpar != 0) + call synerr ("missing parenthesis in condition.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/beginc.r b/unix/boot/spp/rpp/rpprat/beginc.r new file mode 100644 index 00000000..ceb39e4b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/beginc.r @@ -0,0 +1,20 @@ + +include defs + +# BEGINC -- Code that gets executed when the "begin" statement is encountered, +# at the beginning of the executable section of a procedure. + + +subroutine beginc + +integer labgen +include COMMON_BLOCKS + + body = YES # in body of procedure + ername = NO # errchk name not encountered + esp = 0 # error stack pointer + label = FIRST_LABEL # start over with labels + retlab = labgen (1) # label for return stmt + logical_column = 6 + INDENT + col = logical_column +end diff --git a/unix/boot/spp/rpp/rpprat/brknxt.r b/unix/boot/spp/rpp/rpprat/brknxt.r new file mode 100644 index 00000000..154dc31e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/brknxt.r @@ -0,0 +1,45 @@ +#-h- brknxt 1077 local 12/01/80 15:53:46 +# brknxt - generate code for break n and next n; n = 1 is default + include defs + + subroutine brknxt (sp, lextyp, labval, token) + integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token + + integer i, n + integer alldig, ctoi + + character t, ptoken (MAXTOK) + character gnbtok + + include COMMON_BLOCKS + + n = 0 + t = gnbtok (ptoken, MAXTOK) + if (alldig (ptoken) == YES) { # have break n or next n + i = 1 + n = ctoi (ptoken, i) - 1 + } + else if (t != SEMICOL) # default case + call pbstr (ptoken) + for (i = sp; i > 0; i = i - 1) + if (lextyp (i) == LEXWHILE | lextyp (i) == LEXDO + | lextyp (i) == LEXFOR | lextyp (i) == LEXREPEAT) { + if (n > 0) { + n = n - 1 + next # seek proper level + } + else if (token == LEXBREAK) + call outgo (labval (i) + 1) + else + call outgo (labval (i)) + xfer = YES + return + } + + if (token == LEXBREAK) + call synerr ("illegal break.") + else + call synerr ("illegal next.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/cascod.r b/unix/boot/spp/rpp/rpprat/cascod.r new file mode 100644 index 00000000..073dc9a4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/cascod.r @@ -0,0 +1,71 @@ +#-h- cascod 1876 local 12/01/80 15:53:46 +# cascod - generate code for case or default label + include defs + + subroutine cascod (lab, token) + integer lab, token + + include COMMON_BLOCKS + + integer t, l, lb, ub, i, j, junk + integer caslab, labgen, gnbtok + + character tok (MAXTOK) + + if (swtop <= 0) { + call synerr ("illegal case or default.") + return + } + call indent (-1) + call outgo (lab + 1) # terminate previous case + xfer = YES + l = labgen (1) + if (token == LEXCASE) { # case n[,n]... : ... + while (caslab (lb, t) != EOF) { + ub = lb + if (t == MINUS) + junk = caslab (ub, t) + if (lb > ub) { + call synerr ("illegal range in case label.") + ub = lb + } + if (swlast + 3 > MAXSWITCH) + call baderr ("switch table overflow.") + for (i = swtop + 3; i < swlast; i = i + 3) + if (lb <= swstak (i)) + break + else if (lb <= swstak (i+1)) + call synerr ("duplicate case label.") + if (i < swlast & ub >= swstak (i)) + call synerr ("duplicate case label.") + for (j = swlast; j > i; j = j - 1) # insert new entry + swstak (j+2) = swstak (j-1) + swstak (i) = lb + swstak (i + 1) = ub + swstak (i + 2) = l + swstak (swtop + 1) = swstak (swtop + 1) + 1 + swlast = swlast + 3 + if (t == COLON) + break + else if (t != COMMA) + call synerr ("illegal case syntax.") + } + } + else { # default : ... + t = gnbtok (tok, MAXTOK) + if (swstak (swtop + 2) != 0) + call error ("multiple defaults in switch statement.") + else + swstak (swtop + 2) = l + } + + if (t == EOF) + call synerr ("unexpected EOF.") + else if (t != COLON) + call error ("missing colon in case or default label.") + + xfer = NO + call outcon (l) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/caslab.r b/unix/boot/spp/rpp/rpprat/caslab.r new file mode 100644 index 00000000..12d3c0da --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/caslab.r @@ -0,0 +1,48 @@ +include defs + +# caslab - get one case label + +integer function caslab (n, t) + +integer n, t +character tok(MAXTOK) +integer i, s, lev +integer gnbtok, ctoi + + t = gnbtok (tok, MAXTOK) + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + if (t == EOF) + return (t) + + for (lev=0; t == LPAREN; t = gnbtok (tok, MAXTOK)) + lev = lev + 1 + + if (t == MINUS) + s = -1 + else + s = +1 + if (t == MINUS | t == PLUS) + t = gnbtok (tok, MAXTOK) + + if (t != DIGIT) + goto 99 + else { + i = 1 + n = s * ctoi (tok, i) + } + + for (t=gnbtok(tok,MAXTOK); t == RPAREN; t=gnbtok(tok,MAXTOK)) + lev = lev - 1 + if (lev != 0) + goto 99 + + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + return + + 99 call synerr ("Invalid case label.") + n = 0 +end diff --git a/unix/boot/spp/rpp/rpprat/common b/unix/boot/spp/rpp/rpprat/common new file mode 100644 index 00000000..9685729a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/common @@ -0,0 +1,79 @@ +#-h- common 2163 local 12/01/80 15:50:08 +# Common blocks used by the Ratfor preprocessor +# Place on a file called 'common' + + + common /cdefio/ bp, buf (BUFSIZE) + integer bp # next available character; init = 0 + character buf # pushed-back characters + + common /cfname/ fcname (MAXNAME) + character fcname # text of current function name + + common /cfor/ fordep, forstk (MAXFORSTK) + integer fordep # current depth of for statements + character forstk # stack of reinit strings + + common /cgoto/ xfer + integer xfer # YES if just made transfer, NO otherwise + + common /clabel/ label, retlab, memflg, col, logical_column + integer label # next label returned by labgen + integer retlab # label for return code at end of procedure + integer memflg # set to YES after Mem common has been declared + integer col # column where output statement starts + integer logical_column # col = min (maxindent, logical_column) + + common /cline/ dbgout, dbglev, level, linect (NFILES), infile (NFILES), + fnamp, fnames (MAXFNAMES) + integer dbgout # YES if debug (-g) output is desired + integer dbglev # current file level for debug output + integer level # level of file inclusion; init = 1 + integer linect # line count on input file (level); init = 1 + integer infile # file number (level); init infile (1) = STDIN + integer fnamp # next free slot in fnames; init = 2 + character fnames # stack of include names; init fnames (1) = EOS + + common /cmacro/ cp, ep, evalst (EVALSIZE), deftbl + integer cp # current call stack pointer + integer ep # next free position in evalst + character evalst # evaluation stack + pointer deftbl # symbol table holding macro names + + common /coutln/ outp, outbuf (74) + integer outp # last position filled in outbuf; init = 0 + character outbuf # output lines collected here + + common /csbuf/ sbp, sbuf(SBUFSIZE), smem(SZ_SMEM) + integer sbp # next available character position; init = 1 + character sbuf # saved for data statements + character smem # mem declaration + + common /cswtch/ swtop, swlast, swstak(MAXSWITCH), swvnum, swvlev, + swvstk(MAXSWNEST), swinrg + integer swtop # current switch entry; init = 0 + integer swlast # next available position; init = 1 + integer swstak # switch information + integer swvnum # counter for switch variable names; init = 0 + integer swvlev # level pointer for nesting of switches; init = 0 + integer swvstk # stack for the switch variable names + integer swinrg # assert swinrange - disable range checking in next sw. + + common /ckword/ rkwtbl + pointer rkwtbl # symbol table containing Ratfor key words + + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + pointer fkwtbl # a list of long Fortran keywords + pointer namtbl # map of long-form names to short-form names + pointer gentbl # list of generated names + pointer errtbl # symbol table of names to be error checked + pointer xpptbl # table of xpp directives + +common /erchek/ ername, body, esp, errstk(MAXERRSTK) + integer ername # YES if err checked name encountered + integer body # YES when between BEGIN .. END block + integer esp # error stack pointer + integer errstk # error stack (for statement labels) + + DS_DECL(mem, MEMSIZE) +#-t- common 2163 local 12/01/80 15:50:08 diff --git a/unix/boot/spp/rpp/rpprat/declco.r b/unix/boot/spp/rpp/rpprat/declco.r new file mode 100644 index 00000000..7c669e8c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/declco.r @@ -0,0 +1,72 @@ +include defs + +# DECLCO -- Process a declaration (xpp directive). Look up directive in +# the symbol table. If found, output the corresponding Fortran declaration, +# otherwise output the original string. + +subroutine declco (id) + +character id(MAXTOK) +character newid(MAXTOK), tok, tokbl +integer junk, ludef, equal, gettok +include COMMON_BLOCKS +string xptyp XPOINTER +string xpntr "x$pntr" +string xfunc "x$func" +string xsubr "x$subr" +ifdef (IMPNONE, +string impnone "implicit none") + + if (ludef (id, newid, xpptbl) == YES) { + if (equal (id, xpntr) == YES) { + # Pointer declaration. + tokbl = gettok (newid, MAXTOK) + if (tokbl == BLANK) + tok = gettok (newid, MAXTOK) + else + tok = tokbl + + if (tok == XPP_DIRECTIVE & equal (newid, xfunc) == YES) { + # Pointer function. + call outtab + call outstr (xptyp) + junk = ludef (newid, newid, xpptbl) + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + call poicod (NO) + + } else { + # Pointer variable. + call pbstr (newid) + call poicod (YES) + } + + } else if (equal (id, xsubr) == YES) { + # Subroutine declaration. + call outtab + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + } else { + # Some other declaration. + call outtab + call outstr (newid) + call outch (BLANK) + } + + } else + call synerr ("Invalid x$type type declaration.") +end diff --git a/unix/boot/spp/rpp/rpprat/defs b/unix/boot/spp/rpp/rpprat/defs new file mode 100644 index 00000000..bf040c55 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/defs @@ -0,0 +1,138 @@ +# common definitions for all routines comprising the ratfor preprocessor +#--------------------------------------------------------------- +# The definition STDEFNS defines the file which contains the +# standard definitions to be used when preprocessing a file. +# It is opened and read automatically by the ratfor preprocessor. +# Set STDEFNS to the name of the file in which the standard +# definitions reside. If you don't want the preprocessor to +# automatically open this file, set STDENFS to "". +# +#--------------------------------------------------------------- +# If you want the preprocessor to output upper case only, +# set the following definition: +# +# define (UPPERC,) +# +#--------------------------------------------------------------- +# Some of the buffer sizes and other symbols might have to be +# changed. Especially check the following: +# +# MAXDEF (number of characters in a definition) +# SBUFSIZE (nbr string declarations allowed per module) +# MAXSTRTBL (size of table to buffer string declarations) +# MAXSWITCH (max stack for switch statement) +# +#----------------------------------------------------------------- + + +define (STDEFNS, string defns "") # standard defns file +#define (UPPERC,) # define if Fortran compiler wants upper case +#define (IMPNONE,) # output IMPLICIT NONE in procedures +define (NULL,0) +define (INDENT,3) # number of spaces of indentation +define (MAX_INDENT,30) # maximum column for indentation +define (FIRST_LABEL,100) # first statement label +define (SZ_SPOOLBUF,8) # for breaking continuation cards + +define (RADIX,PERCENT) # % indicates alternate radix +define (TOGGLE,PERCENT) # toggle for literal lines +define (ARGFLAG,DOLLAR) +define (CUTOFF,3) # min nbr of cases to generate branch table + # (for switch statement) +define (DENSITY,2) # reciprocal of density necessary for + # branch table +define (FILLCHAR,DIG0) # used in long-name uniquing +define (MAXIDLENGTH,6) # for Fortran 66 and 77 +define (SZ_SMEM,240) # memory common declarations string + + +# Lexical items (codes are negative to avoid conflict with character values) + +define (LEXBEGIN,-83) +define (LEXBREAK,-79) +define (LEXCASE,-91) +define (LEXDEFAULT,-90) +define (LEXDIGITS,-89) +define (LEXDO,-96) +define (LEXELSE,-87) +define (LEXEND,-82) +define (LEXERRCHK,-84) +define (LEXERROR,-73) +define (LEXFOR,-94) +define (LEXIF,-99) +define (LEXIFELSE,-72) +define (LEXIFERR,-98) +define (LEXIFNOERR,-97) +define (LEXLITERAL,-85) +define (LEXNEXT,-78) +define (LEXOTHER,-80) +define (LEXPOINTER,-88) +define (LEXRBRACE,-74) +define (LEXREPEAT,-93) +define (LEXRETURN,-77) +define (LEXGOTO,-76) +define (LEXSTOP,-71) +define (LEXSTRING,-75) +define (LEXSWITCH,-92) +define (LEXTHEN,-86) +define (LEXUNTIL,-70) +define (LEXWHILE,-95) +define (LSTRIPC,-69) +define (RSTRIPC,-68) +define (LEXDECL,-67) + +define (XPP_DIRECTIVE, -166) + +# Built-in macro functions: + +define (DEFTYPE,-4) +define (MACTYPE,-10) +define (IFTYPE,-11) +define (INCTYPE,-12) +define (SUBTYPE,-13) +define (ARITHTYPE,-14) +define (IFDEFTYPE,-15) +define (IFNOTDEFTYPE,-16) +define (PRAGMATYPE,-17) + + +# Size-limiting definitions: + +define (MEMSIZE,60000) # space allotted to symbol tables and macro text +define (BUFSIZE,4096) # pushback buffer for ngetch and putbak +define (PBPOINT,3192) # point in buffer where pushback begins +define (SBUFSIZE,2048) # buffer for string statements +define (MAXDEF,2048) # max chars in a defn +define (MAXFORSTK,200) # max space for for reinit clauses +define (MAXERRSTK,30) # max nesting of iferr statements +define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) +define (MAXSTACK,100) # max stack depth for parser +define (MAXSWITCH,1000) # max stack for switch statement +define (MAXSWNEST,10) # max nesting of switches in a procedure +define (MAXTOK,100) # max chars in a token +define (NFILES,5) # max number of include file nesting +define (MAXNBRSTR,20) #max nbr string declarations per module +define (CALLSIZE,50) +define (ARGSIZE,100) +define (EVALSIZE,500) + + +# Where to find the common blocks: + +define(COMMON_BLOCKS,"common") + +# Data types, Dynamic Memory common: + +define (XPOINTER,"integer ") + + +# The following external names are redefined to avoid name collisions with +# standard library procedures on some systems. + +define open rfopen +define close rfclos +define flush rfflus +define note rfnote +define seek rfseek +define remove rfrmov +define exit rexit diff --git a/unix/boot/spp/rpp/rpprat/deftok.r b/unix/boot/spp/rpp/rpprat/deftok.r new file mode 100644 index 00000000..af20c35c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/deftok.r @@ -0,0 +1,162 @@ +#-h- deftok 4116 local 12/01/80 15:53:47 +# deftok - get token; process macro calls and invocations + include defs + +# this routine has been disabled to allow defines with parameters to be added + +# character function deftok (token, toksiz) +# character gtok +# integer toksiz +# character defn (MAXDEF), t, token (MAXTOK) +# integer ludef +# include COMMON_BLOCKS +# +# for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) { +# if (t != ALPHA) # non-alpha +# break +# if (ludef (token, defn, deftbl) == NO) # undefined +# break +# if (defn (1) == DEFTYPE) { # get definition +# call getdef (token, toksiz, defn, MAXDEF) +# call entdef (token, defn, deftbl) +# } +# else +# call pbstr (defn) # push replacement onto input +# } +# deftok = t +# if (deftok == ALPHA) # convert to single case +# call fold (token) +# return +# end +# deftok - get token; process macro calls and invocations + + character function deftok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character t, c, defn (MAXDEF), mdefn (MAXDEF) + character gtok + integer equal + + integer ap, argstk (ARGSIZE), callst (CALLSIZE), + nlb, plev (CALLSIZE), ifl + integer ludef, push, ifparm + + string balp "()" + string pswrg "switch_no_range_check" + + cp = 0 + ap = 1 + ep = 1 + for (t = gtok (token, toksiz); t != EOF; t = gtok (token, toksiz)) { + if (t == ALPHA) + if (ludef (token, defn, deftbl) == NO) { + if (cp == 0) + break + else + call puttok (token) + } else if (defn (1) == DEFTYPE) { # process defines directly + call getdef (token, toksiz, defn, MAXDEF) + call entdef (token, defn, deftbl) + } else if (defn (1) == IFDEFTYPE | defn (1) == IFNOTDEFTYPE) { + c = defn (1) + call getdef (token, toksiz, defn, MAXDEF) + ifl = ludef (token, mdefn, deftbl) + if ((ifl == YES & c == IFDEFTYPE) | + (ifl == NO & c == IFNOTDEFTYPE)) + call pbstr (defn) + + } else if (defn(1) == PRAGMATYPE & cp == 0) { # pragma + if (gtok (defn, MAXDEF) == BLANK) { + if (gtok (defn, MAXDEF) == ALPHA) { + if (equal (defn, pswrg) == YES) + swinrg = YES + else + goto 10 + } else { +10 call pbstr (defn) + call putbak (BLANK) + break + } + } else { + call pbstr (defn) + break + } + + } else { + cp = cp + 1 + if (cp > CALLSIZE) + call baderr ("call stack overflow.") + callst (cp) = ap + ap = push (ep, argstk, ap) + call puttok (defn) + call putchr (EOS) + ap = push (ep, argstk, ap) + call puttok (token) + call putchr (EOS) + ap = push (ep, argstk, ap) + t = gtok (token, toksiz) + if (t == BLANK) { # allow blanks before arguments + t = gtok (token, toksiz) + call pbstr (token) + if (t != LPAREN) + call putbak (BLANK) + } + else + call pbstr (token) + if (t != LPAREN) + call pbstr (balp) + else if (ifparm (defn) == NO) + call pbstr (balp) + plev (cp) = 0 + } else if (t == LSTRIPC) { + nlb = 1 + repeat { + t = gtok (token, toksiz) + if (t == LSTRIPC) + nlb = nlb + 1 + else if (t == RSTRIPC) { + nlb = nlb - 1 + if (nlb == 0) + break + } + else if (t == EOF) + call baderr ("EOF in string.") + call puttok (token) + } + } + else if (cp == 0) + break + else if (t == LPAREN) { + if (plev (cp) > 0) + call puttok (token) + plev (cp) = plev (cp) + 1 + } + else if (t == RPAREN) { + plev (cp) = plev (cp) - 1 + if (plev (cp) > 0) + call puttok (token) + else { + call putchr (EOS) + call evalr (argstk, callst (cp), ap - 1) + ap = callst (cp) + ep = argstk (ap) + cp = cp - 1 + } + } + else if (t == COMMA & plev (cp) == 1) { + call putchr (EOS) + ap = push (ep, argstk, ap) + } + else + call puttok (token) + } + + deftok = t + if (t == ALPHA) + call fold (token) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/doarth.r b/unix/boot/spp/rpp/rpprat/doarth.r new file mode 100644 index 00000000..2fe633d5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doarth.r @@ -0,0 +1,30 @@ +#-h- doarth 636 local 12/01/80 15:53:48 +# doarth - do arithmetic operation + include defs + + subroutine doarth (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer k, l + integer ctoi + + character op + + k = argstk (i + 2) + l = argstk (i + 4) + op = evalst (argstk (i + 3)) + if (op == PLUS) + call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) + else if (op == MINUS) + call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) + else if (op == STAR ) + call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) + else if (op == SLASH ) + call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) + else + call remark ('arith error') + + return + end diff --git a/unix/boot/spp/rpp/rpprat/docode.r b/unix/boot/spp/rpp/rpprat/docode.r new file mode 100644 index 00000000..e505f8ee --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/docode.r @@ -0,0 +1,33 @@ +#-h- docode 522 local 12/01/80 15:53:49 +# docode - generate code for beginning of do + include defs + + subroutine docode (lab) + integer lab + + integer labgen + + include COMMON_BLOCKS + + character gnbtok + character lexstr (MAXTOK) + + string sdo "do" + + xfer = NO + call outtab + call outstr (sdo) + call outch (BLANK) + lab = labgen (2) + if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO + call outstr (lexstr) + else { + call pbstr (lexstr) + call outnum (lab) + } + call outch (BLANK) + call eatup + call outdwe + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/doif.r b/unix/boot/spp/rpp/rpprat/doif.r new file mode 100644 index 00000000..51495bd2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doif.r @@ -0,0 +1,25 @@ +#-h- doif 458 local 12/01/80 15:53:49 +# doif - select one of two (macro) arguments + include defs + + subroutine doif (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer a2, a3, a4, a5 + integer equal + + if (j - i < 5) + return + a2 = argstk (i + 2) + a3 = argstk (i + 3) + a4 = argstk (i + 4) + a5 = argstk (i + 5) + if (equal (evalst (a2), evalst (a3)) == YES) # subarrays + call pbstr (evalst (a4)) + else + call pbstr (evalst (a5)) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/doincr.r b/unix/boot/spp/rpp/rpprat/doincr.r new file mode 100644 index 00000000..9a8604bf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doincr.r @@ -0,0 +1,17 @@ +#-h- doincr 246 local 12/01/80 15:53:49 +# doincr - increment macro argument by 1 + include defs + + subroutine doincr (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer k + integer ctoi + + k = argstk (i + 2) + call pbnum (ctoi (evalst, k) + 1) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/domac.r b/unix/boot/spp/rpp/rpprat/domac.r new file mode 100644 index 00000000..fe4c1c62 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/domac.r @@ -0,0 +1,18 @@ +#-h- domac 326 local 12/01/80 15:53:49 +# domac - install macro definition in table + include defs + + subroutine domac (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer a2, a3 + + if (j - i > 2) { + a2 = argstk (i + 2) + a3 = argstk (i + 3) + call entdef (evalst (a2), evalst (a3), deftbl) # subarrays + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/dostat.r b/unix/boot/spp/rpp/rpprat/dostat.r new file mode 100644 index 00000000..4a934bad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dostat.r @@ -0,0 +1,13 @@ +#-h- dostat 156 local 12/01/80 15:53:50 +# dostat - generate code for end of do statement + include defs + + subroutine dostat (lab) + + integer lab + + call indent (-1) + call outcon (lab) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/dosub.r b/unix/boot/spp/rpp/rpprat/dosub.r new file mode 100644 index 00000000..611bdbaf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dosub.r @@ -0,0 +1,31 @@ +#-h- dosub 709 local 12/01/80 15:53:50 +# dosub - select macro substring + include defs + + subroutine dosub (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer ap, fc, k, nc + integer ctoi, length + + if (j - i < 3) + return + if (j - i < 4) + nc = MAXTOK + else { + k = argstk (i + 4) + nc = ctoi (evalst, k) # number of characters + } + k = argstk (i + 3) # origin + ap = argstk (i + 2) # target string + fc = ap + ctoi (evalst, k) - 1 # first char of substring + if (fc >= ap & fc < ap + length (evalst (ap))) { # subarrays + k = fc + min (nc, length (evalst (fc))) - 1 + for ( ; k >= fc; k = k - 1) + call putbak (evalst (k)) + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/eatup.r b/unix/boot/spp/rpp/rpprat/eatup.r new file mode 100644 index 00000000..df001caf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/eatup.r @@ -0,0 +1,69 @@ +#-h- eatup 1137 local 12/01/80 15:53:50 +# eatup - process rest of statement; interpret continuations + include defs + + subroutine eatup + + character ptoken (MAXTOK), t, token (MAXTOK) + character gettok + integer nlpar, equal + include COMMON_BLOCKS + string serror "error" + + nlpar = 0 + token(1) = EOS + + repeat { + call outstr (token) + t = gettok (token, MAXTOK) + } until (t != BLANK & t != TAB) + + if (t == ALPHA) { # is it a "call error" stmt? + if (equal (token, serror) == YES) { + # call errorc (token) + # return + + # ERROR statement is now simply error checked like any other + # external procedure, so that it may be used the same way. + ername = YES + } + } + goto 10 + + repeat { + t = gettok (token, MAXTOK) +10 if (t == SEMICOL | t == NEWLINE) + break + if (t == RBRACE | t == LBRACE) { + call pbstr (token) + break + } + if (t == EOF) { + call synerr ("unexpected EOF.") + call pbstr (token) + break + } + if (t == COMMA | t == PLUS | t == MINUS | t == STAR | + (t == SLASH & body == YES) | + t == LPAREN | t == AND | t == BAR | t == BANG | t == TILDE | + t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) { + while (gettok (ptoken, MAXTOK) == NEWLINE) + ; + call pbstr (ptoken) + if (t == UNDERLINE) + token (1) = EOS + } + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + call outstr (token) + } until (nlpar < 0) + + if (nlpar != 0) + call synerr ("unbalanced parentheses.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/elseif.r b/unix/boot/spp/rpp/rpprat/elseif.r new file mode 100644 index 00000000..88b1355d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/elseif.r @@ -0,0 +1,13 @@ +#-h- elseif 155 local 12/01/80 15:53:51 +# elseif - generate code for end of if before else + include defs + + subroutine elseif (lab) + integer lab + + call outgo (lab+1) + call indent (-1) + call outcon (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/endcod.r b/unix/boot/spp/rpp/rpprat/endcod.r new file mode 100644 index 00000000..f94636f8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/endcod.r @@ -0,0 +1,36 @@ +include defs + +# ENDCOD -- Code thats gets executed when the END statement is encountered, +# terminating a procedure. + +subroutine endcod (endstr) + +character endstr(1) +include COMMON_BLOCKS +string sepro "call zzepro" +string sret "return" + + if (esp != 0) + call synerr ("Unmatched 'iferr' or 'then' keyword.") + esp = 0 # error stack pointer + body = NO + ername = NO + if (errtbl != NULL) + call rmtabl (errtbl) + errtbl = NULL + memflg = NO # reinit mem decl flag + + if (retlab != NULL) + call outnum (retlab) + call outtab + call outstr (sepro) + call outdon + call outtab + call outstr (sret) + call outdon + + col = 6 + call outtab + call outstr (endstr) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/entdef.r b/unix/boot/spp/rpp/rpprat/entdef.r new file mode 100644 index 00000000..e9c447ff --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdef.r @@ -0,0 +1,19 @@ +#-h- entdef 387 local 12/01/80 15:53:51 +# entdef - enter a new symbol definition, discarding any old one + include defs + + subroutine entdef (name, defn, table) + character name (MAXTOK), defn (ARB) + pointer table + + integer lookup + + pointer text + pointer sdupl + + if (lookup (name, text, table) == YES) + call dsfree (text) # this is how to do UNDEFINE, by the way + call enter (name, sdupl (defn), table) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entdkw.r b/unix/boot/spp/rpp/rpprat/entdkw.r new file mode 100644 index 00000000..6b061075 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdkw.r @@ -0,0 +1,41 @@ +#-h- entdkw 975 local 12/01/80 15:54:05 +# entdkw --- install macro processor keywords + include defs + + subroutine entdkw + + character deft(2), prag(2) #, inct(2), subt(2), ift(2), art(2), + # ifdft(2), ifndt(2), mact(2) + + string defnam "define" + string prgnam "pragma" +# string macnam "mdefine" +# string incnam "incr" +# string subnam "substr" +# string ifnam "ifelse" +# string arnam "arith" +# string ifdfnm "ifdef" +# string ifndnm "ifnotdef" + + data deft (1), deft (2) /DEFTYPE, EOS/ + data prag (1), prag (2) /PRAGMATYPE, EOS/ +# data mact (1), mact (2) /MACTYPE, EOS/ +# data inct (1), inct (2) /INCTYPE, EOS/ +# data subt (1), subt (2) /SUBTYPE, EOS/ +# data ift (1), ift (2) /IFTYPE, EOS/ +# data art (1), art (2) /ARITHTYPE, EOS/ +# data ifdft (1), ifdft (2) /IFDEFTYPE, EOS/ +# data ifndt (1), ifndt (2) /IFNOTDEFTYPE, EOS/ + + call ulstal (defnam, deft) + call ulstal (prgnam, prag) +# call ulstal (macnam, mact) +# call ulstal (incnam, inct) +# call ulstal (subnam, subt) +# call ulstal (ifnam, ift) +# call ulstal (arnam, art) +# call ulstal (ifdfnm, ifdft) +# call ulstal (ifndnm, ifndt) + +return +end diff --git a/unix/boot/spp/rpp/rpprat/entfkw.r b/unix/boot/spp/rpp/rpprat/entfkw.r new file mode 100644 index 00000000..43174502 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entfkw.r @@ -0,0 +1,14 @@ +include defs + +# entfkw - place Fortran keywords in symbol table. +# Place in the following table any long (> 6 characters) +# keyword that is used by your Fortran compiler: + + +subroutine entfkw + +include COMMON_BLOCKS +string sequiv "equivalence" + + call enter (sequiv, 0, fkwtbl) +end diff --git a/unix/boot/spp/rpp/rpprat/entrkw.r b/unix/boot/spp/rpp/rpprat/entrkw.r new file mode 100644 index 00000000..ec86b9e0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entrkw.r @@ -0,0 +1,56 @@ +#-h- entrkw 1003 local 12/01/80 15:54:06 +# entrkw --- install Ratfor keywords in symbol table + include defs + + subroutine entrkw + + include COMMON_BLOCKS + + string sif "if" + string selse "else" + string swhile "while" + string sdo "do" + string sbreak "break" + string snext "next" + string sfor "for" + string srept "repeat" + string suntil "until" + string sret "return" + string sstr "string" + string sswtch "switch" + string scase "case" + string sdeflt "default" + string send "end" + string serrchk "errchk" + string siferr "iferr" + string sifnoerr "ifnoerr" + string sthen "then" + string sbegin "begin" + string spoint "pointer" + string sgoto "goto" + + call enter (sif, LEXIF, rkwtbl) + call enter (selse, LEXELSE, rkwtbl) + call enter (swhile, LEXWHILE, rkwtbl) + call enter (sdo, LEXDO, rkwtbl) + call enter (sbreak, LEXBREAK, rkwtbl) + call enter (snext, LEXNEXT, rkwtbl) + call enter (sfor, LEXFOR, rkwtbl) + call enter (srept, LEXREPEAT, rkwtbl) + call enter (suntil, LEXUNTIL, rkwtbl) + call enter (sret, LEXRETURN, rkwtbl) + call enter (sstr, LEXSTRING, rkwtbl) + call enter (sswtch, LEXSWITCH, rkwtbl) + call enter (scase, LEXCASE, rkwtbl) + call enter (sdeflt, LEXDEFAULT, rkwtbl) + call enter (send, LEXEND, rkwtbl) + call enter (serrchk, LEXERRCHK, rkwtbl) + call enter (siferr, LEXIFERR, rkwtbl) + call enter (sifnoerr, LEXIFNOERR, rkwtbl) + call enter (sthen, LEXTHEN, rkwtbl) + call enter (sbegin, LEXBEGIN, rkwtbl) + call enter (spoint, LEXPOINTER, rkwtbl) + call enter (sgoto, LEXGOTO, rkwtbl) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entxkw.r b/unix/boot/spp/rpp/rpprat/entxkw.r new file mode 100644 index 00000000..d2ec81b2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entxkw.r @@ -0,0 +1,51 @@ + +include defs + +# ENTXKW -- Enter all XPP directives in the symbol table. + +subroutine entxkw + +include COMMON_BLOCKS + +string sbool "x$bool" +string schar "x$char" +string sshort "x$short" +string sint "x$int" +string slong "x$long" +string sreal "x$real" +string sdble "x$dble" +string scplx "x$cplx" +string spntr "x$pntr" +string sfchr "x$fchr" +string sfunc "x$func" +string ssubr "x$subr" +string sextn "x$extn" + +string dbool "logical" +string dchar "integer*2" +string dshort "integer*2" +string dint "integer" +string dlong "integer" +string dpntr "integer" +string dreal "real" +string ddble "double precision" +string dcplx "complex" +string dfchr "character" +string dfunc "function" +string dsubr "subroutine" +string dextn "external" + + call entdef (sbool, dbool, xpptbl) + call entdef (schar, dchar, xpptbl) + call entdef (sshort, dshort, xpptbl) + call entdef (sint, dint, xpptbl) + call entdef (slong, dlong, xpptbl) + call entdef (spntr, dpntr, xpptbl) + call entdef (sreal, dreal, xpptbl) + call entdef (sdble, ddble, xpptbl) + call entdef (scplx, dcplx, xpptbl) + call entdef (sfchr, dfchr, xpptbl) + call entdef (sfunc, dfunc, xpptbl) + call entdef (ssubr, dsubr, xpptbl) + call entdef (sextn, dextn, xpptbl) +end diff --git a/unix/boot/spp/rpp/rpprat/errchk.r b/unix/boot/spp/rpp/rpprat/errchk.r new file mode 100644 index 00000000..4b948936 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errchk.r @@ -0,0 +1,42 @@ +include defs + +# ERRCHK -- Code called to process an ERRCHK declaration. + +subroutine errchk + +character tok, last_tok, gnbtok, token(MAXTOK) +integer ntok +pointer mktabl +include COMMON_BLOCKS +string serrcom1 "logical xerflg, xerpad(84)" +string serrcom2 "common /xercom/ xerflg, xerpad" + + ntok = 0 + tok = 0 + + repeat { + last_tok = tok + tok = gnbtok (token, MAXTOK) + + switch (tok) { + case ALPHA: + if (errtbl == NULL) { + errtbl = mktabl(0) # make empty table + call outtab # declare err flag + call outstr (serrcom1) + call outdon + call outtab # declare err common + call outstr (serrcom2) + call outdon + } + call enter (token, 0, errtbl) # enter keyw in table + case COMMA: + # no action, but required by syntax + case NEWLINE: + if (last_tok != COMMA) + break + default: + call synerr ("Syntax error in ERRCHK declaration.") + } + } +end diff --git a/unix/boot/spp/rpp/rpprat/errgo.r b/unix/boot/spp/rpp/rpprat/errgo.r new file mode 100644 index 00000000..81aa582c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errgo.r @@ -0,0 +1,29 @@ +include defs + +# ERRGO -- Ouput error checking code. + +subroutine errgo + +include COMMON_BLOCKS +string serrchk "if (xerflg) " + + # In the processing of the last line, was an indentifier encountered + # for which error checking is required (named in errchk declaration)? + + if (ername == YES) { + call outtab + if (esp > 0) { # in iferr ... stmt? + # Omit goto if goto statement label number is zero. This + # happens in "iferr (...)" statements. + if (errstk(esp) > 0) { + call outstr (serrchk) + call ogotos (errstk(esp)+2, NO) # "goto lab" + } + } else { + call outstr (serrchk) + call ogotos (retlab, NO) + call outdon + } + ername = NO + } +end diff --git a/unix/boot/spp/rpp/rpprat/errorc.r b/unix/boot/spp/rpp/rpprat/errorc.r new file mode 100644 index 00000000..f0fa6a2f --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errorc.r @@ -0,0 +1,20 @@ + +include defs + +# ERRORC -- Process an error statement. "call error" already processed. + + +subroutine errorc (str) + +character str(1) +include COMMON_BLOCKS + + xfer = YES + call outstr (str) + call balpar # output "(errcod, errmsg)" + ername = NO # just to be safe + call outdon + call outtab + call ogotos (retlab, NO) # always return after error statement + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/evalr.r b/unix/boot/spp/rpp/rpprat/evalr.r new file mode 100644 index 00000000..3752bcd4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/evalr.r @@ -0,0 +1,56 @@ +#-h- evalr 1126 local 12/01/80 15:54:06 +# evalr - expand args i through j: evaluate builtin or push back defn + include defs + + subroutine evalr (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer argno, k, m, n, t, td, in_string, delim + external index + integer index, length + + string digits '0123456789' + + t = argstk (i) + td = evalst (t) + if (td == MACTYPE) + call domac (argstk, i, j) + else if (td == INCTYPE) + call doincr (argstk, i, j) + else if (td == SUBTYPE) + call dosub (argstk, i, j) + else if (td == IFTYPE) + call doif (argstk, i, j) + else if (td == ARITHTYPE) + call doarth (argstk, i, j) + else { + in_string = NO + for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) + if (evalst(k) == SQUOTE | evalst(k) == DQUOTE) { + if (in_string == NO) { + delim = evalst(k) + in_string = YES + } + else + in_string = NO + call putbak (evalst(k)) + } + # Don't expand $arg if in a string. + else if (evalst(k-1) != ARGFLAG | in_string == YES) + call putbak (evalst (k)) + else { + argno = index (digits, evalst (k)) - 1 + if (argno >= 0 & argno < j - i) { + n = i + argno + 1 + m = argstk (n) + call pbstr (evalst (m)) + } + k = k - 1 # skip over $ + } + if (k == t) # do last character + call putbak (evalst (k)) + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/finit.r b/unix/boot/spp/rpp/rpprat/finit.r new file mode 100644 index 00000000..8ca1ecf5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/finit.r @@ -0,0 +1,24 @@ +#-h- finit 432 local 12/01/80 15:54:07 +# finit - initialize for each input file + include defs + + subroutine finit + + include COMMON_BLOCKS + + outp = 0 # output character pointer + level = 1 # file control + linect (1) = 0 + sbp = 1 + fnamp = 2 + fnames (1) = EOS + bp = PBPOINT + buf (bp) = EOS # to force a read on next call to 'ngetch' + fordep = 0 # for stack + fcname (1) = EOS # current function name + swtop = 0 # switch stack + swlast = 1 + swvnum = 0 + swvlev = 0 + return + end diff --git a/unix/boot/spp/rpp/rpprat/forcod.r b/unix/boot/spp/rpp/rpprat/forcod.r new file mode 100644 index 00000000..9d389f5e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/forcod.r @@ -0,0 +1,101 @@ +#-h- forcod 2259 local 12/01/80 15:54:07 +# forcod - beginning of for statement + include defs + + subroutine forcod (lab) + integer lab + + include COMMON_BLOCKS + + character t, token (MAXTOK) + character gettok, gnbtok + + integer i, j, nlpar + integer length, labgen + + string ifnot "if (.not." + string serrchk ".and.(.not.xerflg))) " + + lab = labgen (3) + call outcon (0) + if (gnbtok (token, MAXTOK) != LPAREN) { + call synerr ("missing left paren.") + return + } + if (gnbtok (token, MAXTOK) != SEMICOL) { # real init clause + call pbstr (token) + call outtab + call eatup + call outdwe + } + if (gnbtok (token, MAXTOK) == SEMICOL) # empty condition + call outcon (lab) + else { # non-empty condition + call pbstr (token) + call outnum (lab) + call outtab + call outstr (ifnot) + call outch (LPAREN) + nlpar = 0 + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == SEMICOL) + break + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + return + } + if (t == ALPHA) + call squash (token) + if (t != NEWLINE & t != UNDERLINE) + call outstr (token) + } + + # name encountered for which error checking is required? + if (ername == YES) + call outstr (serrchk) + else { + call outch (RPAREN) + call outch (RPAREN) + call outch (BLANK) + } + call outgo (lab+2) # error checking below (errgo) + if (nlpar < 0) + call synerr ("invalid for clause.") + } + fordep = fordep + 1 # stack reinit clause + j = 1 + for (i = 1; i < fordep; i = i + 1) # find end + j = j + length (forstk (j)) + 1 + forstk (j) = EOS # null, in case no reinit + nlpar = 0 + t = gnbtok (token, MAXTOK) + call pbstr (token) + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + break + } + if (nlpar >= 0 & t != NEWLINE & t != UNDERLINE) { + if (t == ALPHA) + call squash (token) + if (j + length (token) >= MAXFORSTK) + call baderr ("for clause too long.") + call scopy (token, 1, forstk, j) + j = j + length (token) + } + } + lab = lab + 1 # label for next's + call indent (1) + call errgo + return + end diff --git a/unix/boot/spp/rpp/rpprat/fors.r b/unix/boot/spp/rpp/rpprat/fors.r new file mode 100644 index 00000000..5d3692ea --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/fors.r @@ -0,0 +1,29 @@ +#-h- fors 458 local 12/01/80 15:54:08 +# fors - process end of for statement + include defs + + subroutine fors (lab) + integer lab + + include COMMON_BLOCKS + + integer i, j + integer length + + xfer = NO + call outnum (lab) + j = 1 + for (i = 1; i < fordep; i = i + 1) + j = j + length (forstk (j)) + 1 + if (length (forstk (j)) > 0) { + call outtab + call outstr (forstk (j)) + call outdon + } + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + fordep = fordep - 1 + ername = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/fort b/unix/boot/spp/rpp/rpprat/fort new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/fort diff --git a/unix/boot/spp/rpp/rpprat/getdef.r b/unix/boot/spp/rpp/rpprat/getdef.r new file mode 100644 index 00000000..be97b439 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/getdef.r @@ -0,0 +1,62 @@ +#-h- getdef 1634 local 12/01/80 15:54:08 +# getdef (for no arguments) - get name and definition + include defs + + subroutine getdef (token, toksiz, defn, defsiz) + character token (MAXTOK), defn (MAXDEF) + integer toksiz, defsiz + + include COMMON_BLOCKS + + character c, t, ptoken (MAXTOK) + character gtok, ngetch + + integer i, nlpar + + call skpblk + c = gtok (ptoken, MAXTOK) + if (c == LPAREN) + t = LPAREN # define (name, defn) + else { + t = BLANK # define name defn + call pbstr (ptoken) + } + call skpblk + if (gtok (token, toksiz) != ALPHA) + call baderr ("non-alphanumeric name.") + call skpblk + c = gtok (ptoken, MAXTOK) + if (t == BLANK) { # define name defn + call pbstr (ptoken) + i = 1 + repeat { + c = ngetch (c) + if (i > defsiz) + call baderr ("definition too long.") + defn (i) = c + i = i + 1 + } until (c == SHARP | c == NEWLINE | c == EOF) + if (c == SHARP) + call putbak (c) + } + else if (t == LPAREN) { # define (name, defn) + if (c != COMMA) + call baderr ("missing comma in define.") + # else got (name, + nlpar = 0 + for (i = 1; nlpar >= 0; i = i + 1) + if (i > defsiz) + call baderr ("definition too long.") + else if (ngetch (defn (i)) == EOF) + call baderr ("missing right paren.") + else if (defn (i) == LPAREN) + nlpar = nlpar + 1 + else if (defn (i) == RPAREN) + nlpar = nlpar - 1 + # else normal character in defn (i) + } + else + call baderr ("getdef is confused.") + defn (i - 1) = EOS + return + end diff --git a/unix/boot/spp/rpp/rpprat/gettok.r b/unix/boot/spp/rpp/rpprat/gettok.r new file mode 100644 index 00000000..8ae855db --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gettok.r @@ -0,0 +1,90 @@ +#-h- gettok 2076 local 12/01/80 15:54:09 +# gettok - get token. handles file inclusion and line numbers + include defs + +character function gettok (token, toksiz) + +character token (MAXTOK) +integer toksiz +include COMMON_BLOCKS +integer equal +character t, deftok +#character name(MAXNAME), t +#integer i, len, open, length + +string ssubr "x$subr" +string sfunc "x$func" +#string incl "include" + +# for (; level > 0; level = level - 1) { + + gettok = deftok (token, toksiz) + if (gettok != EOF) { + if (gettok == XPP_DIRECTIVE) { + if (equal (token, sfunc) == YES) { + call skpblk + t = deftok (fcname, MAXNAME) + call pbstr (fcname) + if (t != ALPHA) + call synerr ("Missing function name.") + call putbak (BLANK) + swvnum = 0 + swvlev = 0 + return + } else if (equal (token, ssubr) == YES) { + swvnum = 0 + swvlev = 0 + return + } else + return + } + return + } + + token (1) = EOF + token (2) = EOS + gettok = EOF + return +end + + +# -- Includes are now processed elsewhere + +# else if (equal (token, incl) == NO) +# return +# +# # process 'include' statements: +# call skpblk +# t = deftok (name, MAXNAME) +# if (t == SQUOTE | t == DQUOTE) { +# len = length (name) - 1 +# for (i = 1; i < len; i = i + 1) +# name (i) = name (i + 1) +# name (i) = EOS +# } +# i = length (name) + 1 +# if (level >= NFILES) +# call synerr ("includes nested too deeply.") +# else { +# infile (level + 1) = open (name, READ) +# linect (level + 1) = 0 +# if (infile (level + 1) == ERR) +# call synerr ("can't open include.") +# else { +# level = level + 1 +# if (fnamp + i <= MAXFNAMES) { +# call scopy (name, 1, fnames, fnamp) +# fnamp = fnamp + i # push file name stack +# } +# } +# } +# } +# if (level > 1) { # close include file pop file name stack +# call close (infile (level)) +# for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) +# if (fnames (fnamp - 1) == EOS) +# break +# } + +# } + diff --git a/unix/boot/spp/rpp/rpprat/gnbtok.r b/unix/boot/spp/rpp/rpprat/gnbtok.r new file mode 100644 index 00000000..448a1aad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gnbtok.r @@ -0,0 +1,19 @@ +#-h- gnbtok 237 local 12/01/80 15:54:09 +# gnbtok - get nonblank token + include defs + + character function gnbtok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character gettok + + call skpblk + repeat { + gnbtok = gettok (token, toksiz) + } until (gnbtok != BLANK) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/gocode.r b/unix/boot/spp/rpp/rpprat/gocode.r new file mode 100644 index 00000000..26e201c4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gocode.r @@ -0,0 +1,25 @@ +include defs + +# GOCODE - generate code for goto statement + +subroutine gocode + +character token (MAXTOK), t +character gnbtok +integer ctoi, i +include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != DIGIT) + call synerr ("Invalid label for goto.") + else { + call outtab + i = 1 + call ogotos (ctoi(token,i), NO) + } + xfer = YES + + for (t=gnbtok(token,MAXTOK); t == NEWLINE; t=gnbtok(token,MAXTOK)) + ; + call pbstr (token) +end diff --git a/unix/boot/spp/rpp/rpprat/gtok.r b/unix/boot/spp/rpp/rpprat/gtok.r new file mode 100644 index 00000000..4cdb3d72 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gtok.r @@ -0,0 +1,161 @@ +include defs + +# gtok - get token for Ratfor + + character function gtok (lexstr, toksiz) + character lexstr (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character c + character ngetch + + integer i +# external index +# integer index + +# string digits "0123456789abcdefghijklmnopqrstuvwxyz" + + c = ngetch (lexstr (1)) + + if (c == BLANK | c == TAB) { + lexstr (1) = BLANK + while (c == BLANK | c == TAB) # compress many blanks to one + c = ngetch (c) + if (c == SHARP) + while (ngetch (c) != NEWLINE) # strip comments + ; + if (c != NEWLINE) + call putbak (c) + else + lexstr (1) = NEWLINE + lexstr (2) = EOS + gtok = lexstr (1) + return + } + + i = 1 + if (IS_LETTER(c)) { # alpha + gtok = ALPHA + if (c == LETX) { # "x$cccc" directive? + c = ngetch (lexstr(2)) + if (c == DOLLAR) { + gtok = XPP_DIRECTIVE + i = 2 + } + else + call putbak (c) + } + + for (; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr(i+1)) + if (!IS_LETTER(c) & !IS_DIGIT(c) & c != UNDERLINE) + break + } + call putbak (c) + + } else if (IS_DIGIT(c)) { # digits + for (i=1; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr (i + 1)) + if (!IS_DIGIT(c)) + break + } + call putbak (c) + gtok = DIGIT + } + +# The following is not needed since XPP does base conversion, and this caused +# fixed point overflow on a Data General machine. +# +# b = c - DIG0 # in case alternate base number +# for (i = 1; i < toksiz - 2; i = i + 1) { +# c = ngetch (lexstr (i + 1)) +# if (!IS_DIGIT(c)) +# break +# b = 10 * b + (c - DIG0) +# } +# if (c == RADIX & b >= 2 & b <= 36) { #n%ddd... +# n = 0 +# repeat { +# d = index (digits, clower (ngetch (c))) - 1 +# if (d < 0) +# break +# n = b * n + d +# } +# call putbak (c) +# i = itoc (n, lexstr, toksiz) +# } +# else +# call putbak (c) +# gtok = DIGIT +# } + + else if (c == LBRACK) { # allow [ for { + lexstr (1) = LBRACE + gtok = LBRACE + } + + else if (c == RBRACK) { # allow ] for } + lexstr (1) = RBRACE + gtok = RBRACE + } + + else if (c == DOLLAR) { # $( and $) now used by macro processor + if (ngetch (lexstr (2)) == LPAREN) { + i = 2 + gtok = LSTRIPC + } + else if (lexstr (2) == RPAREN) { + i = 2 + gtok = RSTRIPC + } + else { + call putbak (lexstr (2)) + gtok = DOLLAR + } + } + + else if (c == SQUOTE | c == DQUOTE) { + gtok = c + for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) { + if (lexstr (i) == UNDERLINE) + if (ngetch (c) == NEWLINE) { + while (c == NEWLINE | c == BLANK | c == TAB) + c = ngetch (c) + lexstr (i) = c + } + else + call putbak (c) + if (lexstr (i) == NEWLINE | i >= toksiz - 1) { + call synerr ("missing quote.") + lexstr (i) = lexstr (1) + call putbak (NEWLINE) + break + } + } + } + + else if (c == SHARP) { # strip comments + while (ngetch (lexstr (1)) != NEWLINE) + ; + gtok = NEWLINE + } + + else if (c == GREATER | c == LESS | c == NOT | c == BANG | + c == TILDE | c == CARET | c == EQUALS | c == AND | c == OR) { + call relate (lexstr, i) + gtok = c + } + + else + gtok = c + + if (i >= toksiz - 1) + call synerr ("token too long.") + lexstr (i + 1) = EOS + + # Note: line number accounting is now done in 'ngetch' + + return + end diff --git a/unix/boot/spp/rpp/rpprat/ifcode.r b/unix/boot/spp/rpp/rpprat/ifcode.r new file mode 100644 index 00000000..81855321 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifcode.r @@ -0,0 +1,17 @@ +#-h- ifcode 198 local 12/01/80 15:54:10 +# ifcode - generate initial code for if + include defs + + subroutine ifcode (lab) + integer lab + + include COMMON_BLOCKS + + integer labgen + + xfer = NO + lab = labgen (2) + call ifgo (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/iferrc.r b/unix/boot/spp/rpp/rpprat/iferrc.r new file mode 100644 index 00000000..4fd77154 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/iferrc.r @@ -0,0 +1,85 @@ +include defs + +# IFERRC - Generate initial code for an IFERR statement. Used to provide +# error recovery for a statement or compound statement. + +subroutine iferrc (lab, sense) + +integer lab, sense +integer labgen, nlpar +character t, gettok, gnbtok, token(MAXTOK) +include COMMON_BLOCKS +string errpsh "call xerpsh" +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + lab = labgen (3) + + call outtab # "call errpsh" + call outstr (errpsh) + call outdon + + switch (gnbtok (token, MAXTOK)) { # "iferr (" or "iferr {" + case LPAREN: + call outtab + case LBRACE: + call pbstr (token) + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = lab + return + default: + call synerr ("Missing left paren.") + return + } + + nlpar = 1 # process "iferr (.." + token(1) = EOS + + # Push handler on error stack temporarily so that "iferr (call error.." + # can be handled properly. + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = 0 + + repeat { # output the statement + call outstr (token) + t = gettok (token, MAXTOK) + if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) { + call pbstr (token) + break + } + if (t == NEWLINE) # delete newlines + token (1) = EOS + else if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + else if (t == SEMICOL) { + call outdon + call outtab + } else if (t == ALPHA) + call squash (token) + # else nothing special + } until (nlpar <= 0) + + esp = esp - 1 + ername = NO # ignore errchk + if (nlpar != 0) + call synerr ("Missing parenthesis in condition.") + else + call outdon + + call outtab # "if (errpop())" + if (sense == 1) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) # "... goto lab" + + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ifgo.r b/unix/boot/spp/rpp/rpprat/ifgo.r new file mode 100644 index 00000000..da0e6647 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifgo.r @@ -0,0 +1,23 @@ +include defs + +# IFGO - generate "if (.not.(...)) goto lab" + +subroutine ifgo (lab) + +integer lab +include COMMON_BLOCKS +string ifnot "if (.not." +string serrchk ".and.(.not.xerflg)) " + + call outtab # get to column 7 + call outstr (ifnot) # " if (.not. " + call balpar # collect and output condition + if (ername == YES) # add error checking? + call outstr (serrchk) + else { + call outch (RPAREN) # " ) " + call outch (BLANK) + } + call outgo (lab) # " goto lab " + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/ifparm.r b/unix/boot/spp/rpp/rpprat/ifparm.r new file mode 100644 index 00000000..b2b5f706 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifparm.r @@ -0,0 +1,31 @@ +#-h- ifparm 689 local 12/01/80 15:54:11 +# ifparm - determines if the defined symbol has arguments in its + include defs +# definition. This effects how the macro is expanded. + + integer function ifparm (strng) + character strng (ARB) + + character c + + external index + integer i, index, type + + c = strng (1) + if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | + c == MACTYPE) + ifparm = YES + else { + ifparm = NO + for (i = 1; index (strng (i), ARGFLAG) > 0; ) { + i = i + index (strng (i), ARGFLAG) # i points at char after ARGFLAG + if (type (strng (i)) == DIGIT) + andif (type (strng (i + 1)) != DIGIT) { + ifparm = YES + break + } + } + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/indent.r b/unix/boot/spp/rpp/rpprat/indent.r new file mode 100644 index 00000000..e119c773 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/indent.r @@ -0,0 +1,12 @@ +include defs + +# INDENT -- Indent the output listing. + +subroutine indent (nlevels) + +integer nlevels +include COMMON_BLOCKS + + logical_column = logical_column + (nlevels * INDENT) + col = max(6, min(MAX_INDENT, logical_column)) +end diff --git a/unix/boot/spp/rpp/rpprat/initkw.r b/unix/boot/spp/rpp/rpprat/initkw.r new file mode 100644 index 00000000..c03bf2f2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/initkw.r @@ -0,0 +1,34 @@ +#-h- initkw 549 local 12/01/80 15:54:11 +# initkw - initialize tables and important global variables + include defs + + subroutine initkw + + include COMMON_BLOCKS + + pointer mktabl + + call dsinit (MEMSIZE) + deftbl = mktabl (1) # symbol table for definitions + call entdkw + rkwtbl = mktabl (1) # symbol table for Ratfor key words + call entrkw + fkwtbl = mktabl (0) # symbol table for Fortran key words + call entfkw + namtbl = mktabl (1) # symbol table for long identifiers + xpptbl = mktabl (1) # symbol table for xpp directives + call entxkw + gentbl = mktabl (0) # symbol table for generated identifiers + errtbl = NULL # table of names to be error checked + + label = FIRST_LABEL # starting statement label + smem(1) = EOS # haven't read in "mem.com" file yet + body = NO # not in procedure body to start + dbgout = NO # disable debug output by default + dbglev = 0 # file level if debug enabled + memflg = NO # haven't declared mem common yet + swinrg = NO # default range checking for switches + col = 6 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/labelc.r b/unix/boot/spp/rpp/rpprat/labelc.r new file mode 100644 index 00000000..86421d9b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labelc.r @@ -0,0 +1,19 @@ +#-h- labelc 404 local 12/01/80 15:54:12 +# labelc - output statement number + include defs + + subroutine labelc (lexstr) + character lexstr (ARB) + + include COMMON_BLOCKS + + integer length, l + + xfer = NO # can't suppress goto's now + l = length (lexstr) + if (l >= 3 & l < 4) # possible conflict with pp-generated labels + call synerr ("Warning: statement labels 100 and above are reserved.") + call outstr (lexstr) + call outtab + return + end diff --git a/unix/boot/spp/rpp/rpprat/labgen.r b/unix/boot/spp/rpp/rpprat/labgen.r new file mode 100644 index 00000000..f110e963 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labgen.r @@ -0,0 +1,13 @@ +#-h- labgen 189 local 12/01/80 15:54:12 +# labgen - generate n consecutive labels, return first one + include defs + + integer function labgen (n) + integer n + + include COMMON_BLOCKS + + labgen = label + label = label + (n / 10 + 1) * 10 + return + end diff --git a/unix/boot/spp/rpp/rpprat/lex.r b/unix/boot/spp/rpp/rpprat/lex.r new file mode 100644 index 00000000..bc8f7a27 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lex.r @@ -0,0 +1,49 @@ +#-h- lex 543 local 12/01/80 15:54:12 +# lex - return lexical type of token + include defs + + integer function lex (lexstr) + character lexstr (MAXTOK) + + include COMMON_BLOCKS + + character gnbtok, t, c + + integer lookup, n + string sdefault "default" + + for (lex = gnbtok (lexstr, MAXTOK); lex == NEWLINE; + lex = gnbtok (lexstr, MAXTOK)) + ; + + if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE) + return + if (lex == DIGIT) + lex = LEXDIGITS + else if (lex == TOGGLE) + lex = LEXLITERAL + else if (lex == XPP_DIRECTIVE) + lex = LEXDECL + else if (lookup (lexstr, lex, rkwtbl) == YES) { + if (lex == LEXDEFAULT) { # "default:" + n = -1 + repeat { + c = ngetch (c) + n = n + 1 + } until (c != BLANK & c != TAB) + call putbak (c) + + t = gnbtok (lexstr, MAXTOK) + call pbstr (lexstr) + if (n > 0) + call putbak (BLANK) + call scopy (sdefault, 1, lexstr, 1) + if (t != COLON) + lex = LEXOTHER + } + } + else + lex = LEXOTHER + + return + end diff --git a/unix/boot/spp/rpp/rpprat/litral.r b/unix/boot/spp/rpp/rpprat/litral.r new file mode 100644 index 00000000..e9106559 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/litral.r @@ -0,0 +1,20 @@ +#-h- litral 316 local 12/01/80 15:54:13 +# litral - process literal Fortran line + include defs + + subroutine litral + + include COMMON_BLOCKS + + character ngetch + + # Finish off any left-over characters + if (outp > 0) + call outdwe + + for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1) + ; + outp = outp - 1 + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/lndict.r b/unix/boot/spp/rpp/rpprat/lndict.r new file mode 100644 index 00000000..42cf8d6a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lndict.r @@ -0,0 +1,30 @@ +#-h- lndict 678 local 12/01/80 15:54:13 +# lndict - output long-name dictionary as a debugging aid + include defs + +subroutine lndict + +character sym (MAXTOK), c +ifdef (UPPERC, character cupper) +integer sctabl, length +pointer posn, locn +include COMMON_BLOCKS + + posn = 0 + while (sctabl (namtbl, sym, locn, posn) != EOF) + if (length(sym) > MAXIDLENGTH) { + ifdef (UPPERC, call outch (BIGC)) + ifnotdef (UPPERC, call outch (LETC)) + call outtab + for (; mem (locn) != EOS; locn = locn + 1) { + c = mem (locn) # kluge for people with LOGICAL*1 characters + ifdef (UPPERC, c = cupper (c)) + call outch (c) + } + call outch (BLANK) + call outch (BLANK) + call outstr (sym) + call outdon + } + return +end diff --git a/unix/boot/spp/rpp/rpprat/ludef.r b/unix/boot/spp/rpp/rpprat/ludef.r new file mode 100644 index 00000000..45876968 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ludef.r @@ -0,0 +1,29 @@ +#-h- ludef 495 local 12/01/80 15:54:29 +# ludef --- look up a defined identifier, return its definition + include defs + + integer function ludef (id, defn, table) + character id (ARB), defn (ARB) + pointer table + + include COMMON_BLOCKS + + integer i + integer lookup + + pointer locn + + ludef = lookup (id, locn, table) + if (ludef == YES) { + i = 1 + for (; mem (locn) != EOS; locn = locn + 1) { + defn (i) = mem (locn) + i = i + 1 + } + defn (i) = EOS + } + else + defn (1) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/mapid.r b/unix/boot/spp/rpp/rpprat/mapid.r new file mode 100644 index 00000000..106a9335 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/mapid.r @@ -0,0 +1,19 @@ + +include defs + +# MAPID -- Map a long identifier. The new identifier is formed by +# concatenating the first MAXIDLENGTH-1 characters and the last character. + + +subroutine mapid (name) + +character name(MAXTOK) +integer i + + for (i=1; name(i) != EOS; i=i+1) + ; + if (i-1 > MAXIDLENGTH) { + name(MAXIDLENGTH) = name(i-1) + name(MAXIDLENGTH+1) = EOS + } +end diff --git a/unix/boot/spp/rpp/rpprat/ngetch.r b/unix/boot/spp/rpp/rpprat/ngetch.r new file mode 100644 index 00000000..26dce4de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ngetch.r @@ -0,0 +1,34 @@ +#-h- ngetch 442 local 12/01/80 15:54:30 +# ngetch - get a (possibly pushed back) character + include defs + + character function ngetch (c) + character c + + include COMMON_BLOCKS + + integer getlin, n, i + + if (buf (bp) == EOS) + if (getlin (buf (PBPOINT), infile (level)) == EOF) + c = EOF + else { + c = buf (PBPOINT) + bp = PBPOINT + 1 + if (c == SHARP) { #check for "#!# nn" directive + if (buf(bp) == BANG & buf(bp+1) == SHARP) { + n = 0 + for (i=bp+3; buf(i) >= DIG0 & buf(i) <= DIG9; i=i+1) + n = n * 10 + buf(i) - DIG0 + linect (level) = n - 1 + } + } + linect (level) = linect (level) + 1 + } + else { + c = buf (bp) + bp = bp + 1 + } + + return (c) + end diff --git a/unix/boot/spp/rpp/rpprat/ogotos.r b/unix/boot/spp/rpp/rpprat/ogotos.r new file mode 100644 index 00000000..e20e7df0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ogotos.r @@ -0,0 +1,20 @@ + +include defs + +# OGOTOS - Output "goto n", unconditionally. + + +subroutine ogotos (n, error_check) + +integer n, error_check +include COMMON_BLOCKS +string sgoto "goto " + + call outtab + call outstr (sgoto) + call outnum (n) + if (error_check == YES) + call outdwe + else + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/otherc.r b/unix/boot/spp/rpp/rpprat/otherc.r new file mode 100644 index 00000000..9a8451b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/otherc.r @@ -0,0 +1,18 @@ +#-h- otherc 284 local 12/01/80 15:54:30 +# otherc - output ordinary Fortran statement + include defs + + subroutine otherc (lexstr) + character lexstr(ARB) + + include COMMON_BLOCKS + + xfer = NO + call outtab + if (IS_LETTER(lexstr (1))) + call squash (lexstr) + call outstr (lexstr) + call eatup + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/outch.r b/unix/boot/spp/rpp/rpprat/outch.r new file mode 100644 index 00000000..f7dfa99e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outch.r @@ -0,0 +1,51 @@ +include defs + +# outch - put one character into output buffer + +subroutine outch (c) + +character c, splbuf(SZ_SPOOLBUF+1) +integer i, ip, op, index +include COMMON_BLOCKS +external index +string break_chars " ),.+-*/(" + + # Process a continuation card. Try to break the card at a whitespace + # division, operator, or punctuation mark. + + if (outp >= 72) { + if (index (break_chars, c) > 0) # find break point + ip = outp + else { + for (ip=outp; ip >= 1; ip=ip-1) { + if (index (break_chars, outbuf(ip)) > 0) + break + } + } + + if (ip != outp & (outp-ip) < SZ_SPOOLBUF) { + op = 1 + for (i=ip+1; i <= outp; i=i+1) { # save chars + splbuf(op) = outbuf(i) + op = op + 1 + } + splbuf(op) = EOS + outp = ip + } else + splbuf(1) = EOS + + call outdon + + for (op=1; op < col; op=op+1) + outbuf(op) = BLANK + outbuf(6) = STAR + outp = col + for (ip=1; splbuf(ip) != EOS; ip=ip+1) { + outp = outp + 1 + outbuf(outp) = splbuf(ip) + } + } + + outp = outp + 1 # output character + outbuf(outp) = c +end diff --git a/unix/boot/spp/rpp/rpprat/outcon.r b/unix/boot/spp/rpp/rpprat/outcon.r new file mode 100644 index 00000000..90d5e636 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outcon.r @@ -0,0 +1,21 @@ +#-h- outcon 332 local 12/01/80 15:54:31 +# outcon - output "n continue" + include defs + + subroutine outcon (n) + integer n + + include COMMON_BLOCKS + + string contin "continue" + + xfer = NO + if (n <= 0 & outp == 0) + return # don't need unlabeled continues + if (n > 0) + call outnum (n) + call outtab + call outstr (contin) + call outdon + return + end diff --git a/unix/boot/spp/rpp/rpprat/outdon.r b/unix/boot/spp/rpp/rpprat/outdon.r new file mode 100644 index 00000000..5ea969bb --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdon.r @@ -0,0 +1,58 @@ +#-h- outdon 257 local 12/01/80 15:54:31 +# outdon - finish off an output line + include defs + + subroutine outdon + + include COMMON_BLOCKS + + integer allblk + integer itoc, ip, op, i + character obuf(80) + string s_line "#line " + + # If dbgout is enabled output the "#line" statement. + if (dbgout == YES) { + if (body == YES | dbglev != level) { + op = 1 + for (ip=1; s_line(ip) != EOS; ip=ip+1) { + obuf(op) = s_line(ip) + op = op + 1 + } + + op = op + itoc (linect, obuf(op), 80-op+1) + obuf(op) = BLANK + op = op + 1 + obuf(op) = DQUOTE + op = op + 1 + + for (i=fnamp-1; i >= 1; i=i-1) + if (fnames(i-1) == EOS | i == 1) { # print file name + for (ip=i; fnames(ip) != EOS; ip=ip+1) { + obuf(op) = fnames(ip) + op = op + 1 + } + break + } + + obuf(op) = DQUOTE + op = op + 1 + obuf(op) = NEWLINE + op = op + 1 + obuf(op) = EOS + op = op + 1 + + call putlin (obuf, STDOUT) + dbglev = level + } + } + + # Output the program statement. + outbuf (outp + 1) = NEWLINE + outbuf (outp + 2) = EOS + if (allblk (outbuf) == NO) + call putlin (outbuf, STDOUT) + outp = 0 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/outdwe.r b/unix/boot/spp/rpp/rpprat/outdwe.r new file mode 100644 index 00000000..d6ef22ce --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdwe.r @@ -0,0 +1,13 @@ + +include defs + +# OUTDWE -- (outdon with error checking). +# Called by code generation routines to output a line of code, +# possibly followed by an error checking instruction. + + +subroutine outdwe + + call outdon + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/outgo.r b/unix/boot/spp/rpp/rpprat/outgo.r new file mode 100644 index 00000000..d4f54faa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outgo.r @@ -0,0 +1,13 @@ +#-h- outgo 239 local 12/01/80 15:54:31 +# outgo - output "goto n" + include defs + +subroutine outgo (n) + +integer n +include COMMON_BLOCKS + + if (xfer == YES) + return + call ogotos (n, NO) +end diff --git a/unix/boot/spp/rpp/rpprat/outnum.r b/unix/boot/spp/rpp/rpprat/outnum.r new file mode 100644 index 00000000..5286971e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outnum.r @@ -0,0 +1,24 @@ +#-h- outnum 381 local 12/01/80 15:54:32 +# outnum - output decimal number + include defs + + subroutine outnum (n) + integer n + + character chars (MAXCHARS) + + integer i, m + + m = iabs (n) + i = 0 + repeat { + i = i + 1 + chars (i) = mod (m, 10) + DIG0 + m = m / 10 + } until (m == 0 | i >= MAXCHARS) + if (n < 0) + call outch (MINUS) + for ( ; i > 0; i = i - 1) + call outch (chars (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/outstr.r b/unix/boot/spp/rpp/rpprat/outstr.r new file mode 100644 index 00000000..248bb39c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outstr.r @@ -0,0 +1,33 @@ +#-h- outstr 687 local 12/01/80 15:54:32 +# outstr - output string; handles quoted literals + include defs + + subroutine outstr (str) + character str (ARB) + + character c + ifdef (UPPERC, character cupper) + + integer i, j + + for (i = 1; str (i) != EOS; i = i + 1) { + c = str (i) + if (c != SQUOTE & c != DQUOTE) { + # produce upper case fortran, if desired + ifdef (UPPERC, + c = cupper (c) + ) + call outch (c) + } + else { + i = i + 1 + for (j = i; str (j) != c; j = j + 1) # find end + ; + call outnum (j - i) + call outch (BIGH) + for ( ; i < j; i = i + 1) + call outch (str (i)) + } + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/outtab.r b/unix/boot/spp/rpp/rpprat/outtab.r new file mode 100644 index 00000000..94f38c69 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outtab.r @@ -0,0 +1,12 @@ +#-h- outtab 140 local 12/01/80 15:54:32 +# outtab - get past column 6 + include defs + + subroutine outtab + + include COMMON_BLOCKS + + while (outp < col) + call outch (BLANK) + return + end diff --git a/unix/boot/spp/rpp/rpprat/parse.r b/unix/boot/spp/rpp/rpprat/parse.r new file mode 100644 index 00000000..676ee759 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/parse.r @@ -0,0 +1,144 @@ +include defs + +# PARSE - parse Ratfor source program + +subroutine parse + +include COMMON_BLOCKS +character lexstr(MAXTOK) +integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i, t +integer lex +logical push_stack + + sp = 1 + lextyp(1) = EOF + + for (token = lex(lexstr); token != EOF; token = lex(lexstr)) { + push_stack = .false. + + switch (token) { + case LEXIF: + call ifcode (lab) + push_stack = .true. + case LEXIFERR: + call iferrc (lab, 1) + push_stack = .true. + case LEXIFNOERR: + call iferrc (lab, 0) + push_stack = .true. + case LEXDO: + call docode (lab) + push_stack = .true. + case LEXWHILE: + call whilec (lab) + push_stack = .true. + case LEXFOR: + call forcod (lab) + push_stack = .true. + case LEXREPEAT: + call repcod (lab) + push_stack = .true. + case LEXSWITCH: + call swcode (lab) + push_stack = .true. + case LEXCASE, LEXDEFAULT: + for (i=sp; i > 0; i=i-1) # find for most recent switch + if (lextyp(i) == LEXSWITCH) + break + if (i == 0) + call synerr ("illegal case or default.") + else + call cascod (labval (i), token) + case LEXDIGITS: + call labelc (lexstr) + push_stack = .true. + case LEXELSE: + t = lextyp(sp) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) + call elseif (labval(sp)) + else + call synerr ("Illegal else.") + + t = lex (lexstr) # check for "else if" + call pbstr (lexstr) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) { + call indent (-1) # cancel out indent +1 + token = LEXIFELSE # prevent -indent at end + } + push_stack = .true. + case LEXTHEN: + if (lextyp(sp) == LEXIFERR | lextyp(sp) == LEXIFNOERR) { + call thenco (lextyp(sp), labval(sp)) + lab = labval(sp) + token = lextyp(sp) + sp = sp - 1 # cancel out subsequent push + } else + call synerr ("Illegal 'then' clause in iferr statement.") + push_stack = .true. + case LEXLITERAL: + call litral + case LEXERRCHK: + call errchk + case LEXBEGIN: + call beginc + case LEXEND: + call endcod (lexstr) + if (sp != 1) { + call synerr ("Missing right brace or 'begin'.") + sp = 1 + } + default: + if (token == LBRACE) + push_stack = .true. + else if (token == LEXDECL) + call declco (lexstr) + } + + if (push_stack) { + if (body == NO) { + call synerr ("Missing 'begin' keyword.") + call beginc + } + sp = sp + 1 # beginning of statement + if (sp > MAXSTACK) + call baderr ("Stack overflow in parser.") + lextyp(sp) = token # stack type and value + labval(sp) = lab + + } else if (token != LEXCASE & token != LEXDEFAULT) { + if (token == RBRACE) + token = LEXRBRACE + + switch (token) { + case LEXOTHER: + call otherc (lexstr) + case LEXBREAK, LEXNEXT: + call brknxt (sp, lextyp, labval, token) + case LEXRETURN: + call retcod + case LEXGOTO: + call gocode + case LEXSTRING: + if (body == NO) + call strdcl + else + call otherc (lexstr) + case LEXRBRACE: + if (lextyp(sp) == LBRACE) + sp = sp - 1 + else if (lextyp(sp) == LEXSWITCH) { + call swend (labval(sp)) + sp = sp - 1 + } else + call synerr ("Illegal right brace.") + } + + token = lex (lexstr) # peek at next token + call pbstr (lexstr) + call unstak (sp, lextyp, labval, token) + } + } + + if (sp != 1) + call synerr ("unexpected EOF.") +end diff --git a/unix/boot/spp/rpp/rpprat/pbnum.r b/unix/boot/spp/rpp/rpprat/pbnum.r new file mode 100644 index 00000000..e77b5db6 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbnum.r @@ -0,0 +1,20 @@ +#-h- pbnum 304 local 12/01/80 15:54:33 +# pbnum - convert number to string, push back on input + include defs + + subroutine pbnum (n) + integer n + + integer m, num + integer mod + + string digits '0123456789' + + num = n + repeat { + m = mod (num, 10) + call putbak (digits (m + 1)) + num = num / 10 + } until (num == 0) + return + end diff --git a/unix/boot/spp/rpp/rpprat/pbstr.r b/unix/boot/spp/rpp/rpprat/pbstr.r new file mode 100644 index 00000000..9c2234de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbstr.r @@ -0,0 +1,69 @@ +include defs + +# PBSTR -- Push string back onto input. + +subroutine pbstr (s) + +character s(ARB) # string to be pushed back. +integer lenstr, i +integer length + +#begin + lenstr = length (s) + + # We are called to push back tokens returned by GTOK, which converts + # the ratfor relational operators >, >=, &, etc. into their Fortran + # equivalents .gt., .ge., .and., and so on. This conversion must be + # reversed in the push back to prevent macro expansion from operating + # on the strings "gt", "ge, "and", etc. This is a stupid way to + # handle this but this ratfor code (which was free) is a hopeless mess + # already anyhow. + + if (s(1) == PERIOD & s(lenstr) == PERIOD) + if (lenstr == 4) { + if (s(2) == LETG) { + if (s(3) == LETT) { # .gt. + call putbak (GREATER) + return + } else if (s(3) == LETE) { # .ge. + # Note chars are pushed back in + # reverse order. + call putbak (EQUALS) + call putbak (GREATER) + return + } + } else if (s(2) == LETL) { + if (s(3) == LETT) { # .lt. + call putbak (LESS) + return + } else if (s(3) == LETE) { # .le. + call putbak (EQUALS) + call putbak (LESS) + return + } + } else if (s(2) == LETE & s(3) == LETQ) { + call putbak (EQUALS) # .eq. + call putbak (EQUALS) + return + } else if (s(2) == LETN & s(3) == LETE) { + call putbak (EQUALS) # .ne. + call putbak (BANG) + return + } else if (s(2) == LETO & s(3) == LETR) { + call putbak (OR) # .or. + return + } + } else if (lenstr == 5) { + if (s(2) == LETN & s(3) == LETO & s(4) == LETT) { + call putbak (BANG) # .not. + return + } else if (s(2) == LETA & s(3) == LETN & s(4) == LETD) { + call putbak (AND) # .and. + return + } + } + + # Push back an arbitrary string. + for (i=lenstr; i > 0; i=i-1) + call putbak (s(i)) +end diff --git a/unix/boot/spp/rpp/rpprat/poicod.r b/unix/boot/spp/rpp/rpprat/poicod.r new file mode 100644 index 00000000..7b31bf80 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/poicod.r @@ -0,0 +1,56 @@ +include defs + +# POICOD -- Called to process a declaration of type "pointer". + +subroutine poicod (declare_variable) + +integer declare_variable +include COMMON_BLOCKS +string spointer XPOINTER + +# Fortran declarations for the MEM common. +string p1 "logical Memb(1)" +string p2 "integer*2 Memc(1)" +string p3 "integer*2 Mems(1)" +string p4 "integer Memi(1)" +string p5 "integer Meml(1)" +string p6 "real Memr(1)" +string p7 "double precision Memd(1)" +string p8 "complex Memx(1)" +string p9 "equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)" +string pa "common /Mem/ Memd" + + # Output declarations only once per procedure declarations section. + # The flag memflg is cleared when processing of a procedure begins. + + if (memflg == NO) { + call poidec (p1) + call poidec (p2) + call poidec (p3) + call poidec (p4) + call poidec (p5) + call poidec (p6) + call poidec (p7) + call poidec (p8) + call poidec (p9) + call poidec (pa) + memflg = YES + } + + if (declare_variable == YES) { + call outtab + call outstr (spointer) + } +end + + +# POIDEC -- Output a poicod declaration statement. + +subroutine poidec (str) + +character str + + call outtab + call outstr (str) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/push.r b/unix/boot/spp/rpp/rpprat/push.r new file mode 100644 index 00000000..7d0c3374 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/push.r @@ -0,0 +1,13 @@ +#-h- push 249 local 12/01/80 15:54:34 +# push - push ep onto argstk, return new pointer ap + include defs + + integer function push (ep, argstk, ap) + integer ap, argstk (ARGSIZE), ep + + if (ap > ARGSIZE) + call baderr ('arg stack overflow.') + argstk (ap) = ep + push = ap + 1 + return + end diff --git a/unix/boot/spp/rpp/rpprat/putbak.r b/unix/boot/spp/rpp/rpprat/putbak.r new file mode 100644 index 00000000..b88a3f11 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putbak.r @@ -0,0 +1,18 @@ +#-h- putbak 254 local 12/01/80 15:54:34 +# putbak - push character back onto input + include defs + + subroutine putbak (c) + character c + + include COMMON_BLOCKS + + if (bp <= 1) + call baderr ("too many characters pushed back.") + else { + bp = bp - 1 + buf (bp) = c + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/putchr.r b/unix/boot/spp/rpp/rpprat/putchr.r new file mode 100644 index 00000000..b39eeadf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putchr.r @@ -0,0 +1,15 @@ +#-h- putchr 233 local 12/01/80 15:54:34 +# putchr - put single char into eval stack + include defs + + subroutine putchr (c) + character c + + include COMMON_BLOCKS + + if (ep > EVALSIZE) + call baderr ('evaluation stack overflow.') + evalst (ep) = c + ep = ep + 1 + return + end diff --git a/unix/boot/spp/rpp/rpprat/puttok.r b/unix/boot/spp/rpp/rpprat/puttok.r new file mode 100644 index 00000000..2cdcf6d2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/puttok.r @@ -0,0 +1,13 @@ +#-h- puttok 198 local 12/01/80 15:54:34 +# puttok-put token into eval stack + include defs + + subroutine puttok (str) + character str (MAXTOK) + + integer i + + for (i = 1; str (i) != EOS; i = i + 1) + call putchr (str (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/ratfor.r b/unix/boot/spp/rpp/rpprat/ratfor.r new file mode 100644 index 00000000..f2f847fd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ratfor.r @@ -0,0 +1,70 @@ +#-h- ratfor 4496 local 12/01/80 15:53:43 +# Ratfor preprocessor + include defs + + subroutine ratfor + +# DRIVER(ratfor) Not used; RPP has a C main. + + include COMMON_BLOCKS + + integer i, n + integer getarg, open + + character arg (FILENAMESIZE) + + STDEFNS # define standard definitions file + + call initkw # initialize variables + + # Read file containing standard definitions + # If this isn't desired, define (STDEFNS,"") + + if (defns (1) != EOS) { + infile (1) = open (defns, READ) + if (infile (1) == ERR) + call remark ("can't open standard definitions file.") + else { + call finit + call parse + call close (infile (1)) + } + } + + n = 1 + for (i=1; getarg(i,arg,FILENAMESIZE) != EOF; i=i+1) { + n = n + 1 + call query ("usage: ratfor [-g] [files] >outfile.") + if (arg(1) == MINUS & arg(2) == LETG & arg(3) == EOS) { + dbgout = YES + next + } else if (arg(1) == MINUS & arg(2) == EOS) { + infile(1) = STDIN + call finit + } else { + infile(1) = open (arg, READ) + if (infile(1) == ERR) { + call cant (arg) + } else { #save file name for error messages + call finit + call scopy (arg, 1, fnames, 1) + for (fnamp=1; fnames(fnamp) != EOS; fnamp=fnamp+1) + if (fnames(fnamp) == PERIOD & fnames(fnamp+1) == LETR) + fnames(fnamp+1) = LETX + } + } + call parse + if (infile (1) != STDIN) + call close (infile (1)) + } + + if (n == 1) { # no files given on command line, use STDIN + infile (1) = STDIN + call finit + call parse + } + + call lndict + +# DRETURN + end diff --git a/unix/boot/spp/rpp/rpprat/relate.r b/unix/boot/spp/rpp/rpprat/relate.r new file mode 100644 index 00000000..50a04025 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/relate.r @@ -0,0 +1,59 @@ +#-h- relate 1276 local 12/01/80 15:54:35 +# relate - convert relational shorthands into long form + include defs + + subroutine relate (token, last) + character token (ARB) + integer last + + character ngetch + + integer length + + if (ngetch (token (2)) != EQUALS) { + call putbak (token (2)) + token (3) = LETT + } + else + token (3) = LETE + token (4) = PERIOD + token (5) = EOS + token (6) = EOS # for .not. and .and. + if (token (1) == GREATER) + token (2) = LETG + else if (token (1) == LESS) + token (2) = LETL + else if (token (1) == NOT | token (1) == BANG | + token (1) == CARET | token (1) == TILDE) { + if (token (2) != EQUALS) { + token (3) = LETO + token (4) = LETT + token (5) = PERIOD + } + token (2) = LETN + } + else if (token (1) == EQUALS) { + if (token (2) != EQUALS) { + token (2) = EOS + last = 1 + return + } + token (2) = LETE + token (3) = LETQ + } + else if (token (1) == AND) { + token (2) = LETA + token (3) = LETN + token (4) = LETD + token (5) = PERIOD + } + else if (token (1) == OR) { + token (2) = LETO + token (3) = LETR + } + else # can't happen + token (2) = EOS + token (1) = PERIOD + last = length (token) + return + end diff --git a/unix/boot/spp/rpp/rpprat/repcod.r b/unix/boot/spp/rpp/rpprat/repcod.r new file mode 100644 index 00000000..e2fd40aa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/repcod.r @@ -0,0 +1,16 @@ +#-h- repcod 262 local 12/01/80 15:54:35 +# repcod - generate code for beginning of repeat + include defs + + subroutine repcod (lab) + integer lab + + integer labgen + + call outcon (0) # in case there was a label + lab = labgen (3) + call outcon (lab) + lab = lab + 1 # label to go on next's + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/retcod.r b/unix/boot/spp/rpp/rpprat/retcod.r new file mode 100644 index 00000000..3490016d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/retcod.r @@ -0,0 +1,30 @@ +#-h- retcod 580 local 12/01/80 15:54:35 +# retcod - generate code for return + include defs + + subroutine retcod + + character token (MAXTOK), t + character gnbtok + include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != NEWLINE & t != SEMICOL & t != RBRACE) { + call pbstr (token) + call outtab + call scopy (fcname, 1, token, 1) + call squash (token) + call outstr (token) + call outch (BLANK) + call outch (EQUALS) + call outch (BLANK) + call eatup + call outdon + } + else if (t == RBRACE) + call pbstr (token) + call outtab + call ogotos (retlab, NO) + xfer = YES + return + end diff --git a/unix/boot/spp/rpp/rpprat/sdupl.r b/unix/boot/spp/rpp/rpprat/sdupl.r new file mode 100644 index 00000000..968bfebd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/sdupl.r @@ -0,0 +1,25 @@ +#-h- sdupl 374 local 12/01/80 15:55:03 +# sdupl --- duplicate a string in dynamic storage space + include defs + + pointer function sdupl (str) + character str (ARB) + + DS_DECL(mem, MEMSIZE) + + integer i + integer length + + pointer j + pointer dsget + + j = dsget (length (str) + 1) + sdupl = j + for (i = 1; str (i) != EOS; i = i + 1) { + mem (j) = str (i) + j = j + 1 + } + mem (j) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/skpblk.r b/unix/boot/spp/rpp/rpprat/skpblk.r new file mode 100644 index 00000000..3badc3e9 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/skpblk.r @@ -0,0 +1,17 @@ +#-h- skpblk 247 local 12/01/80 15:55:04 +# skpblk - skip blanks and tabs in current input file + include defs + + subroutine skpblk + + include COMMON_BLOCKS + + character c + character ngetch + + for (c = ngetch (c); c == BLANK | c == TAB; c = ngetch (c)) + ; + + call putbak (c) + return + end diff --git a/unix/boot/spp/rpp/rpprat/squash.r b/unix/boot/spp/rpp/rpprat/squash.r new file mode 100644 index 00000000..9990fe1a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/squash.r @@ -0,0 +1,53 @@ +include defs + +# SQUASH - convert a long or special identifier into a Fortran variable + +subroutine squash (id) + +character id(MAXTOK) +integer junk, i, j +integer lookup, ludef +character newid(MAXTOK), recdid(MAXTOK) +include COMMON_BLOCKS + + # identify names for which error checking is to be performed + if (body == YES & errtbl != NULL & ername == NO) + if (lookup (id, junk, errtbl) == YES) + ername = YES + + j = 1 + for (i=1; id(i) != EOS; i=i+1) # copy, delete '_' + if (IS_LETTER(id(i)) | IS_DIGIT(id(i))) { + newid(j) = id(i) + j = j + 1 + } + newid(j) = EOS + + # done if ordinary (short) Fortran variable + if (i-1 < MAXIDLENGTH & i == j) + return + +# Otherwise, the identifier (1) is longer than Fortran allows, +# (2) contains special characters (_ or .), or (3) is the maximum +# length permitted by the Fortran compiler. The first two cases +# obviously call for name conversion; the last case may require conversion +# to avoid accidental conflicts with automatically generated names. + + if (lookup (id, junk, fkwtbl) == YES) # Fortran key word? + return # (must be treated as reserved) + + if (ludef (id, recdid, namtbl) == YES) { # have we seen this before? + call scopy (recdid, 1, id, 1) + return + } + + call mapid (newid) # try standard mapping + if (lookup (newid, junk, gentbl) == YES) { + call synerr ("Warning: identifier mapping not unique.") + call uniqid (newid) + } + call entdef (newid, id, gentbl) + + call entdef (id, newid, namtbl) # record it for posterity + call scopy (newid, 1, id, 1) # substitute it for the old one +end diff --git a/unix/boot/spp/rpp/rpprat/strdcl.r b/unix/boot/spp/rpp/rpprat/strdcl.r new file mode 100644 index 00000000..03b04afc --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/strdcl.r @@ -0,0 +1,96 @@ +#-h- strdcl 2575 local 12/01/80 15:55:05 +# strdcl - generate code for string declaration + include defs + + subroutine strdcl + + include COMMON_BLOCKS + + character t, token (MAXTOK), dchar (MAXTOK) + character gnbtok + + integer i, j, k, n, len + integer length, ctoi, lex + + string char "integer*2/" + string dat "data " + string eoss "0/" + + t = gnbtok (token, MAXTOK) + if (t != ALPHA) + call synerr ("missing string token.") + call squash (token) + call outtab + call pbstr (char) # use defined meaning of "character" + repeat { + t = gnbtok (dchar, MAXTOK) + if (t == SLASH) + break + call outstr (dchar) + } + call outch (BLANK) # separator in declaration + call outstr (token) + call addstr (token, sbuf, sbp, SBUFSIZE) # save for later + call addchr (EOS, sbuf, sbp, SBUFSIZE) + if (gnbtok (token, MAXTOK) != LPAREN) { # make size same as initial value + len = length (token) + 1 + if (token (1) == SQUOTE | token (1) == DQUOTE) + len = len - 2 + } + else { # form is string name (size) init + t = gnbtok (token, MAXTOK) + i = 1 + len = ctoi (token, i) + if (token (i) != EOS) + call synerr ("invalid string size.") + if (gnbtok (token, MAXTOK) != RPAREN) + call synerr ("missing right paren.") + else + t = gnbtok (token, MAXTOK) + } + call outch (LPAREN) + call outnum (len) + call outch (RPAREN) + call outdon + if (token (1) == SQUOTE | token (1) == DQUOTE) { + len = length (token) + token (len) = EOS + call addstr (token (2), sbuf, sbp, SBUFSIZE) + } + else + call addstr (token, sbuf, sbp, SBUFSIZE) + call addchr (EOS, sbuf, sbp, SBUFSIZE) + t = lex (token) # peek at next token + call pbstr (token) + if (t != LEXSTRING) { # dump accumulated data statements + for (i = 1; i < sbp; i = j + 1) { + call outtab + call outstr (dat) + k = 1 + for (j = i + length (sbuf (i)) + 1; ; j = j + 1) { + if (k > 1) + call outch (COMMA) + call outstr (sbuf (i)) + call outch (LPAREN) + call outnum (k) + call outch (RPAREN) + call outch (SLASH) + if (sbuf (j) == EOS) + break + n = sbuf (j) + call outnum (n) + call outch (SLASH) + k = k + 1 + } + call pbstr (eoss) # use defined meaning of EOS + repeat { + t = gnbtok (token, MAXTOK) + call outstr (token) + } until (t == SLASH) + call outdon + } + sbp = 1 + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/swcode.r b/unix/boot/spp/rpp/rpprat/swcode.r new file mode 100644 index 00000000..348f8de3 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swcode.r @@ -0,0 +1,44 @@ +#-h- swcode 746 local 12/01/80 15:55:06 +# swcode - generate code for beginning of switch statement + include defs + + subroutine swcode (lab) + integer lab + + include COMMON_BLOCKS + + character tok (MAXTOK) + + integer labgen, gnbtok + + lab = labgen (2) + swvnum = swvnum + 1 + swvlev = swvlev + 1 + if (swvlev > MAXSWNEST) + call baderr ("switches nested too deeply.") + swvstk(swvlev) = swvnum + + if (swlast + 3 > MAXSWITCH) + call baderr ("switch table overflow.") + swstak (swlast) = swtop + swstak (swlast + 1) = 0 + swstak (swlast + 2) = 0 + swtop = swlast + swlast = swlast + 3 + xfer = NO + call outtab # Innn=(e) + call swvar (swvnum) + call outch (EQUALS) + call balpar + call outdwe + call outgo (lab) # goto L + call indent (1) + xfer = YES + while (gnbtok (tok, MAXTOK) == NEWLINE) + ; + if (tok (1) != LBRACE) { + call synerr ("missing left brace in switch statement.") + call pbstr (tok) + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/swend.r b/unix/boot/spp/rpp/rpprat/swend.r new file mode 100644 index 00000000..86088ddd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swend.r @@ -0,0 +1,106 @@ +#-h- swend 2714 local 12/01/80 15:55:07 +# swend - finish off switch statement; generate dispatch code + include defs + + subroutine swend (lab) + integer lab + + include COMMON_BLOCKS + + integer lb, ub, n, i, j, swn + + string sif "if (" + string slt ".lt.1.or." + string sgt ".gt." + string sgoto "goto (" + string seq ".eq." + string sge ".ge." + string sle ".le." + string sand ".and." + + swn = swvstk(swvlev) #get switch variable number, SWnnnn + swvlev = max(0, swvlev - 1) + + lb = swstak (swtop + 3) + ub = swstak (swlast - 2) + n = swstak (swtop + 1) + call outgo (lab + 1) # terminate last case + if (swstak (swtop + 2) == 0) + swstak (swtop + 2) = lab + 1 # default default label + xfer = NO + call indent (-1) + call outcon (lab) # L continue + call indent (1) + if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table + if (lb != 1) { # L Innn=Innn-lb+1 + call outtab + call swvar (swn) + call outch (EQUALS) + call swvar (swn) + if (lb < 1) + call outch (PLUS) + call outnum (-lb + 1) + call outdon + } + if (swinrg == NO) { + call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default + call outstr (sif) + call swvar (swn) + call outstr (slt) + call swvar (swn) + call outstr (sgt) + call outnum (ub - lb + 1) + call outch (RPAREN) + call outch (BLANK) + call outgo (swstak (swtop + 2)) + } + call outtab # goto (....),Innn + call outstr (sgoto) + j = lb + for (i = swtop + 3; i < swlast; i = i + 3) { + for ( ; j < swstak (i); j = j + 1) { # fill in vacancies + call outnum (swstak (swtop + 2)) + call outch (COMMA) + } + for (j = swstak (i + 1) - swstak (i); j >= 0; j = j - 1) + call outnum (swstak (i + 2)) # fill in range + j = swstak (i + 1) + 1 + if (i < swlast - 3) + call outch (COMMA) + } + call outch (RPAREN) + call outch (COMMA) + call swvar (swn) + call outdon + } + else if (n > 0) { # output linear search form + for (i = swtop + 3; i < swlast; i = i + 3) { + call outtab # if (Innn + call outstr (sif) + call swvar (swn) + if (swstak (i) == swstak (i+1)) { + call outstr (seq) # .eq.... + call outnum (swstak (i)) + } + else { + call outstr (sge) # .ge.lb.and.Innn.le.ub + call outnum (swstak (i)) + call outstr (sand) + call swvar (swn) + call outstr (sle) + call outnum (swstak (i + 1)) + } + call outch (RPAREN) # ) goto ... + call outch (BLANK) + call outgo (swstak (i + 2)) + } + if (lab + 1 != swstak (swtop + 2)) + call outgo (swstak (swtop + 2)) + } + call indent (-1) + call outcon (lab + 1) # L+1 continue + swlast = swtop # pop switch stack + swtop = swstak (swtop) + swinrg = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/swvar.r b/unix/boot/spp/rpp/rpprat/swvar.r new file mode 100644 index 00000000..df8da344 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swvar.r @@ -0,0 +1,22 @@ +#-h- swvar 157 local 12/01/80 15:55:08 +# swvar - output switch variable SWnnnn, where nnnn = lab +# (modified aug82 dct to permit declaration of switch variable) + + include defs + + subroutine swvar (lab) + integer lab, i, labnum, ndigits + + ifnotdef (UPPERC, call outch (LETS)) + ifdef (UPPERC, call outch (BIGS)) + ifnotdef (UPPERC, call outch (LETW)) + ifdef (UPPERC, call outch (BIGW)) + + labnum = lab + for (ndigits=0; labnum > 0; labnum=labnum/10) + ndigits = ndigits + 1 + for (i=3; i <= 6 - ndigits; i=i+1) + call outch (DIG0) + call outnum (lab) + return + end diff --git a/unix/boot/spp/rpp/rpprat/synerr.r b/unix/boot/spp/rpp/rpprat/synerr.r new file mode 100644 index 00000000..80bee91b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/synerr.r @@ -0,0 +1,37 @@ +#-h- synerr 703 local 12/01/80 15:55:08 +# synerr --- report non-fatal error + include defs + + subroutine synerr (msg) + + character msg +# character*(*) msg + + include COMMON_BLOCKS + character lc (MAXCHARS) + + integer i, junk + integer itoc + + string of " of " + string errmsg "Error on line " + + call putlin (errmsg, ERROUT) + if (level >= 1) + i = level + else + i = 1 # for EOF errors + junk = itoc (linect (i), lc, MAXCHARS) + call putlin (lc, ERROUT) + for (i = fnamp - 1; i >= 1; i = i - 1) + if (fnames (i - 1) == EOS | i == 1) { # print file name + call putlin (of, ERROUT) + call putlin (fnames (i), ERROUT) + break + } + + call putch (COLON, ERROUT) + call putch (BLANK, ERROUT) + call remark (msg) + return + end diff --git a/unix/boot/spp/rpp/rpprat/thenco.r b/unix/boot/spp/rpp/rpprat/thenco.r new file mode 100644 index 00000000..1b4a812e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/thenco.r @@ -0,0 +1,25 @@ + +include defs + +# THENCO -- Generate code for the "then" part of a compound IFERR statement. + + +subroutine thenco (tok, lab) + +integer lab, tok +include COMMON_BLOCKS +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + call outnum (lab+2) + call outtab + if (tok == LEXIFERR) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) + esp = esp - 1 # pop error stack + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ulstal.r b/unix/boot/spp/rpp/rpprat/ulstal.r new file mode 100644 index 00000000..bff4e19e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ulstal.r @@ -0,0 +1,15 @@ +#-h- ulstal 268 local 12/01/80 15:55:09 +# ulstal - install lower and upper case versions of symbol + include defs + + subroutine ulstal (name, defn) + character name (ARB), defn (ARB) + + include COMMON_BLOCKS + + call entdef (name, defn, deftbl) + call upper (name) + call entdef (name, defn, deftbl) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/uniqid.r b/unix/boot/spp/rpp/rpprat/uniqid.r new file mode 100644 index 00000000..6187fa86 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/uniqid.r @@ -0,0 +1,49 @@ +#-h- uniqid 1825 local 12/01/80 15:55:09 +# uniqid - convert an identifier to one never before seen + include defs + +subroutine uniqid (id) + +character id (MAXTOK) +integer i, j, junk, idchl +external index +integer lookup, index, length +character start (MAXIDLENGTH) +include COMMON_BLOCKS +string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters + + # Pad the identifer out to length 6 with FILLCHARs: + for (i = 1; id (i) != EOS; i = i + 1) + ; + for (; i <= MAXIDLENGTH; i = i + 1) + id (i) = FILLCHAR + i = MAXIDLENGTH + 1 + id (i) = EOS + id (i - 1) = FILLCHAR + + # Look it up in the table of generated names. If it's not there, + # it's unique. If it is there, it has been generated previously; + # modify it and try again. Assume this procedure always succeeds, + # since to fail implies there are very, very many identifiers in + # the symbol table. + # Note that we must preserve the first and last characters of the + # id, so as not to disturb implicit typing and to provide a flag + # to catch potentially conflicting user-defined identifiers without + # a lookup. + + if (lookup (id, junk, gentbl) == YES) { # (not very likely) + idchl = length (idch) + for (i = 2; i < MAXIDLENGTH; i = i + 1) + start (i) = id (i) + repeat { # until we get a unique id + for (i = MAXIDLENGTH - 1; i > 1; i = i - 1) { + j = mod (index (idch, id (i)), idchl) + 1 + id (i) = idch (j) + if (id (i) != start (i)) + break + } + if (i == 1) + call baderr ("cannot make identifier unique.") + } until (lookup (id, junk, gentbl) == NO) + } +end diff --git a/unix/boot/spp/rpp/rpprat/unstak.r b/unix/boot/spp/rpp/rpprat/unstak.r new file mode 100644 index 00000000..ec8a6eef --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/unstak.r @@ -0,0 +1,42 @@ +include defs + +# unstak - unstack at end of statement + +define IFSTMT 999 + + +subroutine unstak (sp, lextyp, labval, token) + +integer labval(MAXSTACK), lextyp(MAXSTACK) +integer sp, token, type + + for (; sp > 1; sp=sp-1) { + type = lextyp(sp) + if ((type == LEXIFERR | type == LEXIFNOERR) & token == LEXTHEN) + break + if (type == LEXIF | type == LEXIFERR | type == LEXIFNOERR) + type = IFSTMT + if (type == LBRACE | type == LEXSWITCH) + break + if (type == IFSTMT & token == LEXELSE) + break + + if (type == IFSTMT) { + call indent (-1) + call outcon (labval(sp)) + } else if (type == LEXELSE | type == LEXIFELSE) { + if (sp > 2) + sp = sp - 1 + if (type != LEXIFELSE) + call indent (-1) + call outcon (labval(sp) + 1) + } else if (type == LEXDO) + call dostat (labval(sp)) + else if (type == LEXWHILE) + call whiles (labval(sp)) + else if (type == LEXFOR) + call fors (labval(sp)) + else if (type == LEXREPEAT) + call untils (labval(sp), token) + } +end diff --git a/unix/boot/spp/rpp/rpprat/untils.r b/unix/boot/spp/rpp/rpprat/untils.r new file mode 100644 index 00000000..b784fab5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/untils.r @@ -0,0 +1,26 @@ +#-h- untils 397 local 12/01/80 15:55:11 +# untils - generate code for until or end of repeat + include defs + + subroutine untils (lab, token) + integer lab, token + + include COMMON_BLOCKS + + character ptoken (MAXTOK) + + integer junk + integer lex + + xfer = NO + call outnum (lab) + if (token == LEXUNTIL) { + junk = lex (ptoken) + call ifgo (lab - 1) + } + else + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whilec.r b/unix/boot/spp/rpp/rpprat/whilec.r new file mode 100644 index 00000000..5dc0fd01 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whilec.r @@ -0,0 +1,17 @@ +#-h- whilec 262 local 12/01/80 15:55:11 +# whilec - generate code for beginning of while + include defs + + subroutine whilec (lab) + + integer lab + integer labgen + include COMMON_BLOCKS + + call outcon (0) # unlabeled continue, in case there was a label + lab = labgen (2) + call outnum (lab) + call ifgo (lab + 1) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whiles.r b/unix/boot/spp/rpp/rpprat/whiles.r new file mode 100644 index 00000000..af5679fa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whiles.r @@ -0,0 +1,14 @@ +#-h- whiles 148 local 12/01/80 15:55:12 +# whiles - generate code for end of while + include defs + + subroutine whiles (lab) + + integer lab + include COMMON_BLOCKS + + call outgo (lab) + call indent (-1) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/test.r b/unix/boot/spp/rpp/test.r new file mode 100644 index 00000000..7bafd871 --- /dev/null +++ b/unix/boot/spp/rpp/test.r @@ -0,0 +1,212 @@ + + + + +define ARB 999999999 +define ERR -1 +define EOF -2 +define BOF -3 +define EOT -4 +define BOFL BOF +define EOFL EOF +define EOS 0 +define NO 0 +define YES 1 +define OK 0 +define NULL 0 + + +define READ_ONLY 1 +define READ_WRITE 2 +define WRITE_ONLY 3 +define APPEND 4 +define NEW_FILE 5 +define TEMP_FILE 6 +define NEW_COPY 7 +define NEW_IMAGE 5 +define NEW_STRUCT 5 +define NEW_TAPE 5 +define TEXT_FILE 11 +define BINARY_FILE 12 +define DIRECTORY_FILE 13 +define STATIC_FILE 14 +define SPOOL_FILE (-2) +define RANDOM 1 +define SEQUENTIAL 2 +define CLIN 1 +define CLOUT 2 +define STDIN 3 +define STDOUT 4 +define STDERR 5 +define STDGRAPH 6 +define STDIMAGE 7 +define STDPLOT 8 + + + +define SZ_BOOL 2 +define SZ_CHAR 1 +define SZ_SHORT 1 +define SZ_INT 2 +define SZ_LONG 2 +define SZ_REAL 2 +define SZ_DOUBLE 4 +define SZ_COMPLEX 4 +define SZ_POINTER 2 +define SZ_STRUCT 2 +define SZ_USHORT 1 +define SZ_FNAME 255 +define SZ_PATHNAME 511 +define SZ_LINE 1023 +define SZ_COMMAND 2047 + +define SZ_MII_SHORT 1 +define SZ_MII_LONG 2 +define SZ_MII_REAL 2 +define SZ_MII_DOUBLE 4 +define SZ_MII_INT SZ_MII_LONG + +define SZ_INT32 2 +define SZ_LONG32 2 +define SZ_STRUCT32 2 + +define TY_BOOL 1 +define TY_CHAR 2 +define TY_SHORT 3 +define TY_INT 4 +define TY_LONG 5 +define TY_REAL 6 +define TY_DOUBLE 7 +define TY_COMPLEX 8 +define TY_POINTER 9 +define TY_STRUCT 10 +define TY_USHORT 11 +define TY_UBYTE 12 + + +define INDEFS (-32767) +define INDEFL (-2147483647) +define INDEFI INDEFL +define INDEFR 1.6e38 +define INDEFD 1.6d308 +define INDEFX (INDEF,INDEF) +define INDEF INDEFR + +define IS_INDEFS (($1)==INDEFS) +define IS_INDEFL (($1)==INDEFL) +define IS_INDEFI (($1)==INDEFI) +define IS_INDEFR (($1)==INDEFR) +define IS_INDEFD (($1)==INDEFD) +define IS_INDEFX (real($1)==INDEFR) +define IS_INDEF (($1)==INDEFR) + + +define P2C ((($1)-1)*2+1) +define P2S ((($1)-1)*2+1) +define P2L ($1) +define P2R ($1) +define P2D ((($1)-1)/2+1) +define P2X ((($1)-1)/2+1) + +define P2P ($1) + + + + + + + + + + + + +define access xfaccs +define calloc xcallc +define close xfcloe +define delete xfdele +define error xerror +define flush xffluh +define getc xfgetc +define getchar xfgetr +define malloc xmallc +define mfree xmfree +define mktemp xmktep +define note xfnote +define open xfopen +define poll xfpoll +define printf xprinf +define putc xfputc +define putchar xfputr +define qsort xqsort +define read xfread +define realloc xrealc +define seek xfseek +define sizeof xsizef +define strcat xstrct +define strcmp xstrcp +define strcpy xstrcy +define strlen xstrln +define ungetc xfungc +define write xfwrie +define fatal xfatal +define fchdir xfchdr +define fscan xfscan +define getopt xgtopt +define getpid xgtpid +define getuid xgtuid +define rename xfrnam +define reset xreset +define scan xxscan + + + + + + +define IS_UPPER ($1>=65&$1<=90) +define IS_LOWER ($1>=97&$1<=122) +define IS_DIGIT ($1>=48&$1<=57) +define IS_PRINT ($1>=32&$1<127) +define IS_CNTRL ($1>0&$1<32) +define IS_ASCII ($1>0&$1<=127) +define IS_ALPHA (IS_UPPER($1)|IS_LOWER($1)) +define IS_ALNUM (IS_ALPHA($1)|IS_DIGIT($1)) +define IS_WHITE ($1==32|$1==9) +define TO_UPPER ($1+65-97) +define TO_LOWER ($1+97-65) +define TO_INTEG ($1-48) +define TO_DIGIT ($1+48) + +#!# 2 + + + + + + + + + + + + + + + + + +x$subr t_hello () + +x$short ST0001(14) +save +x$int iyy +data (ST0001(iyy),iyy= 1, 8) /104,101,108,108,111, 44, 32,119/ +data (ST0001(iyy),iyy= 9,14) /111,114,108,100, 10, 0/ +begin +#!# 10 + + call printf (ST0001) +end + + diff --git a/unix/boot/spp/rpp/x b/unix/boot/spp/rpp/x new file mode 100644 index 00000000..007b82a6 --- /dev/null +++ b/unix/boot/spp/rpp/x @@ -0,0 +1,18 @@ + + +x$subr t_foo () +x$int i +x$long l +x$pntr p +x$pntr p2 + +save +begin +#!# 7 + + i = 1 + l = 1 + p = 1 +end + + diff --git a/unix/boot/spp/test.x b/unix/boot/spp/test.x new file mode 100644 index 00000000..1c1d6c71 --- /dev/null +++ b/unix/boot/spp/test.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> + +# Test program. + +task hello = t_hello + +procedure t_hello() + +begin + call printf ("hello, world\n") +end diff --git a/unix/boot/spp/xc.c b/unix/boot/spp/xc.c new file mode 100644 index 00000000..73079c58 --- /dev/null +++ b/unix/boot/spp/xc.c @@ -0,0 +1,1970 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include <signal.h> +#include <errno.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <sys/wait.h> +#include <dirent.h> +#include <string.h> +#include <stdlib.h> +#include "xpp.h" +#include "../bootProto.h" + +#define NOKNET +#define import_kernel +#define import_knames +#include <iraf.h> + +#if defined(LINUX) || defined(BSD) +# ifdef SOLARIS +# undef SOLARIS +# endif +#endif + +/* + * XC -- Main entry point of the XC compiler front-end used by the IRAF + * system. + */ + +#define VERSION "IRAFNET XC V2.4 Jan 21 2010" + +#define ERR (-1) +#define EOS '\0' +#define YES 1 +#define NO 0 +#define MAXFLAG 64 /* maximum option flags */ +#define MAXFILE 1024 /* maximum files on cmdline */ +#define SZ_CMDBUF 4096 /* maximum command buffer */ +#define SZ_BUFFER 4096 /* library names, flags */ +#define SZ_LIBBUF 4096 /* full library names */ +#define SZ_FNAME 255 +#define SZ_PATHNAME 511 +#define SZ_PKGENV 256 +#define DEF_PKGENV "iraf" + +#ifdef MACOSX +#define CCOMP "cc" /* C compiler (also .s etc.) */ +#define LINKER "cc" /* Linking utility */ +#else +#define CCOMP "gcc" /* C compiler (also .s etc.) */ +#define LINKER "gcc" /* Linking utility */ +#endif +#define F77COMP "f77" /* Fortran compiler */ +#define DEBUGFLAG 'g' /* host flag for -x */ +#define USEF2C 1 /* use Fortran to C trans. */ + +#define LIBCINCLUDES "hlib$libc/" /* IRAF LIBC include dir */ +#define LOCALBINDIR "/usr/local/bin/" /* standard local BIN */ +#define SYSBINDIR "/usr/bin/" /* special system BIN */ + +#define XPP "xpp.e" +#define RPP "rpp.e" +#define EDSYM "edsym.e" +#define SHIMAGE "S.e" +#define LIBMAIN "libmain.o" +#define SHARELIB "libshare.a" +#define IRAFLIB1 "libex.a" +#define IRAFLIB2 "libsys.a" +#define IRAFLIB3 "libvops.a" +#define IRAFLIB4 "libos.a" +#define IRAFLIB5 "libVO.a" +#define IRAFLIB6 "libcfitsio.a" + +#ifdef LINUX +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ +#ifndef LINUXPPC +#ifndef LINUX64 + "", /* 3 -lcompat */ +#endif +#else + "-lg2c", /* 3 */ +#endif + "-lpthread", /* 4 */ + "-lm", /* 5 */ + "-lrt", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef BSD +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcompat", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef MACOSX +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcurl", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O3", /* 0 */ + 0}; /* EOF */ + +/* As of Dec2007 there remains an unexplained optimizer bug in +** the system which has the effect of disabling FPE handling on +** Mac Intel/PPC systems. For the moment, we'll disable the optimization +** until this is better understood or fixed in future GCC versions. +*/ +int nopt_flags = 0; /* No. optimizer flags */ + +#else +#ifdef SOLARIS +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lsocket", /* 3 */ + "-lnsl", /* 4 */ + "-lintl", /* 5 */ + "-ldl", /* 6 */ + "-lelf", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +#ifdef CYGWIN +char *fortlib[] = { "-lf2c", /* 0 (host progs) */ + "-lf2c", /* 1 */ + "-lm", /* 2 */ + "-lcompat", /* 3 */ + "", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#else +char *fortlib[] = { "-lU77", /* 0 (host progs) */ + "-lm", /* 1 */ + "-lF77", /* 2 */ + "-lI77", /* 3 */ + "-lm", /* 4 */ + "", /* 5 */ + "", /* 6 */ + "", /* 7 */ + "", /* 8 */ + "", /* 9 */ + 0}; /* EOF */ + +char *opt_flags[] = { "-O", /* 0 */ + 0}; /* EOF */ +int nopt_flags = 1; /* No. optimizer flags */ + +#endif +#endif +#endif +#endif +#endif + +#ifdef BSD +#define F_STATIC "-static" +#define F_SHARED "-shared" +#else +#ifdef MACOSX +#define F_STATIC "-static" +#define F_SHARED "-shared" +#else +#ifdef LINUX +#define F_STATIC "-Wl,-Bstatic" +#define F_SHARED "-Wl,-Bdynamic" +#else +#ifdef SOLARIS +#define F_STATIC "-Wl,-Bstatic" +#define F_SHARED "-Wl,-Bdynamic" +#endif +#endif +#endif +#endif + +#define isxfile(str) (getextn(str) == 'x') +#define isffile(str) (getextn(str) == 'f') +#define iscfile(str) (getextn(str) == 'c') +#define issfile(str) (getextn(str) == 's') +#define isefile(str) (getextn(str) == 'e') +#define isafile(str) (getextn(str) == 'a') +#define isofile(str) (getextn(str) == 'o') +#define ispfile(str) (getextn(str) == 'P') /* func prototypes */ + + +#ifdef SOLARIS +#ifdef X86 +int usesharelib = NO; +int noedsym = YES; +#else +int usesharelib = YES; +int noedsym = NO; +#endif + +#else +#ifdef SHLIB +int usesharelib = YES; +int noedsym = NO; +#else +int usesharelib = NO; +int noedsym = YES; +#endif +#endif + +int stripexe = NO; +int notvsym = NO; +int noshsym = NO; +int errflag = NO; +int objflags = NO; +int keepfort = NO; +int mkobject = YES; +int mktask = YES; +int optimize = YES; +int cflagseen = NO; +int nfileargs = 0; +int link_static = NO; +int link_nfs = NO; +int debug = NO; +int dbgout = NO; +int hostprog = NO; +int voslibs = YES; +int nolibc = NO; +int usef2c = YES; +int useg95 = NO; +int userincs = NO; +#ifdef LINUXPPC +int useg2c = YES; +#else +int useg2c = NO; +#endif +int host_c_main = NO; + +char ccomp[SZ_FNAME] = CCOMP; +char f77comp[SZ_FNAME] = F77COMP; +char linker[SZ_FNAME] = LINKER; +char f2cpath[SZ_FNAME] = "/usr/bin/f2c"; +char g77path[SZ_FNAME] = "/usr/bin/g77"; + +char outfile[SZ_FNAME] = ""; +char tempfile[SZ_FNAME] = ""; +char *lflags[MAXFLAG+1]; +char *lfiles[MAXFILE+1]; /* all files */ +char *hlibs[MAXFILE+1]; /* host libraries */ +char *lxfiles[MAXFILE+1]; /* .x files */ +char *lffiles[MAXFILE+1]; /* .f files */ +char buffer[SZ_BUFFER+1]; +char libbuf[SZ_LIBBUF+1]; +char *bp = buffer; +char *libp = libbuf; +char *pkgenv = NULL; +char *pkglibs = NULL; +char v_pkgenv[SZ_PKGENV+1]; +int nflags, nfiles, nhlibs, nxfiles, nffiles; +long sig_int, sig_quit, sig_hup, sig_term; +char *shellname = "/bin/sh"; +int foreigndefs = NO; +char *foreign_defsfile = ""; +char *irafarch = ""; /* IRAFARCH string */ +char floatoption[32] = ""; /* f77 arch flag, if any */ +int pid; + + +/** + * External procedure declarations. + */ +extern void ZZSTRT (void); +extern void ZZSTOP (void); + +/** + * Local procedure declarations. + */ +static char *mkfname (char *i_fname); +static int addflags (char *flag, char *arglist[], int *p_nargs); +static char *iraflib (char *libref); +static void printargs (char *cmd, char *arglist[], int nargs); +static void xtof (char *file); +static int getextn (char *fname); +static void chdot (char *fname, char dotchar); + +static int run (char *task, char *argv[]); +static int sys (char *cmd); + +static void done (int k); +static void enbint (SIGFUNC handler); +static void interrupt (void); +static int await (int waitpid); +static void rmfiles (void); + +static void fatalstr (char *s1, char *s2); +static void fatal (char *s); + +static int isv13 (void); +static char *findexe (char *prog, char *dir); + + + + +/** + * MAIN -- Execution begins here. Interpret command line arguments and + * pass commands to UNIX to execute the various passes, i.e.: + * + * xpp SPP to modified-ratfor + * rpp modified-ratfor to Fortran + * f77 UNIX fortran compiler + * cc compile other sources, link if desired + * + * The Fortran source is left behind if the -F flag is given. The IRAF root + * directory must either be given on the command line as "-r pathname" or in + * the environment as the variable "irafdir". + */ +int +main (int argc, char *argv[]) +{ + int i, j, nargs, ncomp; + char *arglist[MAXFILE+MAXFLAG+10]; + char *arg, *ip, *s; + int status, noperands; + + /* Initialization. */ + ZZSTRT(); + isv13(); + +#if defined(LINUX) || defined(BSD) || defined(X86) || defined(MACOSX) + if (os_sysfile ("f77.sh", f77comp, SZ_FNAME) < 0) { + strcpy (f77comp, "f77"); + usef2c = 0; + } else + usef2c = 1; + if (os_sysfile ("f2c.e", tempfile, SZ_FNAME) > 0) + strcpy (f2cpath, tempfile); +#else + strcpy (f77comp, "f77"); +#endif + + nflags = nfiles = nhlibs = nxfiles = nffiles = 0; + + sig_int = (long) signal (SIGINT, SIG_IGN) & 01; + sig_quit = (long) signal (SIGQUIT, SIG_IGN) & 01; + sig_hup = (long) signal (SIGHUP, SIG_IGN) & 01; + sig_term = (long) signal (SIGTERM, SIG_IGN) & 01; + + enbint ((SIGFUNC)interrupt); + pid = getpid(); + + /* Load any XC related environment definitions. + */ + if ((s = os_getenv ("XC-CC")) || (s = os_getenv ("XC_CC"))) + strcpy (ccomp, s); + if ((s = os_getenv ("XC-F77")) || (s = os_getenv ("XC_F77"))) { + strcpy (f77comp, s); + usef2c = (strncmp (f77comp, "f77", 3) == 0 ? 1 : 0); + useg95 = (strncmp (f77comp, "g95", 3) == 0 ? 1 : 0); + } + if ((s = os_getenv ("XC-LINKER")) || (s = os_getenv ("XC_LINKER"))) + strcpy (linker, s); + + + + /* Always load the default IRAF package environment. */ + loadpkgenv (DEF_PKGENV); + + /* Count the number of file arguments. Load the environment for + * any packages named on the command line. + */ + pkgenv = NULL; + v_pkgenv[0] = EOS; + for (i=1, nfileargs=0; argv[i] != NULL; i++) + if (argv[i][0] != '-') + nfileargs++; + else if (strcmp (argv[i], "-p") == 0 && argv[i+1]) { + loadpkgenv (argv[++i]); + strcat (v_pkgenv, v_pkgenv[0] ? " -p " : "-p "); + strcat (v_pkgenv, argv[i]); + pkgenv = v_pkgenv; + } + + /* If no package environment was specified see if the user has + * specified a default package in their user environment. + */ + if (!pkgenv) { + char *s, u_pkgenv[SZ_PKGENV+1]; + char *pkgname, *ip; + + if ((s = os_getenv ("PKGENV"))) { + strcpy (ip = u_pkgenv, s); + while (*ip) { + while (isspace(*ip)) + ip++; + pkgname = ip; + while (*ip && !isspace(*ip)) + ip++; + if (*ip) + *ip++ = EOS; + + if (pkgname[0]) { + loadpkgenv (pkgname); + strcat (v_pkgenv, v_pkgenv[0] ? " -p " : "-p "); + strcat (v_pkgenv, pkgname); + pkgenv = v_pkgenv; + } + } + } + } + + /* Process command line options, make file lists. + * Convert ".x" files to ".f". + */ + for (i=1; (arg = argv[i]) != NULL; i++) { + if (arg[0] == '-') { + switch (arg[1]) { + case '/': + /* Pass flag on without further interpretation. + * "-/foo" -> "-foo" + * "-//foo" -> "foo" + */ + lflags[nflags] = bp; + ip = &arg[2]; + if (*ip == '/') + ip++; + else + *bp++ = '-'; + + while ((*bp++ = *ip++)) + ; + + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + break; + + case 'D': + /* Pass a -D<define> flag on to the host compiler. + */ + lflags[nflags] = bp; + for (ip = &arg[0]; (*bp++ = *ip++); ) + ; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + break; + + case 'I': + /* Pass a -I<include-dir> flag on to the host compiler. + * A special case is "-Inolibc" which disables automatic + * inclusion of the IRAF LIBC includes (hlib$libc). + */ + if (strcmp (&arg[2], "nolibc") == 0) + nolibc++; + else { + lflags[nflags] = bp; + *bp++ = arg[0]; + *bp++ = arg[1]; + strcpy (bp, vfn2osfn (&arg[2], 0)); + bp += strlen (bp) + 1; + + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + break; + + case 'l': + case 'L': + /* Library file (-llib) or library directory (-Ldir) + * reference. + */ + if ((lfiles[nfiles] = iraflib (arg)) == NULL) { + hlibs[nhlibs] = arg; + nhlibs++; + } else + nfiles++; + if (nfiles > MAXFILE || nhlibs > MAXFILE) + fatal ("Too many files"); + + objflags = YES; + mkobject = YES; + mktask = YES; + break; + + case 'o': + /* Set output file name. + */ + if ((arg = argv[++i]) == NULL) + i--; + else + strcpy (outfile, arg); + mkobject = YES; + mktask = YES; + objflags = YES; + break; + + case 'p': + /* Ignore since the -p args were already processed above. + */ + i++; + break; + + case 'r': + /* Not used anymore */ + if ((arg = argv[++i]) == EOS) + i--; + break; + + case 'h': + /* Host program: do not link in IRAF main or search + * standard IRAF libraries unless explicitly referenced + * on command line. + */ + voslibs = 0; + /* fall through */ + + case 'H': + /* Link a host program, but include the VOS libraries. + */ + hostprog++; + noedsym++; + nolibc++; + break; + + case 'G': + /* Force a program to link w/ libg2c.a instead of libf2c.a + */ + useg2c++; + break; + + case 'A': + /* Force arch-specific include files. + */ + userincs++; + break; + + case 'C': + /* Link a host program which has a C main. We may need + * to tweak the command line as a special case here since + * we normally assume Fortran sources. This is currently + * only needed for host C programs under LinuxPPC. + */ + host_c_main++; + break; + + case 'V': + /* Print XC version identification. + */ + fprintf (stderr, "%s\n", VERSION); + fflush (stderr); + break; + + default: + if (strcmp (&arg[1], "Nh") == 0) { + if ((arg = argv[++i]) == EOS) + i--; + else { + foreigndefs++; + foreign_defsfile = arg; + continue; + } + } + + lflags[nflags] = bp; + *bp++ = '-'; + + /* Process list of flags without arguments, e.g. "-xyz" + * which is the same as "-x -y -z". + */ + for (ip = &arg[1]; *ip != EOS; ip++) + if (*ip == 'c') { + mkobject = YES; + mktask = NO; + objflags = YES; + cflagseen = YES; + + } else if (*ip == 'd') { + debug++; + } else if (*ip == 'q') { + optimize = NO; + } else if (*ip == 'O') { + optimize = YES; + + } else if (*ip == 'F' || *ip == 'f') { + keepfort = YES; + if (objflags == NO) { + mkobject = NO; + mktask = NO; + } + } else if (*ip == 'x') { + dbgout++; + optimize = NO; + *bp++ = DEBUGFLAG; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + } else if (*ip == 'z') { + usesharelib = NO; + } else if (*ip == 'e') { + noedsym = YES; + } else if (*ip == 't') { + notvsym = YES; + } else if (*ip == 'T') { + noshsym = YES; + } else if (*ip == 's') { + stripexe = YES; + goto passflag; + } else if (*ip == 'N') { + /* "NFS" link option. Generate the output temp + * file in /tmp during the link, then move it to + * the output directory in one operation when done. + * For cases such as linking in an NFS-mounted + * directory, where all the NFS i/o may slow the + * link down excessively. + */ + link_nfs = YES; + } else { +passflag: mkobject = YES; + if (!cflagseen) + mktask = YES; + *bp++ = *ip; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + } + + if (bp - lflags[nflags] <= 1) { + lflags[nflags] = NULL; + bp--; + } else { + *bp++ = EOS; + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + } + + } else { + char *ip, *op, *last_dot; + + /* Get default name for output executable file, if not given + * as arg. The default extension is ".e". + */ + if (outfile[0] == EOS) { + last_dot = NULL; + for (ip=arg, op=outfile; (*op = *ip++) != EOS; op++) + if (*op == '.') + last_dot = op; + if (last_dot != NULL) + *last_dot = EOS; + strcat (outfile, ".e"); + } + + /* Munge filename if file is a library. */ + if (isafile(arg) && (s = iraflib(arg))) + arg = s; + + if (access (arg,0) == -1) { + fprintf (stderr, "Warning: file `%s' not found\n", arg); + fflush (stderr); + } else { + lfiles[nfiles++] = arg; + if (nfiles > MAXFILE) + fatal ("Too many files"); + + if (isxfile (arg)) { + xtof (arg); + if (errflag & (XPP_BADXFILE | XPP_COMPERR)) { + nfiles--; + errflag &= ~(XPP_BADXFILE | XPP_COMPERR); + } + } else if (isffile (arg)) { + lffiles[nffiles++] = arg; + if (nffiles > MAXFILE) + fatal ("too many files"); + } else if (isefile (arg)) + fatal ("no .e files permitted in file list"); + } + } + } + + if (!mkobject) { + if (debug) { + fprintf (stderr, "quit, fortran only\n"); + fflush (stderr); + } + ZZSTOP(); + exit (errflag); + } + + /* Add -I<include-dir> to lflags for each directory in the pkglibs + * package library list. pkglibs is a comma delimited list of VFN + * directory names formed by loading the core system and layered + * package environments. + */ + if ((pkglibs = os_getenv ("pkglibs"))) { + char *ip, *op, *vp, fname[SZ_FNAME]; + + for (ip=pkglibs; *ip; ) { + while (*ip && (isspace(*ip) || *ip == ',')) + ip++; + for (op=fname; *ip && !(isspace (*ip) || *ip == ','); ) + *op++ = *ip++; + *op++ = EOS; + if (*fname == EOS) + break; + + /* Omit the LIBC includes if -Inolibc was specified. */ + if (! (nolibc && strcmp (fname, LIBCINCLUDES) == 0)) { + lflags[nflags] = bp; + *bp++ = '-'; + *bp++ = 'I'; + for (vp=vfn2osfn(fname,0); (*bp++ = *vp++); ) + ; + if (*(bp-2) == '/') { + --bp; + *(bp-1) = EOS; + } + + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of buffer space for options"); + if (nflags++ >= MAXFLAG) + fatal ("Too many compiler options"); + } + + while (*ip && (isspace(*ip) || *ip == ',')) + ip++; + } + } + + /* Now check for any alternative compiler definitions or commandline + * flags which will affect out link line. Some systems like LinuxPPC + * will require use of -lg2c even though we can continue to use the + * hlib$f77.sh the fortran compiler script on that system. + */ + if (useg2c || strncmp (f77comp, "g77", 3) == 0) { + fortlib[0] = fortlib[1] = "-lg2c"; + } + + +#ifdef sun + /* Determine if any special architecture dependent compilation flags + * are needed. For the Sun V1.3 compiler, since FLOAT_OPTION is no + * longer supported, we look for IRAFARCH and generate the -f68881 + * or -ffpa compiler switches automatically if we are compiling on a + * Sun-3 and no -/f* has already been specified on the command line. + */ + if (!floatoption[0] && (irafarch = os_getenv("IRAFARCH"))) + if (irafarch[0] == 'f') + sprintf (floatoption, "-%s", irafarch); +#endif + /* Compile all F77 source files with F77 to produce object code. + * This compilation is separate from that used for the '.x' files, + * because we do not want to use the UNIX "-u" flag (requires that + * everything be declared) for raw Fortran files. + */ + nargs = 0; + arglist[nargs++] = f77comp; + arglist[nargs++] = "-c"; + if (usef2c == YES) { + arglist[nargs++] = "-f2c"; + arglist[nargs++] = f2cpath; + } + +#ifdef MACOSX + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + } + } +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-FFLAGS")) || (s = os_getenv("XC_FFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + for (i=0; i < nffiles; i++) + arglist[nargs++] = lffiles[i]; + arglist[nargs] = NULL; + + if (i > 0) { + if (debug) + printargs (f77comp, arglist, nargs); + status = run (f77comp, arglist); +#ifdef LINUX + /* This kludge is to work around a bug in the F2C based F77 script + * on Linux, which returns an exit status of 4 when successfully + * compiling a Fortran file. + */ + if (status == 4) + status = 0; +#endif + errflag += status; + } + + + /* Compile the remaining Fortran source files with F77 to produce + * object code. + */ + nargs = 0; + arglist[nargs++] = f77comp; + arglist[nargs++] = "-c"; + arglist[nargs++] = "-u"; + arglist[nargs++] = "-x"; + if (usef2c == YES) { + arglist[nargs++] = "-f2c"; + arglist[nargs++] = f2cpath; + } + +#ifdef MACOSX + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + + } + } +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-FFLAGS")) || (s = os_getenv("XC_FFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + /* Make list of files to be compiled. Do not include F77 files, + * as they were already compiled above. + */ + for (i=0, noperands=0; i < nfiles; i++) { + for (j=0; j < nffiles && lffiles[j] != lfiles[i]; j++) + ; + if (j >= nffiles && isffile (lfiles[i])) { + arglist[nargs++] = lfiles[i]; + noperands++; + } + } + arglist[nargs] = NULL; + + if (noperands > 0) { + if (debug) + printargs (f77comp, arglist, nargs); + status = run (f77comp, arglist); +#ifdef LINUX + /* This kludge is to work around a bug in the F2C based F77 script + * on Linux, which returns an exit status of 4 when successfully + * compiling a Fortran file. + */ + if (status == 4) + status = 0; +#endif + errflag += status; + } + + + /* Compile the remaining non-Fortran source files with CC to produce + * object code. + */ + nargs = 0; + arglist[nargs++] = ccomp; + arglist[nargs++] = "-c"; + +#ifdef MACH64 + arglist[nargs++] = "-DMACH64"; /* needed for zmain.c */ +#endif +#ifdef LINUX64 + arglist[nargs++] = "-DLINUX64"; /* needed for zmain.c */ +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#ifdef LINUX + arglist[nargs++] = "-DLINUX"; +#ifdef REDHAT + arglist[nargs++] = "-DREDHAT"; +#endif +#ifdef LINUXPPC + arglist[nargs++] = "-DLINUXPPC"; +#endif + arglist[nargs++] = "-DPOSIX"; + arglist[nargs++] = "-DSYSV"; +#endif + +#ifdef BSD + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-DBSD"; +#endif + +#ifdef MACOSX + arglist[nargs++] = "-DMACOSX"; + if (useg95 == 0) { + if ((irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + + } + } +#endif + +#ifdef SOLARIS + arglist[nargs++] = "-DSOLARIS"; +#ifdef X86 + arglist[nargs++] = "-DX86"; +#endif + arglist[nargs++] = "-DPOSIX"; + arglist[nargs++] = "-DSYSV"; +#endif + +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif + +#ifdef sun + if (floatoption[0]) + arglist[nargs++] = floatoption; +#endif + if (optimize) { + for (i=0; i < nopt_flags; i++) + arglist[nargs++] = opt_flags[i]; + } + + /* Add the user-defined flags last so they can override the + * hardwired options. + */ + if ((s = os_getenv("XC-CFLAGS")) || (s = os_getenv("XC_CFLAGS"))) + addflags (s, arglist, &nargs); + + for (i=0; i < nflags; i++) + arglist[nargs++] = lflags[i]; + + /* Make list of files to be compiled. Only C and assembler files + * are included. + */ + for (i=0, noperands=0; i < nfiles; i++) { + if (iscfile (lfiles[i]) || issfile (lfiles[i])) { + arglist[nargs++] = lfiles[i]; + noperands++; + } + } + arglist[nargs] = NULL; + + if (noperands > 0) { + if (debug) + printargs (ccomp, arglist, nargs); + errflag += run (ccomp, arglist); + } + + + /* If "-c" (compile only), or there was a compiler error, do not + * proceed with the link. + */ + if (!mktask || cflagseen || errflag) + done (errflag); + + + /* Link the object files and libraries to produce the "-o" task. + */ + nargs = 0; + arglist[nargs++] = linker; + if ((s = os_getenv("XC-LFLAGS")) || (s = os_getenv("XC_LFLAGS"))) + addflags (s, arglist, &nargs); + +#ifdef MACOSX + if (useg95 == 0 && (irafarch = os_getenv("IRAFARCH"))) { + if (strcmp (irafarch, "macosx") == 0) { + /* + arglist[nargs++] = "-arch"; + arglist[nargs++] = "ppc"; + */ + arglist[nargs++] = "-arch"; + arglist[nargs++] = "i386"; + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-mmacosx-version-min=10.4"; + } else if (strcmp (irafarch, "macintel") == 0) { + arglist[nargs++] = "-arch"; + arglist[nargs++] = "x86_64"; + arglist[nargs++] = "-m64"; + } + } +#endif + +#ifdef SOLARIS + arglist[nargs++] = "-Wl,-t"; +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-Wl,--defsym,mem_=0"; +#endif +#if (defined(LINUX) && !defined(MACH64)) + arglist[nargs++] = "-m32"; +#endif +#if (defined(BSD)) + arglist[nargs++] = "-m32"; + arglist[nargs++] = "-L/usr/lib32"; + arglist[nargs++] = "-B/usr/lib32"; +#endif +#ifdef NEED_GCC_SPECS + { char gcc_specs[SZ_PATHNAME]; + static char cmd[SZ_CMDBUF]; + + if (os_sysfile ("gcc-specs", gcc_specs, SZ_PATHNAME) < 0) + arglist[nargs++] = "/iraf/iraf/unix/bin/gcc-specs"; + sprintf (cmd, "-specs=%s", gcc_specs); + arglist[nargs++] = cmd; + } +#endif +#ifdef LINUXAOUT + arglist[nargs++] = "-b"; + arglist[nargs++] = "i486-linuxaout"; +#endif + arglist[nargs++] = "-o"; + + if (link_nfs) { + sprintf (tempfile, "/tmp/T_%s.XXXXXX", outfile); +#ifdef LINUX + mkstemp (tempfile); +#else + mktemp (tempfile); +#endif + } else + sprintf (tempfile, "T_%s", outfile); + arglist[nargs++] = tempfile; + + ncomp = 0; + for (i=0; i < nfiles; i++) + if (*(ip = lfiles[i]) != '-') { + while (*ip++ != EOS) + ; + while (*--ip != '.' && ip >= lfiles[i]) + ; + if (*ip == '.') + switch (ip[1]) { + case 'f': + case 'r': + case 'c': + case 's': + case 'e': + ip[1] = 'o'; + ncomp++; + } + } + + /* Link options. */ + link_static = 0; + for (i=0; i < nflags; i++) { + arglist[nargs++] = lflags[i]; + if (strcmp (lflags[i], F_STATIC) == 0) + link_static = 1; + else if (strcmp (lflags[i], F_SHARED) == 0) + link_static = 0; + } + +#ifdef sun + /* Need to pass -f<float> to CC for the C libraries. */ + if (floatoption[0]) + arglist[nargs++] = floatoption; + + /* If we are using the V1.3 Sun Fortran compiler, the V1.3 "f77" + * should be a symbolic link pointing to the BIN directory for the + * new compiler. Construct the path to this directory and put it + * out as a -Ldir flag on the link line to ensure that the library + * is searched for linking. + */ + if (isv13()) { + char libpath[SZ_PATHNAME]; + char dir[SZ_PATHNAME], *path; + char *pp, *ip, *op, *s; + int n; + + path = findexe ("f77", dir); + + strcpy (libpath, "-L"); + strcpy (libpath+2, dir); + for (op=libpath; *op; op++) + ; + if ((n = readlink (path, op, 128)) > 0) { + op[n] = EOS; + + for (ip=op; *ip; ip++) + if (*ip == '/') + op = ip; + *op = EOS; + + /* Search, e.g., /usr/lang/SC0.0/ffpa first if Sun-3. */ + if (floatoption[0]) { + s = floatoption + 1; + *op = '/'; + strcpy (op+1, s); + strcpy (libp, libpath); + libp += strlen (pp = libp) + 1; + arglist[nargs++] = pp; + } + + /* Search /usr/lang/SC0.0 (or whatever). */ + *op = EOS; + strcpy (libp, libpath); + libp += strlen (pp = libp) + 1; + arglist[nargs++] = pp; + } + } +#endif + + /* File to link. */ + for (i=0; i < nfiles; i++) + arglist[nargs++] = lfiles[i]; + + /* Libraries to link against. + */ + if (hostprog) { +#ifdef LINUXPPC + /* LinuxPPC (YellowDog anyway) requires this library to resolve + * the MAIN__ generated by the fortran program statement into + * the 'main'. + */ + if (host_c_main == 0) + arglist[nargs++] = "-lfrtbegin"; +#else + if (!isv13()) + arglist[nargs++] = mkfname (fortlib[0]); +#endif + } else + arglist[nargs++] = mkfname (LIBMAIN); + + if (voslibs) { + if (usesharelib) { + arglist[nargs++] = mkfname (SHARELIB); + arglist[nargs++] = mkfname (IRAFLIB4); + arglist[nargs++] = mkfname (IRAFLIB5); + arglist[nargs++] = mkfname (IRAFLIB6); + } else { + arglist[nargs++] = mkfname (IRAFLIB1); + arglist[nargs++] = mkfname (IRAFLIB2); + arglist[nargs++] = mkfname (IRAFLIB3); + arglist[nargs++] = mkfname (IRAFLIB4); + arglist[nargs++] = mkfname (IRAFLIB5); + arglist[nargs++] = mkfname (IRAFLIB6); + } + } + + /* Host libraries, searched after iraf libraries. */ + for (i=0; i < nhlibs; i++) + arglist[nargs++] = hlibs[i]; + + /* The remaining system libraries depend upon which version of + * the SunOS compiler we are using. The V1.3 compilers use only + * -lF77 and -lm. + */ + if (isv13()) { + addflags (fortlib[2], arglist, &nargs); + addflags (fortlib[4], arglist, &nargs); + } else { + addflags (fortlib[1], arglist, &nargs); + addflags (fortlib[2], arglist, &nargs); + addflags (fortlib[3], arglist, &nargs); + addflags (fortlib[4], arglist, &nargs); + addflags (fortlib[5], arglist, &nargs); + addflags (fortlib[6], arglist, &nargs); + addflags (fortlib[7], arglist, &nargs); + addflags (fortlib[8], arglist, &nargs); + addflags (fortlib[9], arglist, &nargs); + } + arglist[nargs] = NULL; + + if (ncomp) { + fprintf (stderr, "link:\n"); + fflush (stderr); + } + if (debug) + printargs (linker, arglist, nargs); + + /* If the link is successful, replace the old executable with the + * new one. Do not delete the bad executable if the link fails, + * as we might want to examine its symbol table. + */ + if ((status = run (linker, arglist)) == 0) { + unlink (outfile); + + if (link_nfs) { + char command[1024]; + sprintf (command, "/bin/cp -f %s %s", tempfile, outfile); + if (debug) + printargs (command, NULL, 0); + status = sys (command); + } else + link (tempfile, outfile); + + /* Force the mode of the file. */ + chmod (outfile, 0755); + + unlink (tempfile); + } + errflag += status; + + /* If we are linking against the iraf shared library and symbol editing + * has not been disabled, edit the symbol table of the new executable + * to provide symbols within the shared image. + */ + if (usesharelib && !noedsym && !stripexe) { + char shlib[SZ_PATHNAME+1]; + char edsym[SZ_PATHNAME+1]; + char command[SZ_CMDBUF]; + + /* The os_sysfile(SHIMAGE) below assumes the existence of a file + * entry "S.e" in the directory containing the real shared image + * "S<n>.e". We can't easily look directly for S<n>.e because + * the process symbol table and image has to be examined to + * determine the shared image version number. + */ + if (os_sysfile (SHIMAGE, shlib, SZ_PATHNAME) > 0) { + if (os_sysfile (EDSYM, edsym, SZ_PATHNAME) > 0) { + sprintf (command, "%s %s %s", edsym, outfile, shlib); + if (noshsym) + strcat (command, " -T"); + else if (notvsym) + strcat (command, " -t"); + status = sys (command); + } + } + } + errflag += status; + done (errflag); + + return (0); +} + + +/* MKFNAME -- Make the UNIX pathname of an IRAF library file. Use os_sysfile + * the get the vfn of the library file, so that we do not have to know what + * system directory the library file is in. + */ +static char * +mkfname (char *i_fname) +{ + char fname[SZ_PATHNAME+1]; + char *oname; + + /* Library referenced as -lXXX */ + if (strncmp (i_fname, "-l", 2) == 0) { + sprintf (fname, "lib%s.a", &i_fname[2]); + if ((oname = iraflib (fname))) + return (oname); + else + return (i_fname); + } + + /* Must be a library filename or pathname */ + strcpy (fname, i_fname); + if ((oname = iraflib (fname))) + strcpy (libp, oname); + else + strcpy (libp, fname); + + oname = libp; + libp += strlen (libp) + 1; + + return (oname); +} + + +/* ADDFLAGS -- Add one or more flags to an argument list. Ignore null flags, + * separate multiple flags on whitespace. + */ +static int +addflags (char *flag, char *arglist[], int *p_nargs) +{ + register int i, len, nargs = *p_nargs; + char *fp, *fs, lflag[SZ_FNAME]; + + if (flag && *flag) { + + for (fp = flag; *fp; ) { + while (*fp && isspace(*fp)) /* skip leading space */ + fp++; + for (i=0; *fp && !isspace(*fp); ) /* collect flag */ + lflag[i++] = *fp++; + lflag[i] = '\0'; + len = strlen (lflag); + strcpy ((fs = malloc(len+1)), lflag); + + if (strcmp (lflag, F_STATIC) == 0) { + link_static = 1; + } else if (strcmp (lflag, F_SHARED) == 0) { + link_static = 0; +#if defined(LINUX) || defined(BSD) || defined(X86) || defined(MACOSX) + } else if ((strcmp (lflag, "-lf2c") == 0) || + (strcmp (lflag, "-lcompat") == 0)) { + /* Use the IRAF version of libf2c.a or libcompat.a, + * not the host version which may or may not be present. + */ + arglist[nargs++] = mkfname (lflag); + *p_nargs = nargs; + return (1); + } +#endif +#ifdef SOLARIS + else if (strcmp (lflag, "-ldl") == 0) { + /* This beastie has to be linked dynamic on Solaris, but + * we don't want to have to know this everywhere so we do + * it automatically there. + */ + if (link_static) + arglist[nargs++] = F_SHARED; + arglist[nargs++] = fs; + if (link_static) + arglist[nargs++] = F_STATIC; + *p_nargs = nargs; + return (1); + } +#endif + arglist[nargs++] = fs; + } + + *p_nargs = nargs; + return (1); + } + + return (0); +} + + +/* IRAFLIB -- Determine if "libname" is an IRAF library. If so return + * the pathname of the library, else return NULL. + */ +static char * +iraflib (char *libref) +{ + register char *ip, *op; + char savename[SZ_PATHNAME+1]; + char libname[SZ_PATHNAME+1]; + char fname[SZ_PATHNAME+1]; + char path[SZ_PATHNAME+1]; + int foundit, dbg = dbgout; + char *absname; + + strcpy (savename, libref); + + /* If dbgout is enabled try the debug library first, but fall back + * to the normal library if thie debug library is not found. + */ +again: + if (strncmp (libref, "-l", 2) == 0) { + sprintf (libname, "lib%s.a", libref+2); + libref = libname; + goto again; + } else + strcpy (libname, libref); + + /* Position IP to EOS. */ + for (ip=libref; *ip; ip++) + ; + + if (!(*(ip-2) == '.' && *(ip-1) == 'a')) { + /* Not a library file, leave it alone. + */ + strcpy (fname, libref); + + } else { + /* Normalize the library file name, "libXXX[_p].a". + */ + for (ip=libref, op=fname; (*op = *ip); op++, ip++) + ; + if ((*(op-2) == '.' && *(op-1) == 'a')) { + *(op-2) = '\0'; + op -= 2; + } else + op -= 1; + + if (dbg && !(*(op-2) == '_' && *(op-1) == 'p')) { + *op++ = '_'; + *op++ = 'p'; + } + *op++ = '.'; + *op++ = 'a'; + *op++ = '\0'; + } + + foundit = 0; + if (access (fname, 0) == 0) { + strcpy (path, fname); + foundit++; + } else { + if (os_sysfile (fname, path, SZ_PATHNAME) > 0) + foundit++; + } + + if (foundit) { + strcpy (absname=bp, vfn2osfn (path, 0)); + bp += strlen (absname) + 1; + if (bp - buffer >= SZ_BUFFER) + fatal ("Out of space for library names"); + if (debug > 1) + fprintf (stderr, "iraflib: %s -> %s\n", savename, absname); + return (absname); + } else if (dbg) { + dbg = 0; + goto again; + } else { + if (debug > 1) + fprintf (stderr, "iraflib: %s -> %s\n", savename, savename); + return (NULL); + } +} + + +/* PRINTARGS -- Echo a UNIX command on the standard error output. + */ +static void +printargs (char *cmd, char *arglist[], int nargs) +{ + int i; + + fputs (cmd, stderr); + for (i=1; i < nargs; i++) + fprintf (stderr, " %s", arglist[i]); + putc ('\n', stderr); + fflush (stderr); +} + + +/* XTOF -- Convert a ".x" file into a ".f" file, i.e., call up the preprocessor + * to translate an SPP file into Fortran. + */ +static void +xtof (char *file) +{ + static char xpp_path[SZ_PATHNAME+1], rpp_path[SZ_PATHNAME+1]; + char cmdbuf[SZ_CMDBUF], fname[SZ_FNAME]; +#if defined(LINUX64) || defined(MACH64) + char iraf_h[SZ_PATHNAME]; +#endif + + + lxfiles[nxfiles++] = file; + if (nxfiles > MAXFILE) + fatal ("too many files"); + + if (nfileargs > 1 || mkobject) { + fprintf (stderr, "%s:\n", file); + fflush (stderr); + } + + if (!xpp_path[0]) + if (os_sysfile (XPP, xpp_path, SZ_PATHNAME) <= 0) + strcpy (xpp_path, XPP); + + if (userincs) { + if (pkgenv) + sprintf (cmdbuf, "%s %s -A -R %s", xpp_path, pkgenv, file); + else + sprintf (cmdbuf, "%s -A -R %s", xpp_path, file); + } else { + if (pkgenv) + sprintf (cmdbuf, "%s %s -R %s", xpp_path, pkgenv, file); + else + sprintf (cmdbuf, "%s -R %s", xpp_path, file); + } + + + /* Include a custom 64-bit iraf.h file. + */ +#if defined(LINUX64) || defined(MACH64) + memset (iraf_h, 0, SZ_PATHNAME); + + if (os_sysfile ("iraf.h", iraf_h, SZ_PATHNAME) <= 0) + strcpy (iraf_h, "iraf.h"); + strcat (cmdbuf, " -h "); + strcat (cmdbuf, iraf_h); +#else + if (foreigndefs) { + strcat (cmdbuf, " -h "); + strcat (cmdbuf, foreign_defsfile); + } +#endif + + errflag |= sys (cmdbuf); + chdot (file, 'r'); + + strcpy (fname, file); + chdot (fname, 'f'); + + if (!rpp_path[0]) + if (os_sysfile (RPP, rpp_path, SZ_PATHNAME) <= 0) + strcpy (rpp_path, RPP); + sprintf (cmdbuf, "%s %s%s >%s", + rpp_path, dbgout ? "-g " : "", file, fname); + if (!(errflag & XPP_BADXFILE)) + errflag |= sys (cmdbuf); + + unlink (file); /* remove ".r" file */ + chdot (file, 'f'); /* change name to ".f" */ +} + + +/* GETEXTN -- Get a one letter extension from a file name (BPS 07.23.96) + */ +static int +getextn (char *fname) +{ + register char *ip, *dot; + int ch; + + for (ip=fname, dot=NULL; *ip != EOS; ip++) + if (*ip == '.') + dot = ip; + + if (dot == NULL || *(dot+2) != EOS) { + ch = EOS; + } else { + ch = *(dot+1); + } + + return (ch); +} + + +/* CHDOT -- Change the filename extension, i.e., the single character + * following the "." at the end of the filename, to the indicated character. + */ +static void +chdot (char *fname, char dotchar) +{ + char *p; + + p = fname; + while (*p++ != EOS) + ; + while (*--p != '.' && p >= fname) + ; + *(p+1) = dotchar; +} + + +/* RUN -- Send a command to UNIX and return the execution status to our + * caller at the completion of the command. + */ +static int +run (char *task, char *argv[]) +{ + int waitpid; + pid_t fork(); + char path[SZ_PATHNAME]; + + if ((waitpid = fork()) == 0) { + enbint (SIG_DFL); + + execvp (task, argv); /* use user PATH for search */ + strcpy (path, SYSBINDIR); + strcat (path, task); + execv (path, argv); /* look in SYSBINDIR */ + strcpy (path, LOCALBINDIR); + strcat (path, task); + execv (path, argv); /* look in LOCALBINDIR */ + + fatalstr ("Cannot execute %s", task); + } + + return (await (waitpid)); +} + + +/* + * Task execution and interrupt handling routines, + * taken with minor modifications the F77 driver. + */ + + +/* SYS -- Execute a general UNIX command passed as a string. The command may + * contain i/o redirection metacharacters. The full path of the command to + * be executed should be given (and always is in the case of XC). + */ +static int +sys (char *cmd) +{ + register char *ip; + char *argv[256]; + char *inname, *outname; + int append; + int waitpid; + int argc; + + if (debug) { + fprintf (stderr, "debug: %s\n", cmd); + fflush (stderr); + } + + inname = NULL; + outname = NULL; + append = NO; + argc = 0; + + /* Parse command string into argv array, inname, and outname. + */ + ip = cmd; + while (isspace (*ip)) + ++ip; + while (*ip) { + if (*ip == '<') + inname = ip+1; + else if (*ip == '>') { + if (ip[1] == '>') { + append = YES; + outname = ip+2; + } else { + append = NO; + outname = ip+1; + } + } else + argv[argc++] = ip; + while ( !isspace (*ip) && *ip != '\0' ) + ++ip; + if (*ip) { + *ip++ = '\0'; + while (isspace (*ip)) + ++ip; + } + } + + if (argc <= 0) /* no command */ + return (-1); + argv[argc] = 0; + + /* Execute the command. */ + if ((waitpid = fork()) == 0) { + if (inname) + freopen (inname, "r", stdin); + if (outname) + freopen (outname, (append ? "a" : "w"), stdout); + enbint (SIG_DFL); + + execv (argv[0], argv); + fatalstr ("Cannot execute %s", argv[0]); + } + + return (await (waitpid)); +} + + +/* DONE -- Called at process shutdown to cleanup. Primary action is to delete + * the intermediate Fortran files, unless the -F flag was given on the command + * line. + */ +static void +done (int k) +{ + static int recurs = NO; + + if (recurs == NO) { + recurs = YES; + if (!keepfort) + rmfiles(); + } + + ZZSTOP(); + exit (k); +} + + +/* ENBINT -- Post an exception handler function to be executed if any sort + * of interrupt occurs. + */ +static void +enbint (SIGFUNC handler) +{ + if (sig_int == 0) + signal (SIGINT, handler); + if (sig_quit == 0) + signal (SIGQUIT, handler); + if (sig_hup == 0) + signal (SIGHUP, handler); + if (sig_term == 0) + signal (SIGTERM, handler); +} + + +/* INTERRUPT -- Exception handler, called if an interrupt is received + * during compilation. + */ +static void +interrupt (void) +{ + done (2); +} + + +/* AWAIT -- Wait for an asynchronous child process to terminate. + */ +static int +await (int waitpid) +{ + int w, status; + + enbint (SIG_IGN); + while ((w = wait (&status)) != waitpid) + if (w == -1) + fatal ("bad wait code"); + enbint ((SIGFUNC)interrupt); + if (status & 0377) { + if (status != SIGINT) { + fprintf (stderr, "Termination code %d", status); + fflush (stderr); + } + done (2); + } + return (status>>8); +} + + +/* RMFILES -- Delete all of the ".f" intermediate Fortran files. + */ +static void +rmfiles (void) +{ + int i; + + for (i=0; i < nxfiles; i++) { + chdot (lxfiles[i], 'f'); + unlink (lxfiles[i]); + } +} + + +/* FATALSTR -- Fatal error with an sprintf format and one string argument. + */ +static void +fatalstr (char *s1, char *s2) +{ + char out[SZ_CMDBUF]; + + sprintf (out, s1, s2); + fatal (out); +} + + +/* FATAL -- A fatal error has occurred. Print error message and terminate + * process execution. + */ +static void +fatal (char *s) +{ + fprintf (stderr, "Fatal compiler error: %s\n", s); + fflush (stderr); + done (1); +} + + +/* ISV13 -- Test if we are using the version 1.3 Sun Fortran compiler. + * There is no simple, reliable way to do this. The heuristic used is + * to first locate the "f77" we will use, then see if there is a file + * named "f77-1.3*" in the same directory. + */ +static int +isv13 (void) +{ + static int v13 = -1; + struct dirent *dp; + char dir[SZ_PATHNAME]; + char *name; + DIR *dirp; + +return (0); +#ifdef SOLARIS + return (v13 = 0); +#else + + if (v13 != -1) + return (v13); + + if (findexe ("f77", dir) && (dirp = opendir(dir)) != NULL) { + while ((dp = readdir(dirp))) { + /* Actually, we don't want to be too picky about the + * version number of this won't work for future versions, + * so just match up to the version number. + */ + name = dp->d_name; + if (!strncmp (name, "f77-1.3", 4) && isdigit(name[4])) { + closedir (dirp); + return (v13 = 1); + } + } + closedir (dirp); + } + + return (v13 = 0); +#endif +} + + +/* FINDEXE -- Search for the named file and return the path if found, else + * NULL. If "dir" is non-NULL the directory in which the file resides is + * returned in the string buffer pointed to. The user's PATH is searched, + * followed by SYSBINDIR, then LOCALBINDIR. + */ +static char * +findexe ( + char *prog, /* file to search for */ + char *dir /* pointer to output string buf, or NULL */ +) +{ + register char *ip, *op; + static char path[SZ_PATHNAME]; + char dirpath[SZ_PATHNAME]; + char *dp = dir ? dir : dirpath; + char *pathp; + + /* Look for the program in the directories in the user's path. + */ + ip = pathp = os_getenv ("PATH"); + while (*ip) { + for (op=dp; *ip && (*op = *ip++) != ':'; op++) + ; + *op++ = '/'; + *op++ = EOS; + strcpy (path, dp); + strcat (path, prog); + if (access (path, 0) != -1) + return (path); + } + + /* Look in SYSBINDIR. */ + strcpy (dp, SYSBINDIR); + strcpy (path, dp); + strcat (path, prog); + + if (access (path, 0) != -1) { + static char envpath[8192]; + char *oldpath; + + /* Add SYSBINDIR to the user's path. This is required to + * use the V1.3 compiler. Note that this code should only be + * executed once, since the next time findexe is called the + * SYSBINDIR directory will be in the default path, above. + */ + if ((oldpath = pathp)) { + sprintf (envpath, "PATH=%s:%s", SYSBINDIR, oldpath); + putenv (envpath); + } + + return (path); + } + + /* Look in LOCALBINDIR. */ + strcpy (dp, LOCALBINDIR); + strcpy (path, dp); + strcat (path, prog); + if (access (path, 0) != -1) + return (path); + + /* Not found. */ + return (NULL); +} diff --git a/unix/boot/spp/xc.hlp b/unix/boot/spp/xc.hlp new file mode 100644 index 00000000..0e941b82 --- /dev/null +++ b/unix/boot/spp/xc.hlp @@ -0,0 +1,197 @@ +.help xc Oct89 softools +.ih +NAME +xc -- portable IRAF compile/link utility +.ih +USAGE +xc [flags] files +.ih +FLAGS +.ls 10 -a +To support VMS link options file. Next file is taken to be the VMS name +of a link options file. This is primarily for using long lists of files +or libraries and not for actual VMS Linker options, since XC adds continuation +characters where it believes it is appropriate. +.le +.ls 10 -C +Tells fortran to do array bound and other checking. +By default no checking is done. From DCL fortran usually +does array and overflow checking which is not used here. +.le +.ls 10 -c +Tells \fIxc\fR not to link, i.e., not to create an executable. +.le +.ls 10 -d +Causes debug messages to be printed during execution. +.le +.ls 10 -F, -f +Do not delete the Fortran translation of an SPP source file. +.le +.ls 10 -g +Generates debugging information and (for VMS), links in the debugger. +.le +.ls 10 -h +Causes the executable to be linked as a host program, i.e., without the +IRAF main and without searching the IRAF libraries, unless explicitly +referenced on the command line. Used to compile and link host (e.g., Fortran) +programs which may or may not reference the IRAF libraries. +.le +.ls 10 -i2 +Tells fortran to use I*2 by default. +.le +.ls 10 -i4 +Tells fortran to use I*4 by default. +.le +.ls 10 -l\fIlib\fR +This tells the linker which libraries besides the standard +ones to include. These must be either on the current +directory, or in an IRAF system library (lib$ or hlib$). +The library specification must be immediately after the option as in +"-lxtools". No other option may follow the 'l' option in the same +argument as in -lxtoolsO. +.le +.ls 10 -L +Creates a list file. VMS specific. +.le +.ls 10 -M, -m +Tells the linker to create a link map. +.le +.ls 10 -n +Not really supported under VMS since "normal" users +cannot install images. In Unix this is just a link +option to make a shareable image. +.le +.ls 10 -N +Same as -z for VMS. +.le +.ls 10 -Nh [filename] +This tells xpp that the foreign definitions in the +file specified should be used in preference to +standard include files. +.le +.ls 10 -o +This flag redirects the output of the compile if used in +conjunction with -c option or specifies where the executable +or object is to be placed. If not given the first file +name is used to obtain the name for the executable or +object. +.le +.ls 10 -O +Optimize object code produced; this is now the default, but this switch +is still provided for backwards compatibility. +.le +.ls 10 -p pkgname +Load the package environment for the named external package, e.g., +"xc -c -p noao file.x". If the same package is always specified +the environment variable or logical name PKGENV may be defined at the +host level to accomplish the same thing. The package name \fImust\fR +be specified when doing software development in an external or layered +package. +.le +.ls 10 -P +Check portability. This should be used all of the time in IRAF, +but the VMS C compiler forces the use of non-standard +constructs in some cases. Also <stdio.h> and <ctype.h> get +complaints for the above reason. This may be used and probably +should when working with Fortran due to Dec non-standard +extension. +.le +.ls 10 -q +Disable optimization. Opposite of -O. Object code will be optimized +by default. +.le +.ls 10 -s +Strips all symbols and debugging information. +.le +.ls 10 -S +Same as -s for VMS. +.le +.ls 10 -v +Verbose mode. Causes messages to be printed during execution telling +what the \fIxc\fR program is doing. +.le +.ls 10 -w +Suppress warnings. +.le +.ls 10 -X, -x +Compile and link for debugging. In VMS/IRAF, links in the VMS debugger +and symbols. +.le +.ls 10 -z +Create a non-shareable image (default). +.le +.ih +DESCRIPTION +XC is a machine independent utility for compiling and linking IRAF +tasks or files. The XC utility may also be used to compile and/or link +non-IRAF files and tasks. The VMS version of XC supports all of the +important flags except -D which VMS C doesn't support in any way. +It can be used to generate fortran from xpp or ratfor code, to compile any +number of files, and then link them if desired. XC accepts and maps IRAF +virtual filenames, but since it is a standalone bootstrap utility the +environment is not passed, hence logical directories cannot be used. + +The following extensions are supported by the VMS version of xc: +.x, .r, .f, .ftn, .for, .c, .mar, .s, .o, .obj, .a, .olb, .e, .exe. +It is suggested that everyone stick with the iraf virtual file name extensions. +These are : .x, .r, .f, .c, .s, .o, .a, .e. The mapping of these to their +VMS counterparts is: + +.ks +.nf + .x -> .x SPP code + .r -> .r Ratfor code + .f -> .for Fortran code + .c -> .c C code + .s -> .mar Macro assembler code + .o -> .obj Object module + .a -> .olb Library file + .e -> .exe Executable Image +.fi +.ke + + +XC is available both in the CL, via the foreign task interface, and as +a standalone DCL callable task. Usage is equivalent in either case. Upper +case flags must be quoted to be recognized (the upper case flags will be +done away with at some point). +.ih +EXAMPLES +Any upper case flags in the following examples must be doubly quoted in +the CL, singly quoted in VMS, to make it to XC without VMS mapping +everything to one case. Omit the "-x" flag on a UNIX system. + +1. Compile and link the source file "mytask.x" to produce the executable +"mytask.e". + + cl> xc mytask.x + +2. Translate the file "file.x" into Fortran. + + cl> xc -f file.x + +3. Compile but do not link "mytask.x" and the support file "util.x". + + cl> xc -c file.x util.x + +4. Now link these for debugging. + + cl> xc -x file.o util.o + +5. Link the same files without the VMS debug stuff, but link in the library +-ldeboor (the DeBoor spline routines) as well. + + cl> xc file.o util.o -ldeboor + +XC is often combined with \fImkpkg\fR to automatically maintain large packages +or libraries. +.ih +BUGS +The -S flag should generate assembler +output but does not presently do so in the VMS version. All case sensitive +switches should be done away with in both the UNIX and VMS versions of the +utility. +.ih +SEE ALSO +mkpkg, generic +.endhelp diff --git a/unix/boot/spp/xpp.h b/unix/boot/spp/xpp.h new file mode 100644 index 00000000..c240bf6a --- /dev/null +++ b/unix/boot/spp/xpp.h @@ -0,0 +1,12 @@ +/* XPP error codes. + */ +#define XPP_COMPERR 101 /* compiler error */ +#define XPP_BADXFILE 102 /* cannot open .x file */ +#define XPP_SYNTAX 104 /* language error */ + + +/* String type codes. + */ +#define STR_INLINE 0 +#define STR_DEFINE 1 +#define STR_DECL 2 diff --git a/unix/boot/spp/xpp/README b/unix/boot/spp/xpp/README new file mode 100644 index 00000000..6f5b7b9f --- /dev/null +++ b/unix/boot/spp/xpp/README @@ -0,0 +1,6 @@ +XPP -- First pass of the SPP preprocessor. + + This directory contains the Lex and C sources for the first pass of the +preprocessor for the IRAF SPP (subset preprocessor) language. XPP takes as +input an SPP source file and produces as output a text file which is further +processed by RPP (the second pass) to produce Fortran. diff --git a/unix/boot/spp/xpp/decl.c b/unix/boot/spp/xpp/decl.c new file mode 100644 index 00000000..b5c64774 --- /dev/null +++ b/unix/boot/spp/xpp/decl.c @@ -0,0 +1,565 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include <string.h> +#include "xpp.h" + +#define import_spp +#include <iraf.h> + +#ifndef SZ_SBUF +#define SZ_SBUF 4096 /* max chars in proc. decls. */ +#endif +#define SZ_TOKEN 63 /* max chars in a token */ +#define MAX_SYMBOLS 300 /* max symbol table entries */ +#define SPMAX (&sbuf[SZ_SBUF-1]) +#define UNDECL 0 + +/* + * DECL.C -- A package of routines for parsing argument lists and declarations + * and generating the Fortran (actually, RPP) declarations required to compile + * a procedure. The main functions of this package at present are to remove + * arbitrary limitations on the ordering of argument declarations imposed by + * Fortran, and to perform various compile time checks on all declarations. + * Specifically, we allow scalar arguments to be used to dimension array + * arguments before the scalar arguments are declared, and we check for + * multiple declarations of the same object. + * + * Package Externals: + * + * d_newproc (name, type) process procedure declaration + * d_declaration (typestr) process typed declaration statement + * d_codegen (fp) output declarations for sym table + * d_runtime (text) return any runtime initialization text + * + * *symbol = d_enter (symbol, dtype, flags) + * *symbol = d_lookup (symbol) + * + * The external procedures YY_INPUT() and YY_UNPUT() are called to get/putpack + * characters from the input. + */ + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ + +struct symbol { + char *s_name; /* symbol name */ + char *s_dimstr; /* dimension string if array */ + short s_dtype; /* datatype (0 until declared) */ + short s_flags; /* type flags */ +}; + +#define S_ARGUMENT 001 /* symbol is an argument */ +#define S_ARRAY 002 /* symbol is an array */ +#define S_FUNCTION 004 /* symbol is a function() */ +#define S_EXTERN 010 /* symbol is an external */ + +static char sbuf[SZ_SBUF+1]; /* string buffer */ +static char *nextch = sbuf; /* next location in sbuf */ +static char procname[SZ_FNAME+1]; /* procedure name */ +static int proctype; /* procedure type if function */ +static struct symbol sym[MAX_SYMBOLS]; /* symbol table */ +static int nsym = 0; /* number of symbols */ + +struct symbol *d_enter(); +struct symbol *d_lookup(); + +extern void error (int errcode, char *errmsg); +extern void xpp_warn (char *warnmsg); +extern int yy_input (void); +extern void yy_unput (char ch); + + +void d_newproc (char *name, int dtype); +int d_declaration (int dtype); +void d_codegen (register FILE *fp); +void d_runtime (char *text); +void d_makedecl (struct symbol *sp, FILE *fp); +struct symbol *d_enter (char *name, int dtype, int flags); +struct symbol *d_lookup (char *name); +void d_chksbuf (void); +int d_gettok (char *tokstr, int maxch); +void d_declfunc (struct symbol *sp, FILE *fp); + + + + +/* D_NEWPROC -- Process a procedure declaration. The name of the procedure + * is passed as the single argument. The input stream is left positioned + * with the ( of the argument list as the next token (if present). INPUT is + * called repeatedly to read the remainder of the declaration, which may span + * several lines. The symbol table is cleared whenever a new procedure + * declaration is started. + */ +void +d_newproc (name, dtype) +char *name; /* procedure name */ +int dtype; /* procedure type (0 if subr) */ +{ + register int token; + char tokstr[SZ_TOKEN+1]; + + + + /* Print procedure name to keep the user amused in case the file + * is large and the machine slow. + */ + fprintf (stderr, " %s:\n", name); + fflush (stderr); + + strncpy (procname, name, SZ_FNAME); + proctype = dtype; + nextch = sbuf; + nsym = 0; + + /* Check for null argument list. */ + if (d_gettok(tokstr,SZ_TOKEN) != '(') + return; + + /* Process the argument list. + */ + while ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') { + if (isalpha(token)) { + /* Enter argument name into the symbol table. + */ + if (d_lookup (tokstr) != NULL) { + char lbuf[200]; + sprintf (lbuf, "%s.%s multiply declared", + procname, tokstr); + xpp_warn (lbuf); + } else + d_enter (tokstr, UNDECL, S_ARGUMENT); + } else if (token == '\n') { + linenum[istkptr]++; + continue; + } else if (token == ',') { + continue; + } else + error (XPP_SYNTAX, "bad syntax in procedure argument list"); + } +} + + +/* D_DECLARATION -- Process a declaration statement. This is any statement + * of the form + * + * type obj1, obj2, ..., objn + * + * ignoring comments and newlines following commas. The recognized types are + * + * bool, char, short, int, long, real, double, complex, pointer, extern + * + * If "obj" is followed by "()" the function type bit is set. If followed + * by "[...]" the array bit is set and the dimension string is accumulated, + * converting [] into (), adding 1 for char arrays, etc. in the process. + * Each OBJ identifier is entered into the symbol table with its attributes. + */ +int +d_declaration (int dtype) +{ + register struct symbol *sp = NULL; + register char ch; + int token, ndim; + char tokstr[SZ_TOKEN+1]; + + while ((token = d_gettok(tokstr,SZ_TOKEN)) != '\n') { + if (isalpha(token)) { + +#ifdef CYGWIN + { if (strncmp ("procedure", tokstr, 9) == 0) { +/* + extern char *yytext; + pushcontext (PROCSTMT); + d_gettok (yytext, SZ_TOKEN-1); + d_newproc (yytext, dtype); +*/ + pushcontext (PROCSTMT); + d_gettok (tokstr, SZ_TOKEN-1); + d_newproc (tokstr, dtype); + return (1); + } + } +#endif + + /* Enter argument or variable name into the symbol table. + * If symbol is already in table it must be an argument + * or we have a multiple declaration. + */ + if ((sp = d_lookup (tokstr)) != NULL) { + if (dtype == XTY_EXTERN) + sp->s_flags |= S_EXTERN; + else if (sp->s_flags & S_ARGUMENT && sp->s_dtype == UNDECL) + sp->s_dtype = dtype; + else { + char lbuf[200]; + sprintf (lbuf, "%s.%s multiply declared", + procname, tokstr); + xpp_warn (lbuf); + } + } else + sp = d_enter (tokstr, dtype, 0); + + /* Check for trailing () or []. + */ + token = d_gettok (tokstr, SZ_TOKEN); + + switch (token) { + case ',': + case '\n': + yy_unput (token); + continue; + + case '(': + /* Function declaration. + */ + if ((token = d_gettok(tokstr,SZ_TOKEN)) != ')') { + yy_unput (token); + error (XPP_SYNTAX, + "missing right paren in function declaration"); + } + sp->s_flags |= S_FUNCTION; + continue; + + case '[': + /* Array declaration. Turn [] into (), add space for EOS + * if char array, set array bit for operand in symbol table. + */ + sp->s_dimstr = nextch; + *nextch++ = '('; + ndim = 1; + + while ((ch = yy_input()) != ']' && ch > 0) { + if (ch == '\n') { + yy_unput (ch); + error (XPP_SYNTAX, + "missing right bracket in array declaration"); + break; + } else if (ch == ',') { + /* Add one char for the EOS in the first axis of + * a multidimensional char array. + */ + if (ndim == 1 && dtype == TY_CHAR) + *nextch++ = '+', *nextch++ = '1'; + *nextch++ = ','; + ndim++; + } else if (ch == 'A') { + /* Turn [ARB] into [*] for array arguments. */ + if ((ch = yy_input()) == 'R') { + if ((ch = yy_input()) == 'B') { + *nextch++ = '*'; + ndim++; + if (!(sp->s_flags & S_ARGUMENT)) { + error (XPP_SYNTAX, + "local variable dimensioned ARB"); + break; + } + } else { + *nextch++ = 'A'; + *nextch++ = 'R'; + yy_unput (ch); + } + } else { + *nextch++ = 'A'; + yy_unput (ch); + } + } else + *nextch++ = ch; + } + + if (ndim == 1 && dtype == TY_CHAR) + *nextch++ = '+', *nextch++ = '1'; + + *nextch++ = ')'; + *nextch++ = '\0'; + d_chksbuf(); + + sp->s_flags |= S_ARRAY; + break; + + default: + error (XPP_SYNTAX, "declaration syntax error"); + } + + } else if (token == ',') { + /* Check for implied continuation on the next line. + */ + do { + ch = yy_input(); + } while (ch == ' ' || ch == '\t'); + + if (ch == '\n') + linenum[istkptr]++; + else + yy_unput (ch); + + } else if (sp && (sp->s_flags & S_ARGUMENT)) { + error (XPP_SYNTAX, "bad syntax in procedure argument list"); + } else + error (XPP_SYNTAX, "declaration syntax error"); + } + + yy_unput ('\n'); + + return (0); +} + + +/* D_CODEGEN -- Output the RPP declarations for all symbol table entries. + * Declare scalar arguments first, followed by array arguments, followed + * by nonarguments. + */ +void +d_codegen (fp) +register FILE *fp; +{ + register struct symbol *sp; + register struct symbol *top = &sym[nsym-1]; + extern char *type_decl[]; + int col; + + /* Declare the procedure itself. + */ + if (proctype) { + fputs (type_decl[proctype], fp); + fputs (" x$func ", fp); + } else + fputs ("x$subr ", fp); + + fputs (procname, fp); + fputs (" ", fp); + + /* Output the argument list. Keep track of the approximate line length + * and break line if it gets too long for the second pass. + */ + fputs ("(", fp); + col = strlen(procname) + 9; + + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) { + if (sp > sym) { + fputs (", ", fp); + col += 2; + } + col += strlen (sp->s_name); + if (col >= 78) { + fputs ("\n\t", fp); + col = strlen (sp->s_name) + 1; + } + fputs (sp->s_name, fp); + } + fputs (")\n", fp); + + /* Declare scalar arguments. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + if (!(sp->s_flags & S_ARRAY)) + d_makedecl (sp, fp); + + /* Declare vector arguments. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + if (sp->s_flags & S_ARRAY) + d_makedecl (sp, fp); + + /* Declare local variables and externals. */ + for (sp=sym; sp <= top; sp++) + if (sp->s_flags & S_ARGUMENT) + continue; + else if (sp->s_flags & S_FUNCTION) + d_declfunc (sp, fp); + else + d_makedecl (sp, fp); +} + + +/* D_RUNTIME -- Return any runtime procedure initialization statements, + * i.e., statements to be executed at runtime when a procedure is entered, + * in the given output buffer. + */ +void +d_runtime (char *text) +{ + /* For certain types of functions, ensure that the function value + * is initialized to a legal value, in case the procedure is exited + * without returning a value (e.g., during error processing). + */ + switch (proctype) { + case XTY_REAL: + case XTY_DOUBLE: + sprintf (text, "\t%s = 0\n", procname); + break; + default: + text[0] = EOS; + break; + } +} + + +/* D_MAKEDECL -- Output a single RPP symbol declaration. Each declaration + * is output on a separate line. + */ +void +d_makedecl (sp, fp) +register struct symbol *sp; /* symbol table entry */ +register FILE *fp; /* output file */ +{ + extern char *type_decl[]; + + if (sp->s_dtype != UNDECL) { + fputs (type_decl[sp->s_dtype], fp); + fputs ("\t", fp); + fputs (sp->s_name, fp); + if (sp->s_flags & S_ARRAY) + fputs (sp->s_dimstr, fp); + fputs ("\n", fp); + } + + if (sp->s_flags & S_EXTERN) { + fputs (type_decl[XTY_EXTERN], fp); + fputs ("\t", fp); + fputs (sp->s_name, fp); + fputs ("\n", fp); + } +} + + +/* D_ENTER -- Add a symbol to the symbol table. Return a pointer to the + * new symbol. + */ +struct symbol * +d_enter (name, dtype, flags) +char *name; /* symbol name */ +int dtype; /* data type code */ +int flags; /* flag bits */ +{ + register struct symbol *sp; + + + sp = &sym[nsym]; + nsym++; + if (nsym > MAX_SYMBOLS) + error (XPP_COMPERR, "too many declarations in procedure"); + + sp->s_name = strcpy (nextch, name); + nextch += strlen(name) + 1; + d_chksbuf(); + + sp->s_dimstr = NULL; + sp->s_dtype = dtype; + sp->s_flags = flags; + + return (sp); +} + + +/* D_LOOKUP -- Lookup a symbol in the symbol table. Return a pointer to the + * symbol table entry. + */ +struct symbol * +d_lookup (name) +char *name; /* symbol name */ +{ + register struct symbol *sp; + register struct symbol *top = &sym[nsym-1]; + + for (sp=sym; sp <= top; sp++) + if (sp->s_name[0] == name[0]) + if (strcmp (sp->s_name, name) == 0) + return (sp); + + return (NULL); +} + + +/* D_CHKSBUF -- Check for overflow on the string buffer. + */ +void +d_chksbuf() +{ + if (nextch > SPMAX) + error (XPP_COMPERR, "decl string buffer overflow"); +} + + +/* D_GETTOK -- Get the next token from the input stream. Return the integer + * value of the first character of the token as the function value. EOF + * is an error in this application, not a token. + */ +int +d_gettok (tokstr, maxch) +char *tokstr; /* receives token string */ +int maxch; /* max chars to token string */ +{ + register char *op = tokstr; + register int ch, n; + + + + /* Skip whitespace and comments to first char of next token. + */ + do { + ch = yy_input(); + } while (ch == ' ' || ch == '\t'); + + if (ch == '#') { + /* Skip a comment. + */ + while ((ch = yy_input()) != '\n' && ch > 0) + ; + } + + if (ch <= 0) + error (XPP_SYNTAX, "unexpected EOF"); + + *op++ = ch; + n = maxch - 1; + + if (isalpha (ch)) { + /* Identifer. + */ + while ((ch = yy_input()) > 0) + if (isalnum(ch) || ch == '_') { + *op++ = ch; + if (--n <= 0) + error (XPP_SYNTAX, "identifier too long"); + } else { + yy_unput (ch); + break; + } + + } else if (isdigit (ch)) { + /* Number. + */ + while ((ch = yy_input()) > 0) + if (isdigit(ch)) { + *op++ = ch; + if (--n <= 0) + error (XPP_SYNTAX, "number too long"); + } else { + yy_unput (ch); + break; + } + + } + + *op++ = '\0'; + if (ch <= 0) + error (XPP_SYNTAX, "unexpected EOF"); + + return (tokstr[0]); +} + + +/* D_DECLFUNC -- Declare a function. This module is provided to allow + * for any special treatment required for certain types of function + * declarations. + */ +void +d_declfunc (sp, fp) +register struct symbol *sp; +FILE *fp; +{ + d_makedecl (sp, fp); +} diff --git a/unix/boot/spp/xpp/lex.sed b/unix/boot/spp/xpp/lex.sed new file mode 100644 index 00000000..b0b35fd7 --- /dev/null +++ b/unix/boot/spp/xpp/lex.sed @@ -0,0 +1,9 @@ +/int nstr; extern int yyprevious;/a\ +if (yyin==NULL) yyin = stdin;\ +if (yyout==NULL) yyout = stdout; +/{stdin}/c\ +FILE *yyin, *yyout; +s/"stdio.h"/<stdio.h>/ +s/YYLMAX 200/YYLMAX 8192/ +s/static int input/int input/g +s/static void yyunput/void yyunput/g diff --git a/unix/boot/spp/xpp/lexyy.c b/unix/boot/spp/xpp/lexyy.c new file mode 100644 index 00000000..c79ba67d --- /dev/null +++ b/unix/boot/spp/xpp/lexyy.c @@ -0,0 +1,2932 @@ + +#line 3 "lex.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include <stdio.h> +#include <string.h> +#include <errno.h> +#include <stdlib.h> + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have <inttypes.h>. Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include <inttypes.h> +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +typedef uint64_t flex_uint64_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; +#endif /* ! C99 */ + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart(yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#define YY_BUF_SIZE 16384 +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern yy_size_t yyleng; + +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + /* Note: We specifically omit the test for yy_rule_can_match_eol because it requires + * access to the local variable yy_act. Since yyless() is a macro, it would break + * existing scanners that call yyless() from OUTSIDE yylex. + * One obvious solution it to make yy_act a global. I tried that, and saw + * a 5% performance hit in a non-yylineno scanner, because yy_act is + * normally declared as a register variable-- so it is not worth it. + */ + #define YY_LESS_LINENO(n) \ + do { \ + yy_size_t yyl;\ + for ( yyl = n; yyl < yyleng; ++yyl )\ + if ( yytext[yyl] == '\n' )\ + --yylineno;\ + }while(0) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + yy_size_t yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; +static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ +yy_size_t yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart (FILE *input_file ); +void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer (FILE *file,int size ); +void yy_delete_buffer (YY_BUFFER_STATE b ); +void yy_flush_buffer (YY_BUFFER_STATE b ); +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state (void ); + +static void yyensure_buffer_stack (void ); +static void yy_load_buffer_state (void ); +static void yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER yy_flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE yy_scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE yy_scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes (yyconst char *bytes,yy_size_t len ); + +void *yyalloc (yy_size_t ); +void *yyrealloc (void *,yy_size_t ); +void yyfree (void * ); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ + +typedef unsigned char YY_CHAR; + +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; + +typedef int yy_state_type; + +#define YY_FLEX_LEX_COMPAT +extern int yylineno; + +int yylineno = 1; + +extern char yytext[]; + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + yyleng = (yy_size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + if ( yyleng + (yy_more_offset) >= YYLMAX ) \ + YY_FATAL_ERROR( "token too large, exceeds YYLMAX" ); \ + yy_flex_strncpy( &yytext[(yy_more_offset)], (yytext_ptr), yyleng + 1 ); \ + yyleng += (yy_more_offset); \ + (yy_prev_more_offset) = (yy_more_offset); \ + (yy_more_offset) = 0; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 44 +#define YY_END_OF_BUFFER 45 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_acclist[275] = + { 0, + 45, 44, 43, 44, 41, 44, 25, 44, 44, 32, + 44, 44, 44, 44, 44, 44, 28, 44, 28, 44, + 38, 44, 39, 44, 28, 44, 28, 44, 36, 44, + 44, 37, 44, 44, 26, 44, 44, 44, 28, 44, + 28, 44, 28, 44, 28, 44, 28, 44, 28, 44, + 28, 44, 28, 44, 28, 44, 28, 44, 28, 44, + 34, 33, 40, 42, 30, 31, 30, 28, 28, 28, + 31, 28, 28, 35, 26, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + + 28, 28, 28, 28,16405, 28, 28, 28,16388, 28, + 28, 28, 28, 28, 28, 28, 29, 28, 28,16405, + 28, 28, 28, 28,16385, 28,16386, 28, 28,16407, + 28, 28, 8213, 8213, 28, 28, 28, 8196, 8196, 28, + 28,16389, 28, 28, 28,16390, 28, 28, 28,16397, + 29, 28, 28,16407,16397, 16, 28, 28, 28,16401, + 8193, 8193, 28, 8194, 8194, 28, 28, 8215, 8215, 28, + 28, 28, 28, 28, 8197, 8197, 28, 28, 28, 8198, + 8198, 28, 28,16387, 28, 8205, 8205, 28, 29, 28, + 28,16408,16401, 28, 28, 8209, 8209, 28, 28, 28, + + 16404, 28,16391, 28,16394, 28, 28, 28, 8195, 8195, + 28, 28,16406, 29, 28, 8216, 8216, 28,16404,16406, + 16404, 14, 28, 28, 28,16392, 8212, 8212, 8212, 28, + 8199, 8199, 28, 8202, 8202, 28, 28, 28,16393, 28, + 8214, 8214, 28, 28, 14, 28, 8200, 8200, 28, 27, + 8201, 8201, 28, 28, 28,16396, 15, 28, 28,16395, + 16396, 8204, 8204, 28, 15,16395, 19, 8203, 8204, 8203, + 8204, 28, 8203, 18 + } ; + +static yyconst flex_int16_t yy_accept[285] = + { 0, + 1, 1, 1, 2, 3, 5, 7, 9, 10, 12, + 13, 14, 15, 16, 17, 19, 21, 23, 25, 27, + 29, 31, 32, 34, 35, 37, 38, 39, 41, 43, + 45, 47, 49, 51, 53, 55, 57, 59, 61, 62, + 63, 64, 64, 65, 65, 65, 65, 65, 65, 66, + 67, 68, 69, 70, 72, 73, 74, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 76, 76, + 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 86, 87, 88, 89, 90, 91, 92, 93, 94, 94, + 94, 95, 96, 96, 96, 96, 96, 96, 96, 96, + + 96, 96, 96, 96, 97, 98, 99, 100, 101, 102, + 103, 104, 106, 107, 108, 110, 111, 112, 113, 114, + 115, 116, 117, 118, 119, 120, 120, 120, 120, 120, + 121, 121, 121, 121, 121, 121, 121, 122, 123, 124, + 126, 128, 129, 131, 132, 133, 134, 136, 137, 138, + 139, 141, 143, 144, 145, 147, 148, 149, 151, 152, + 152, 153, 154, 154, 154, 154, 155, 155, 155, 155, + 155, 156, 156, 157, 158, 159, 161, 162, 164, 165, + 167, 168, 169, 171, 172, 173, 174, 175, 176, 178, + 179, 180, 181, 183, 185, 186, 187, 189, 190, 190, + + 191, 193, 193, 193, 194, 194, 194, 194, 194, 194, + 195, 196, 197, 199, 200, 202, 204, 206, 207, 208, + 209, 210, 212, 214, 215, 216, 217, 219, 219, 219, + 220, 220, 220, 221, 222, 224, 225, 227, 228, 229, + 231, 232, 234, 235, 237, 238, 240, 241, 242, 244, + 245, 246, 246, 246, 246, 247, 248, 250, 250, 250, + 250, 251, 252, 254, 255, 257, 257, 257, 259, 259, + 262, 263, 265, 266, 267, 268, 268, 270, 273, 274, + 274, 274, 275, 275 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 4, 1, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 1, 14, 1, 15, 1, 16, 16, 16, + 16, 16, 16, 16, 17, 18, 18, 19, 20, 21, + 1, 1, 1, 1, 22, 23, 24, 25, 26, 22, + 27, 27, 28, 27, 27, 29, 30, 31, 27, 32, + 27, 33, 27, 34, 27, 27, 27, 35, 27, 27, + 36, 1, 37, 1, 38, 1, 39, 40, 41, 42, + + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 53, 54, 48, 55, 56, 57, 58, 48, 59, 60, + 48, 48, 61, 62, 63, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[64] = + { 0, + 1, 2, 3, 2, 1, 1, 4, 1, 1, 1, + 1, 1, 1, 1, 1, 5, 5, 5, 1, 1, + 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 1, 1, 5, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 1, 1, 1 + } ; + +static yyconst flex_int16_t yy_base[295] = + { 0, + 0, 62, 390, 1555, 1555, 1555, 1555, 380, 1555, 358, + 364, 65, 104, 58, 149, 0, 1555, 1555, 313, 308, + 1555, 304, 1555, 208, 0, 53, 319, 333, 29, 30, + 41, 26, 311, 309, 32, 318, 33, 321, 1555, 1555, + 1555, 104, 1555, 356, 0, 0, 84, 115, 0, 1555, + 1555, 0, 250, 0, 305, 310, 1555, 0, 314, 324, + 311, 50, 301, 300, 296, 293, 310, 0, 305, 302, + 337, 298, 289, 302, 289, 282, 294, 279, 294, 278, + 56, 282, 286, 279, 289, 274, 271, 253, 305, 119, + 266, 249, 298, 259, 246, 258, 259, 259, 246, 243, + + 241, 252, 245, 86, 247, 243, 237, 237, 251, 242, + 248, 310, 244, 236, 373, 239, 231, 241, 231, 225, + 232, 229, 123, 234, 230, 115, 223, 230, 216, 0, + 211, 219, 212, 209, 210, 202, 228, 222, 200, 436, + 499, 199, 562, 195, 196, 1555, 0, 190, 186, 1555, + 0, 625, 186, 198, 688, 183, 187, 751, 129, 137, + 196, 191, 210, 204, 182, 0, 181, 174, 188, 178, + 0, 177, 1555, 204, 193, 814, 1555, 0, 1555, 0, + 183, 1555, 0, 182, 181, 171, 180, 1555, 0, 178, + 178, 1555, 0, 877, 173, 1555, 0, 132, 138, 159, + + 940, 192, 180, 0, 170, 169, 166, 162, 163, 176, + 178, 1555, 0, 143, 1003, 1066, 1129, 158, 145, 141, + 1555, 0, 1192, 183, 142, 1555, 0, 167, 168, 97, + 150, 134, 0, 0, 0, 158, 1255, 1555, 155, 0, + 1555, 0, 1555, 0, 156, 1318, 133, 1555, 0, 138, + 1555, 136, 174, 108, 130, 1555, 0, 166, 178, 181, + 1555, 1555, 0, 109, 1381, 119, 82, 0, 185, 1444, + 1555, 0, 1555, 0, 1555, 81, 1555, 0, 1555, 64, + 36, 1555, 1555, 1504, 1510, 1516, 1522, 1526, 1530, 1534, + 1538, 1542, 1545, 1550 + + } ; + +static yyconst flex_int16_t yy_def[295] = + { 0, + 283, 1, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 13, 284, 284, 283, 283, 284, 284, + 283, 283, 283, 283, 285, 283, 283, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 283, 283, + 283, 283, 283, 286, 13, 14, 283, 14, 48, 283, + 283, 284, 284, 284, 284, 284, 283, 24, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 285, 283, 283, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 286, 283, + 284, 284, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 284, 284, 283, 284, 284, 283, 283, 283, 283, 287, + 283, 283, 283, 283, 283, 283, 284, 284, 284, 284, + 284, 284, 284, 284, 284, 283, 284, 284, 284, 283, + 284, 284, 284, 284, 284, 284, 284, 284, 283, 283, + 284, 284, 283, 283, 283, 288, 283, 283, 283, 283, + 289, 283, 283, 284, 284, 284, 283, 284, 283, 284, + 284, 283, 284, 284, 284, 284, 284, 283, 284, 284, + 284, 283, 284, 284, 284, 283, 284, 283, 283, 284, + + 284, 283, 283, 290, 283, 283, 283, 283, 283, 284, + 284, 283, 284, 284, 284, 284, 284, 284, 284, 284, + 283, 284, 284, 283, 284, 283, 284, 283, 283, 291, + 283, 283, 292, 291, 284, 284, 284, 283, 293, 284, + 283, 284, 283, 284, 284, 284, 284, 283, 284, 284, + 283, 283, 283, 283, 284, 283, 284, 293, 293, 283, + 283, 283, 284, 284, 284, 283, 283, 284, 283, 284, + 283, 284, 283, 294, 283, 283, 283, 284, 283, 283, + 283, 283, 0, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283 + + } ; + +static yyconst flex_int16_t yy_nxt[1619] = + { 0, + 4, 4, 5, 4, 6, 7, 4, 4, 8, 9, + 10, 4, 11, 12, 4, 13, 13, 14, 4, 12, + 4, 15, 15, 15, 15, 15, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 17, 18, 4, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 19, 16, 20, 16, 16, 16, 16, + 21, 22, 23, 24, 40, 24, 42, 43, 42, 25, + 44, 72, 26, 46, 46, 74, 27, 79, 86, 76, + 48, 73, 75, 77, 83, 80, 84, 90, 95, 87, + 282, 56, 96, 78, 69, 28, 114, 283, 239, 90, + + 239, 29, 30, 31, 32, 42, 43, 42, 33, 44, + 137, 34, 115, 138, 281, 35, 36, 37, 38, 45, + 45, 46, 47, 280, 274, 48, 49, 48, 48, 48, + 48, 48, 48, 283, 123, 123, 123, 159, 50, 163, + 199, 160, 164, 51, 198, 198, 198, 198, 198, 198, + 273, 270, 199, 224, 224, 224, 258, 260, 258, 260, + 261, 268, 267, 50, 53, 53, 53, 258, 266, 258, + 53, 53, 53, 53, 53, 260, 261, 260, 261, 269, + 265, 269, 260, 54, 260, 261, 269, 264, 269, 275, + 255, 254, 253, 252, 261, 251, 250, 159, 247, 246, + + 245, 261, 237, 236, 235, 234, 233, 232, 54, 58, + 231, 58, 230, 229, 276, 228, 225, 223, 59, 220, + 219, 218, 217, 216, 215, 214, 211, 210, 209, 208, + 207, 206, 205, 204, 203, 202, 201, 200, 195, 194, + 191, 60, 190, 187, 186, 185, 184, 61, 181, 62, + 63, 176, 175, 174, 64, 173, 172, 171, 170, 169, + 168, 65, 167, 66, 67, 53, 53, 53, 166, 165, + 162, 53, 53, 53, 53, 53, 161, 158, 157, 156, + 155, 154, 153, 152, 54, 149, 148, 145, 144, 143, + 142, 141, 140, 139, 136, 135, 134, 133, 132, 131, + + 130, 129, 128, 127, 126, 125, 124, 43, 122, 54, + 146, 146, 146, 146, 146, 146, 147, 146, 146, 146, + 146, 146, 146, 146, 146, 121, 120, 119, 146, 146, + 146, 118, 117, 116, 113, 112, 111, 110, 109, 108, + 107, 106, 105, 104, 103, 146, 146, 102, 101, 100, + 99, 98, 97, 94, 93, 69, 92, 91, 43, 88, + 85, 82, 81, 71, 70, 57, 56, 55, 41, 40, + 146, 146, 146, 150, 150, 150, 150, 150, 150, 151, + 150, 150, 150, 150, 150, 150, 150, 150, 39, 283, + 283, 150, 150, 150, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 150, 150, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 150, 150, 150, 177, 177, 177, 177, + 177, 177, 178, 177, 177, 177, 177, 177, 177, 177, + 177, 283, 283, 283, 177, 177, 177, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 177, 177, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 177, 177, 177, 179, + + 179, 179, 179, 179, 179, 180, 179, 179, 179, 179, + 179, 179, 179, 179, 283, 283, 283, 179, 179, 179, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 179, 179, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 179, + 179, 179, 182, 182, 182, 182, 182, 182, 183, 182, + 182, 182, 182, 182, 182, 182, 182, 283, 283, 283, + 182, 182, 182, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 182, 182, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 182, 182, 182, 188, 188, 188, 188, 188, + 188, 189, 188, 188, 188, 188, 188, 188, 188, 188, + 283, 283, 283, 188, 188, 188, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 188, 188, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 188, 188, 188, 192, 192, + 192, 192, 192, 192, 193, 192, 192, 192, 192, 192, + + 192, 192, 192, 283, 283, 283, 192, 192, 192, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 192, 192, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 192, 192, + 192, 196, 196, 196, 196, 196, 196, 197, 196, 196, + 196, 196, 196, 196, 196, 196, 283, 283, 283, 196, + 196, 196, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 196, 196, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 196, 196, 196, 212, 212, 212, 212, 212, 212, + 213, 212, 212, 212, 212, 212, 212, 212, 212, 283, + 283, 283, 212, 212, 212, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 212, + 212, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 212, 212, 212, 221, 221, 221, + 221, 221, 221, 222, 221, 221, 221, 221, 221, 221, + 221, 221, 283, 283, 283, 221, 221, 221, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 221, 221, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 221, 221, 221, + 226, 226, 226, 226, 226, 226, 227, 226, 226, 226, + 226, 226, 226, 226, 226, 283, 283, 283, 226, 226, + 226, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 226, 226, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 226, 226, 226, 238, 239, 238, 239, 238, 238, 240, + 238, 238, 238, 238, 238, 238, 238, 238, 283, 283, + 283, 238, 238, 238, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 238, 238, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 238, 238, 238, 241, 241, 241, 241, + 241, 241, 242, 241, 241, 241, 241, 241, 241, 241, + 241, 283, 283, 283, 241, 241, 241, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 241, 241, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 241, 241, 241, 243, + 243, 243, 243, 243, 243, 244, 243, 243, 243, 243, + 243, 243, 243, 243, 283, 283, 283, 243, 243, 243, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 243, 243, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 243, + 243, 243, 248, 248, 248, 248, 248, 248, 249, 248, + + 248, 248, 248, 248, 248, 248, 248, 283, 283, 283, + 248, 248, 248, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 248, 248, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 248, 248, 248, 256, 256, 256, 256, 256, + 256, 257, 256, 256, 256, 256, 256, 256, 256, 256, + 283, 283, 283, 256, 256, 256, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 256, 256, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 256, 256, 256, 262, 262, + 262, 262, 262, 262, 263, 262, 262, 262, 262, 262, + 262, 262, 262, 283, 283, 283, 262, 262, 262, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 262, 262, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 262, 262, + 262, 271, 271, 271, 271, 271, 271, 272, 271, 271, + 271, 271, 271, 271, 271, 271, 283, 283, 283, 271, + + 271, 271, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 271, 271, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 271, 271, 271, 277, 277, 277, 277, 277, 277, + 278, 277, 277, 277, 277, 277, 277, 277, 277, 283, + 283, 283, 277, 277, 277, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 277, + 277, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 277, 277, 277, 52, 52, 52, + 68, 68, 283, 68, 68, 68, 89, 89, 89, 89, + 89, 89, 146, 146, 146, 146, 182, 182, 182, 182, + 196, 196, 196, 196, 212, 212, 212, 212, 238, 238, + 238, 238, 248, 248, 248, 248, 259, 283, 283, 259, + 279, 279, 279, 279, 3, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283 + } ; + +static yyconst flex_int16_t yy_chk[1619] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 2, 26, 2, 12, 12, 12, 2, + 12, 29, 2, 14, 14, 30, 2, 32, 37, 31, + 14, 29, 30, 31, 35, 32, 35, 47, 62, 37, + 281, 37, 62, 31, 26, 2, 81, 14, 230, 47, + + 230, 2, 2, 2, 2, 42, 42, 42, 2, 42, + 104, 2, 81, 104, 280, 2, 2, 2, 2, 13, + 13, 13, 13, 276, 267, 13, 13, 13, 13, 13, + 48, 48, 48, 48, 90, 90, 90, 123, 13, 126, + 160, 123, 126, 13, 159, 159, 159, 198, 198, 198, + 266, 264, 160, 199, 199, 199, 239, 245, 239, 245, + 245, 255, 254, 13, 15, 15, 15, 258, 252, 258, + 15, 15, 15, 15, 15, 253, 245, 253, 253, 259, + 250, 259, 260, 15, 260, 260, 269, 247, 269, 269, + 236, 232, 231, 229, 253, 228, 225, 224, 220, 219, + + 218, 260, 214, 211, 210, 209, 208, 207, 15, 24, + 206, 24, 205, 203, 269, 202, 200, 195, 24, 191, + 190, 187, 186, 185, 184, 181, 175, 174, 172, 170, + 169, 168, 167, 165, 164, 163, 162, 161, 157, 156, + 154, 24, 153, 149, 148, 145, 144, 24, 142, 24, + 24, 139, 138, 137, 24, 136, 135, 134, 133, 132, + 131, 24, 129, 24, 24, 53, 53, 53, 128, 127, + 125, 53, 53, 53, 53, 53, 124, 122, 121, 120, + 119, 118, 117, 116, 53, 114, 113, 111, 110, 109, + 108, 107, 106, 105, 103, 102, 101, 100, 99, 98, + + 97, 96, 95, 94, 93, 92, 91, 89, 88, 53, + 112, 112, 112, 112, 112, 112, 112, 112, 112, 112, + 112, 112, 112, 112, 112, 87, 86, 85, 112, 112, + 112, 84, 83, 82, 80, 79, 78, 77, 76, 75, + 74, 73, 72, 71, 70, 112, 112, 69, 67, 66, + 65, 64, 63, 61, 60, 59, 56, 55, 44, 38, + 36, 34, 33, 28, 27, 22, 20, 19, 11, 10, + 112, 112, 112, 115, 115, 115, 115, 115, 115, 115, + 115, 115, 115, 115, 115, 115, 115, 115, 8, 3, + 0, 115, 115, 115, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 115, 115, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 115, 115, 115, 140, 140, 140, 140, + 140, 140, 140, 140, 140, 140, 140, 140, 140, 140, + 140, 0, 0, 0, 140, 140, 140, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 140, 140, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 140, 140, 140, 141, + + 141, 141, 141, 141, 141, 141, 141, 141, 141, 141, + 141, 141, 141, 141, 0, 0, 0, 141, 141, 141, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 141, 141, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 141, + 141, 141, 143, 143, 143, 143, 143, 143, 143, 143, + 143, 143, 143, 143, 143, 143, 143, 0, 0, 0, + 143, 143, 143, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 143, 143, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 143, 143, 143, 152, 152, 152, 152, 152, + 152, 152, 152, 152, 152, 152, 152, 152, 152, 152, + 0, 0, 0, 152, 152, 152, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 152, 152, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 152, 152, 152, 155, 155, + 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, + + 155, 155, 155, 0, 0, 0, 155, 155, 155, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 155, 155, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 155, 155, + 155, 158, 158, 158, 158, 158, 158, 158, 158, 158, + 158, 158, 158, 158, 158, 158, 0, 0, 0, 158, + 158, 158, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 158, 158, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 158, 158, 158, 176, 176, 176, 176, 176, 176, + 176, 176, 176, 176, 176, 176, 176, 176, 176, 0, + 0, 0, 176, 176, 176, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 176, + 176, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 176, 176, 176, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 194, 0, 0, 0, 194, 194, 194, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 194, 194, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 194, 194, 194, + 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, + 201, 201, 201, 201, 201, 0, 0, 0, 201, 201, + 201, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 201, 201, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 201, 201, 201, 215, 215, 215, 215, 215, 215, 215, + 215, 215, 215, 215, 215, 215, 215, 215, 0, 0, + 0, 215, 215, 215, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 215, 215, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 215, 215, 215, 216, 216, 216, 216, + 216, 216, 216, 216, 216, 216, 216, 216, 216, 216, + 216, 0, 0, 0, 216, 216, 216, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 216, 216, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 216, 216, 216, 217, + 217, 217, 217, 217, 217, 217, 217, 217, 217, 217, + 217, 217, 217, 217, 0, 0, 0, 217, 217, 217, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 217, 217, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 217, + 217, 217, 223, 223, 223, 223, 223, 223, 223, 223, + + 223, 223, 223, 223, 223, 223, 223, 0, 0, 0, + 223, 223, 223, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 223, 223, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 223, 223, 223, 237, 237, 237, 237, 237, + 237, 237, 237, 237, 237, 237, 237, 237, 237, 237, + 0, 0, 0, 237, 237, 237, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 237, 237, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 237, 237, 237, 246, 246, + 246, 246, 246, 246, 246, 246, 246, 246, 246, 246, + 246, 246, 246, 0, 0, 0, 246, 246, 246, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 246, 246, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 246, 246, + 246, 265, 265, 265, 265, 265, 265, 265, 265, 265, + 265, 265, 265, 265, 265, 265, 0, 0, 0, 265, + + 265, 265, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 265, 265, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 265, 265, 265, 270, 270, 270, 270, 270, 270, + 270, 270, 270, 270, 270, 270, 270, 270, 270, 0, + 0, 0, 270, 270, 270, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 270, + 270, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + + 0, 0, 0, 0, 270, 270, 270, 284, 284, 284, + 285, 285, 0, 285, 285, 285, 286, 286, 286, 286, + 286, 286, 287, 287, 287, 287, 288, 288, 288, 288, + 289, 289, 289, 289, 290, 290, 290, 290, 291, 291, + 291, 291, 292, 292, 292, 292, 293, 0, 0, 293, + 294, 294, 294, 294, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + + 283, 283, 283, 283, 283, 283, 283, 283, 283, 283, + 283, 283, 283, 283, 283, 283, 283, 283 + } ; + +/* Table of booleans, true if rule could match eol. */ +static yyconst flex_int32_t yy_rule_can_match_eol[45] = + { 0, +1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0, 0, + 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 1, 0, }; + +extern int yy_flex_debug; +int yy_flex_debug = 0; + +static yy_state_type *yy_state_buf=0, *yy_state_ptr=0; +static char *yy_full_match; +static int yy_lp; +static int yy_looking_for_trail_begin = 0; +static int yy_full_lp; +static int *yy_full_state; +#define YY_TRAILING_MASK 0x2000 +#define YY_TRAILING_HEAD_MASK 0x4000 +#define REJECT \ +{ \ +*yy_cp = (yy_hold_char); /* undo effects of setting up yytext */ \ +yy_cp = (yy_full_match); /* restore poss. backed-over text */ \ +(yy_lp) = (yy_full_lp); /* restore orig. accepting pos. */ \ +(yy_state_ptr) = (yy_full_state); /* restore orig. state */ \ +yy_current_state = *(yy_state_ptr); /* restore curr. state */ \ +++(yy_lp); \ +goto find_rule; \ +} + +static int yy_more_offset = 0; +static int yy_prev_more_offset = 0; +#define yymore() ((yy_more_offset) = yy_flex_strlen( yytext )) +#define YY_NEED_STRLEN +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET \ + { \ + (yy_more_offset) = (yy_prev_more_offset); \ + yyleng -= (yy_more_offset); \ + } +#ifndef YYLMAX +#define YYLMAX 8192 +#endif + +char yytext[YYLMAX]; +char *yytext_ptr; +#line 1 "xpp.l" +#line 2 "xpp.l" + +#include <stdio.h> +#include <ctype.h> +#include "xpp.h" +#include "../../bootProto.h" +#include "xppProto.h" + +#define import_spp +#include <iraf.h> + + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +#ifdef YYLMAX +#undef YYLMAX +#endif +#define YYLMAX YY_BUF_SIZE + +YY_BUFFER_STATE include_stack[MAX_INCLUDE]; + + +extern FILE *istk[]; +extern char fname[MAX_INCLUDE][SZ_PATHNAME]; +extern char *machdefs[]; +extern int hbindefs, foreigndefs; + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +extern int ntasks; +static int dtype; /* set if typed procedure */ + +extern char *vfn2osfn(); +extern void skipnl (void); + + +void typespec (int typecode); +void process_task_statement (void); + +void do_include (void); +int yywrap (void); +int yy_input (void); +void yy_unput (char ch); + + +#line 1053 "lex.yy.c" + +#define INITIAL 0 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include <unistd.h> +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy (void ); + +int yyget_debug (void ); + +void yyset_debug (int debug_flag ); + +YY_EXTRA_TYPE yyget_extra (void ); + +void yyset_extra (YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in (void ); + +void yyset_in (FILE * in_str ); + +FILE *yyget_out (void ); + +void yyset_out (FILE * out_str ); + +yy_size_t yyget_leng (void ); + +char *yyget_text (void ); + +int yyget_lineno (void ); + +void yyset_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap (void ); +#else +extern int yywrap (void ); +#endif +#endif + + void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + yy_size_t n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, yyin))==0 && ferror(yyin)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(yyin); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + if ( yyleng > 0 ) \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = \ + (yytext[yyleng - 1] == '\n'); \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 79 "xpp.l" + + +#line 1241 "lex.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + /* Create the reject buffer large enough to save one state per allowed character. */ + if ( ! (yy_state_buf) ) + (yy_state_buf) = (yy_state_type *)yyalloc(YY_STATE_BUF_SIZE ); + if ( ! (yy_state_buf) ) + YY_FATAL_ERROR( "out of dynamic memory in yylex()" ); + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of yytext. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + *(yy_state_ptr)++ = yy_current_state; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 1555 ); + +yy_find_action: + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; +goto find_rule; /* Shut up GCC warning -Wall */ +find_rule: /* we branch to this label when backing up */ + for ( ; ; ) /* until we find what rule we matched */ + { + if ( (yy_lp) && (yy_lp) < yy_accept[yy_current_state + 1] ) + { + yy_act = yy_acclist[(yy_lp)]; + if ( yy_act & YY_TRAILING_HEAD_MASK || + (yy_looking_for_trail_begin) ) + { + if ( yy_act == (yy_looking_for_trail_begin) ) + { + (yy_looking_for_trail_begin) = 0; + yy_act &= ~YY_TRAILING_HEAD_MASK; + break; + } + } + else if ( yy_act & YY_TRAILING_MASK ) + { + (yy_looking_for_trail_begin) = yy_act & ~YY_TRAILING_MASK; + (yy_looking_for_trail_begin) |= YY_TRAILING_HEAD_MASK; + (yy_full_match) = yy_cp; + (yy_full_state) = (yy_state_ptr); + (yy_full_lp) = (yy_lp); + } + else + { + (yy_full_match) = yy_cp; + (yy_full_state) = (yy_state_ptr); + (yy_full_lp) = (yy_lp); + break; + } + ++(yy_lp); + goto find_rule; + } + --yy_cp; + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + if ( yy_act != YY_END_OF_BUFFER && yy_rule_can_match_eol[yy_act] ) + { + yy_size_t yyl; + for ( yyl = (yy_prev_more_offset); yyl < yyleng; ++yyl ) + if ( yytext[yyl] == '\n' ) + + yylineno++; +; + } + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ +case 1: +/* rule 1 can match eol */ +YY_RULE_SETUP +#line 81 "xpp.l" +typespec (XTY_BOOL); + YY_BREAK +case 2: +/* rule 2 can match eol */ +YY_RULE_SETUP +#line 82 "xpp.l" +typespec (XTY_CHAR); + YY_BREAK +case 3: +/* rule 3 can match eol */ +YY_RULE_SETUP +#line 83 "xpp.l" +typespec (XTY_SHORT); + YY_BREAK +case 4: +/* rule 4 can match eol */ +YY_RULE_SETUP +#line 84 "xpp.l" +typespec (XTY_INT); + YY_BREAK +case 5: +/* rule 5 can match eol */ +YY_RULE_SETUP +#line 85 "xpp.l" +typespec (XTY_LONG); + YY_BREAK +case 6: +/* rule 6 can match eol */ +YY_RULE_SETUP +#line 86 "xpp.l" +typespec (XTY_REAL); + YY_BREAK +case 7: +/* rule 7 can match eol */ +YY_RULE_SETUP +#line 87 "xpp.l" +typespec (XTY_DOUBLE); + YY_BREAK +case 8: +/* rule 8 can match eol */ +YY_RULE_SETUP +#line 88 "xpp.l" +typespec (XTY_COMPLEX); + YY_BREAK +case 9: +/* rule 9 can match eol */ +YY_RULE_SETUP +#line 89 "xpp.l" +typespec (XTY_POINTER); + YY_BREAK +case 10: +/* rule 10 can match eol */ +YY_RULE_SETUP +#line 90 "xpp.l" +typespec (XTY_EXTERN); + YY_BREAK +case 11: +/* rule 11 can match eol */ +YY_RULE_SETUP +#line 92 "xpp.l" +{ + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + YY_BREAK +case 12: +/* rule 12 can match eol */ +YY_RULE_SETUP +#line 99 "xpp.l" +{ + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + setline(); + } + YY_BREAK +case 13: +/* rule 13 can match eol */ +YY_RULE_SETUP +#line 107 "xpp.l" +{ if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 114 "xpp.l" +put_dictionary(); + YY_BREAK +case 15: +YY_RULE_SETUP +#line 115 "xpp.l" +put_interpreter(); + YY_BREAK +case 16: +YY_RULE_SETUP +#line 116 "xpp.l" +{ + skip_helpblock(); + setline(); + } + YY_BREAK +case 17: +/* rule 17 can match eol */ +YY_RULE_SETUP +#line 120 "xpp.l" +{ + begin_code(); + setline(); + } + YY_BREAK +case 18: +YY_RULE_SETUP +#line 124 "xpp.l" +{ + macro_redef(); + setline(); + } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 128 "xpp.l" +{ + str_enter(); + } + YY_BREAK +case 20: +/* rule 20 can match eol */ +YY_RULE_SETUP +#line 131 "xpp.l" +{ + pushcontext (DEFSTMT); + ECHO; + } + YY_BREAK +case 21: +/* rule 21 can match eol */ +YY_RULE_SETUP +#line 135 "xpp.l" +{ + end_code(); + setline(); + } + YY_BREAK +case 22: +/* rule 22 can match eol */ +YY_RULE_SETUP +#line 139 "xpp.l" +{ + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } + YY_BREAK +case 23: +/* rule 23 can match eol */ +YY_RULE_SETUP +#line 143 "xpp.l" +{ + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + YY_BREAK +case 24: +/* rule 24 can match eol */ +YY_RULE_SETUP +#line 149 "xpp.l" +{ + ECHO; + if (context & BODY) + nswitch++; + } + YY_BREAK +case 25: +YY_RULE_SETUP +#line 155 "xpp.l" +skipnl(); + YY_BREAK +case 26: +YY_RULE_SETUP +#line 156 "xpp.l" +ECHO; + YY_BREAK +case 27: +YY_RULE_SETUP +#line 158 "xpp.l" +do_include(); + YY_BREAK +case 28: +YY_RULE_SETUP +#line 160 "xpp.l" +mapident(); + YY_BREAK +case 29: +YY_RULE_SETUP +#line 162 "xpp.l" +hms (yytext); + YY_BREAK +case 30: +YY_RULE_SETUP +#line 163 "xpp.l" +int_constant (yytext, OCTAL); + YY_BREAK +case 31: +YY_RULE_SETUP +#line 164 "xpp.l" +int_constant (yytext, HEX); + YY_BREAK +case 32: +YY_RULE_SETUP +#line 165 "xpp.l" +int_constant (yytext, CHARCON); + YY_BREAK +case 33: +YY_RULE_SETUP +#line 167 "xpp.l" +{ + if (context & (BODY|PROCSTMT)) + ECHO; + } + YY_BREAK +case 34: +YY_RULE_SETUP +#line 172 "xpp.l" +output ('&'); + YY_BREAK +case 35: +YY_RULE_SETUP +#line 173 "xpp.l" +output ('|'); + YY_BREAK +case 36: +YY_RULE_SETUP +#line 175 "xpp.l" +{ + ECHO; + nbrace++; + } + YY_BREAK +case 37: +YY_RULE_SETUP +#line 179 "xpp.l" +{ + ECHO; + nbrace--; + } + YY_BREAK +case 38: +YY_RULE_SETUP +#line 183 "xpp.l" +output ('('); + YY_BREAK +case 39: +YY_RULE_SETUP +#line 184 "xpp.l" +output (')'); + YY_BREAK +case 40: +YY_RULE_SETUP +#line 186 "xpp.l" +do_hollerith(); + YY_BREAK +case 41: +YY_RULE_SETUP +#line 188 "xpp.l" +{ + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + YY_BREAK +case 42: +/* rule 42 can match eol */ +YY_RULE_SETUP +#line 195 "xpp.l" +{ + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + YY_BREAK +case 43: +/* rule 43 can match eol */ +YY_RULE_SETUP +#line 203 "xpp.l" +{ + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + YY_BREAK +case 44: +YY_RULE_SETUP +#line 211 "xpp.l" +ECHO; + YY_BREAK +#line 1680 "lex.yy.c" + case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( yywrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of yylex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + yy_size_t num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart(yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + yy_current_state += YY_AT_BOL(); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + *(yy_state_ptr)++ = yy_current_state; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + + register YY_CHAR yy_c = 1; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 284 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 283); + if ( ! yy_is_jam ) + *(yy_state_ptr)++ = yy_current_state; + + return yy_is_jam ? 0 : yy_current_state; +} + + void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up yytext */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register yy_size_t number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + if ( c == '\n' ){ + --yylineno; + } + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart(yyin ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve yytext */ + (yy_hold_char) = *++(yy_c_buf_p); + + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = (c == '\n'); + if ( YY_CURRENT_BUFFER_LVALUE->yy_at_bol ) + + yylineno++; +; + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void yyrestart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_init_buffer(YY_CURRENT_BUFFER,input_file ); + yy_load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * yypop_buffer_state(); + * yypush_buffer_state(new_buffer); + */ + yyensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + yy_load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void yy_load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yyalloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with yy_create_buffer() + * + */ + void yy_delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yyfree((void *) b->yy_ch_buf ); + + yyfree((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a yyrestart() or at EOF. + */ + static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + yy_flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then yy_init_buffer was _probably_ + * called from yyrestart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void yy_flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + yy_load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + yyensure_buffer_stack(); + + /* This block is copied from yy_switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from yy_switch_to_buffer. */ + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void yypop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void yyensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to yylex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * yy_scan_bytes() instead. + */ +YY_BUFFER_STATE yy_scan_string (yyconst char * yystr ) +{ + + return yy_scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to yylex() will + * scan from a @e copy of @a bytes. + * @param bytes the byte buffer to scan + * @param len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n, i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) yyalloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + yytext[yyleng] = (yy_hold_char); \ + (yy_c_buf_p) = yytext + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + yyleng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int yyget_lineno (void) +{ + + return yylineno; +} + +/** Get the input stream. + * + */ +FILE *yyget_in (void) +{ + return yyin; +} + +/** Get the output stream. + * + */ +FILE *yyget_out (void) +{ + return yyout; +} + +/** Get the length of the current token. + * + */ +yy_size_t yyget_leng (void) +{ + return yyleng; +} + +/** Get the current token. + * + */ + +char *yyget_text (void) +{ + return yytext; +} + +/** Set the current line number. + * @param line_number + * + */ +void yyset_lineno (int line_number ) +{ + + yylineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see yy_switch_to_buffer + */ +void yyset_in (FILE * in_str ) +{ + yyin = in_str ; +} + +void yyset_out (FILE * out_str ) +{ + yyout = out_str ; +} + +int yyget_debug (void) +{ + return yy_flex_debug; +} + +void yyset_debug (int bdebug ) +{ + yy_flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from yylex_destroy(), so don't allocate here. + */ + + /* We do not touch yylineno unless the option is enabled. */ + yylineno = 1; + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + + (yy_state_buf) = 0; + (yy_state_ptr) = 0; + (yy_full_match) = 0; + (yy_lp) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + yyin = stdin; + yyout = stdout; +#else + yyin = (FILE *) 0; + yyout = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * yylex_init() + */ + return 0; +} + +/* yylex_destroy is for both reentrant and non-reentrant scanners. */ +int yylex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + yypop_buffer_state(); + } + + /* Destroy the stack itself. */ + yyfree((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + yyfree ( (yy_state_buf) ); + (yy_state_buf) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * yylex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *yyalloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *yyrealloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void yyfree (void * ptr ) +{ + free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 211 "xpp.l" + + + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +void +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} + + + +/* PROCESS_TASK_STATEMENT -- Parse the TASK statement. The task statement + * is replaced by the "sys_runtask" procedure (sysruk), which is called by + * the IRAF main to run a task, or to print the dictionary (cmd "?"). + * The source for the basic sys_runtask procedure is in "lib$sysruk.x". + * We process the task statement into some internal tables, then open the + * sysruk.x file as an include file. Special macros therein are + * replaced by the taskname dictionary as processing continues. + */ +void +process_task_statement() +{ + char ch; + + if (ntasks > 0) { /* only one task statement permitted */ + error (XPP_SYNTAX, "Only one TASK statement permitted per file"); + return; + } + + /* Process the task statement into the TASK_LIST structure. + */ + if (parse_task_statement() == ERR) { + error (XPP_SYNTAX, "Syntax error in TASK statement"); + while ((ch = input()) != EOF && ch != '\n') + ; + unput ('\n'); + return; + } + + /* Open RUNTASK ("lib$sysruk.x") as an include file. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + istkptr--; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + strcpy (fname[istkptr], IRAFLIB); + strcat (fname[istkptr], RUNTASK); + if ((yyin = fopen (vfn2osfn (fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot read lib$sysruk.x"); + return; + } + + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of the include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer(yyin,YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* DO_INCLUDE -- Process an include statement, i.e., eat up the include + * statement, push the current input file on a stack, and open the new file. + * System include files are referenced as "<file>", other files as "file". + */ +void +do_include() +{ + char *p, delim, *rindex(); + char hfile[SZ_FNAME+1], *op; + int root_len; + + + /* Push current input file status on the input file stack istk. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + --istkptr; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + /* If filespec "<file>", call os_sysfile to get the pathname of the + * system include file. + */ + if (yytext[yyleng-1] == '<') { + + for (op=hfile; (*op = input()) != EOF; op++) + if (*op == '\n') { + --istkptr; + error (XPP_SYNTAX, "missing > delim in include statement"); + return; + } else if (*op == '>') + break; + + *op = EOS; + + if (os_sysfile (hfile, fname[istkptr], SZ_PATHNAME) == ERR) { + --istkptr; + error (XPP_COMPERR, "cannot find include file"); + return; + } + + } else { + /* Prepend pathname leading to the file in which the current + * include statement was found. Compiler may not have been run + * from the directory containing the source and include file. + */ + if (!hbindefs) { + if ((p = rindex (fname[istkptr-1], '/')) == NULL) + root_len = 0; + else + root_len = p - fname[istkptr-1] + 1; + strncpy (fname[istkptr], fname[istkptr-1], root_len); + + } else { + if ((p = vfn2osfn (HBIN_INCLUDES, 0))) { + root_len = strlen (p); + strncpy (fname[istkptr], p, root_len); + } else { + --istkptr; + error (XPP_COMPERR, "cannot find hbin$ directory"); + return; + } + } + fname[istkptr][root_len] = EOS; + + delim = '"'; + + /* Advance to end of whatever is in the file name string. + */ + for (p=fname[istkptr]; *p != EOS; p++) + ; + /* Concatenate name of referenced file. + */ + while ((*p = input()) != delim) { + if (*p == '\n' || *p == EOF) { + --istkptr; + error (XPP_SYNTAX, "bad include file name"); + return; + } + p++; + } + *p = EOS; + } + + /* If the foreign defs option is in effect, the machine dependent defs + * for a foreign machine are given by a substitute "iraf.h" file named + * on the command line. This foreign machine header file includes + * not only the iraf.h for the foreign machine, but the equivalent of + * all the files named in the array of strings "machdefs". Ignore any + * attempts to include any of these files since they have already been + * included in the foreign definitions header file. + */ + if (foreigndefs) { + char sysfile[SZ_PATHNAME]; + char **files; + + /* + for (files=machdefs; *files != NULL; files++) { + */ + for (files=machdefs; **files; files++) { + memset (sysfile, 0, SZ_PATHNAME); + strcpy (sysfile, HOSTLIB); + strcat (sysfile, *files); + if (strcmp (sysfile, fname[istkptr]) == 0) { + --istkptr; + return; + } + } + } + + if ((yyin = fopen (vfn2osfn(fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot open include file"); + return; + } + + /* Keep track of the line number within the include file. */ + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer(yyin,YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* YYWRAP -- Called by LEX when end of file is reached. If input stack is + * not empty, close off include file and continue on in old file. Return + * nonzero when the stack is empty, i.e., when we reach the end of the + * main file. + */ +int +yywrap() +{ + /* The last line of a file is not necessarily newline terminated. + * Output a newline just in case. + */ + fprintf (yyout, "\n"); + + if (istkptr <= 0) { + /* ALL DONE with main file. + */ + return (1); + + } else { + /* End of include file. Pop old input file and set line number + * for error messages. + */ + fclose (yyin); + /* yyin = istk[--istkptr]; */ + istkptr--; + + yypop_buffer_state (); + if ( !YY_CURRENT_BUFFER ) + yyterminate (); + + if (istkptr == 0) + setline(); + return (0); + } +} + + + +/* YY_INPUT -- Get a character from the input stream. + */ +int +yy_input () +{ + return (input()); +} + + +/* YY_UNPUT -- Put a character back into the input stream. + */ +void +yy_unput (ch) +char ch; +{ + unput(ch); +} + diff --git a/unix/boot/spp/xpp/mkpkg.sh b/unix/boot/spp/xpp/mkpkg.sh new file mode 100644 index 00000000..d6972000 --- /dev/null +++ b/unix/boot/spp/xpp/mkpkg.sh @@ -0,0 +1,15 @@ +# Make the first pass (XPP) of the SPP language compiler. + +find xpp.l -newer lexyy.c -exec rm lexyy.c \; +if test -f lexyy.c; then\ + $CC -c $HSI_CF lexyy.c;\ +else\ + lex xpp.l;\ + sed -f lex.sed lex.yy.c > lexyy.c; rm lex.yy.c;\ + $CC -c $HSI_CF lexyy.c;\ +fi + +$CC -c $HSI_CF xppmain.c xppcode.c decl.c +$CC $HSI_LF xppmain.o lexyy.o xppcode.o decl.o $HSI_LIBS -o xpp.e +mv -f xpp.e ../../../hlib +rm *.o diff --git a/unix/boot/spp/xpp/xpp.h b/unix/boot/spp/xpp/xpp.h new file mode 100644 index 00000000..2fde825d --- /dev/null +++ b/unix/boot/spp/xpp/xpp.h @@ -0,0 +1,94 @@ +/* XPP error codes. + */ +#define XPP_OK OSOK /* no problems */ +#define XPP_COMPERR 101 /* compiler error */ +#define XPP_BADXFILE 102 /* cannot open .x file */ +#define XPP_SYNTAX 104 /* language error */ + + + +#define F77 /* Fortran 77 target compiler? */ + +#define IRAFLIB "iraf$lib/" +#define HOSTLIB "host$hlib/" +#define HBIN_INCLUDES "hbin$arch_includes/" + + +/* Size limiting definitions. + */ +#define MAX_TASKS 100 /* max no. of tasks we can handle */ +#define SZ_OBUF 131072 /* buffers procedure body */ +#define SZ_DBUF 8192 /* for errchk, common, ect. decls */ +#define SZ_SBUF 8192 /* buffers text of strings */ +#define MAX_STRINGS 256 /* max strings in a procedure */ +#define MAX_INCLUDE 5 /* maximum nesting of includes */ +#define MIN_REALPREC 7 /* used by HMS */ +#define SZ_NUMBUF 32 /* for numeric constants */ +#define SZ_STBUF 4096 /* text of defined strings */ +#define MAX_DEFSTR 128 /* max defined strings */ + +#define RUNTASK "sysruk.x" +#define OCTAL 8 +#define DECIMAL 10 +#define HEX 16 +#define CHARCON 1 +#define SEXAG 2 + + +/* Contexts. + */ +#define GLOBAL 01 +#define DECL 02 +#define BODY 04 +#define DEFSTMT 010 +#define DATASTMT 020 +#define PROCSTMT 040 + +/* String type codes. + */ +#define STR_INLINE 0 +#define STR_DEFINE 1 +#define STR_DECL 2 + +/* SPP keywords. The datatype keywords bool through pointer must be assigned + * the lowest numbers. + */ +#define XTY_BOOL 1 +#define XTY_CHAR 2 +#define XTY_SHORT 3 +#define XTY_INT 4 +#define XTY_LONG 5 +#define XTY_REAL 6 +#define XTY_DOUBLE 7 +#define XTY_COMPLEX 8 +#define XTY_POINTER 9 +#define XTY_PROC 10 +#define XTY_TRUE 11 +#define XTY_FALSE 12 +#define XTY_IFERR 13 +#define XTY_IFNOERR 14 +#define XTY_EXTERN 15 +#define XTY_ERROR 16 +#define MAX_KEY 16 + +/* RPP type keywords (must match type codes above). + */ +#define RPP_TYPES {\ + "",\ + "x$bool",\ + "x$short", /* MACHDEP */\ + "x$short",\ + "x$int",\ + "x$long",\ + "x$real",\ + "x$dble",\ + "x$cplx",\ + "x$pntr",\ + "x$fcn",\ + ".true.",\ + ".false.",\ + "iferr",\ + "ifnoerr",\ + "x$extn",\ + "error"\ +} diff --git a/unix/boot/spp/xpp/xpp.l b/unix/boot/spp/xpp/xpp.l new file mode 100644 index 00000000..554c38dc --- /dev/null +++ b/unix/boot/spp/xpp/xpp.l @@ -0,0 +1,476 @@ +%{ + +#include <stdio.h> +#include <ctype.h> +#include "xpp.h" +#include "../../bootProto.h" +#include "xppProto.h" + +#define import_spp +#include <iraf.h> + + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +#ifdef YYLMAX +#undef YYLMAX +#endif +#define YYLMAX YY_BUF_SIZE + +YY_BUFFER_STATE include_stack[MAX_INCLUDE]; + + +extern FILE *istk[]; +extern char fname[MAX_INCLUDE][SZ_PATHNAME]; +extern char *machdefs[]; +extern int hbindefs, foreigndefs; + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +extern int ntasks; +static int dtype; /* set if typed procedure */ + +extern char *vfn2osfn(); +extern void skipnl (void); + + +void typespec (int typecode); +void process_task_statement (void); + +void do_include (void); +int yywrap (void); +int yy_input (void); +void yy_unput (char ch); + + +%} + +D [0-9] +O [0-7] +S [ 0-6]{D} +X [0-9A-F] +W [ \t] +NI [^a-zA-Z0-9_] + +%a 5000 +%o 9000 +%k 500 + +%% + +^"bool"/{NI} typespec (XTY_BOOL); +^"char"/{NI} typespec (XTY_CHAR); +^"short"/{NI} typespec (XTY_SHORT); +^"int"/{NI} typespec (XTY_INT); +^"long"/{NI} typespec (XTY_LONG); +^"real"/{NI} typespec (XTY_REAL); +^"double"/{NI} typespec (XTY_DOUBLE); +^"complex"/{NI} typespec (XTY_COMPLEX); +^"pointer"/{NI} typespec (XTY_POINTER); +^"extern"/{NI} typespec (XTY_EXTERN); + +^{W}*"procedure"/{NI} { + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + +"procedure"/{NI} { + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + setline(); + } + +^{W}*"task"/{NI} { if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } +^{W}*"TN$DECL" put_dictionary(); +^{W}*"TN$INTERP" put_interpreter(); +^".""help" { + skip_helpblock(); + setline(); + } +^{W}*"begin"/{NI} { + begin_code(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+Memr { + macro_redef(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+\" { + str_enter(); + } +^{W}*("(")?"define"/{NI} { + pushcontext (DEFSTMT); + ECHO; + } +^{W}*"end"/{NI} { + end_code(); + setline(); + } +^{W}*"string"/{NI} { + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } +^{W}*"data"/{NI} { + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + +"switch"/{NI} { + ECHO; + if (context & BODY) + nswitch++; + } + +"#" skipnl(); +^"%"[^\n]* ECHO; + +^{W}*"include"{W}*(\"|<) do_include(); + +[a-zA-Z][a-zA-Z0-9_$]* mapident(); + +{D}+":"{S}(":"{S})?("."{D}*)? hms (yytext); +{O}+("B"|"b") int_constant (yytext, OCTAL); +{X}+("X"|"x") int_constant (yytext, HEX); +\' int_constant (yytext, CHARCON); + +"()" { + if (context & (BODY|PROCSTMT)) + ECHO; + } + +"&&" output ('&'); +"||" output ('|'); + +"{" { + ECHO; + nbrace++; + } +"}" { + ECHO; + nbrace--; + } +"[" output ('('); +"]" output (')'); + +\*\" do_hollerith(); + +\" { + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + +(","|";"){W}*("#"[^\n]*)?"\n" { + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + +"\n" { + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + +%% + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +void +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} + + + +/* PROCESS_TASK_STATEMENT -- Parse the TASK statement. The task statement + * is replaced by the "sys_runtask" procedure (sysruk), which is called by + * the IRAF main to run a task, or to print the dictionary (cmd "?"). + * The source for the basic sys_runtask procedure is in "lib$sysruk.x". + * We process the task statement into some internal tables, then open the + * sysruk.x file as an include file. Special macros therein are + * replaced by the taskname dictionary as processing continues. + */ +void +process_task_statement() +{ + char ch; + + if (ntasks > 0) { /* only one task statement permitted */ + error (XPP_SYNTAX, "Only one TASK statement permitted per file"); + return; + } + + /* Process the task statement into the TASK_LIST structure. + */ + if (parse_task_statement() == ERR) { + error (XPP_SYNTAX, "Syntax error in TASK statement"); + while ((ch = input()) != EOF && ch != '\n') + ; + unput ('\n'); + return; + } + + /* Open RUNTASK ("lib$sysruk.x") as an include file. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + istkptr--; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + strcpy (fname[istkptr], IRAFLIB); + strcat (fname[istkptr], RUNTASK); + if ((yyin = fopen (vfn2osfn (fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot read lib$sysruk.x"); + return; + } + + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of the include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer( yyin, YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* DO_INCLUDE -- Process an include statement, i.e., eat up the include + * statement, push the current input file on a stack, and open the new file. + * System include files are referenced as "<file>", other files as "file". + */ +void +do_include() +{ + char *p, delim, *rindex(); + char hfile[SZ_FNAME+1], *op; + int root_len; + + + /* Push current input file status on the input file stack istk. + */ + istk[istkptr] = yyin; + if (++istkptr >= MAX_INCLUDE) { + --istkptr; + error (XPP_COMPERR, "Maximum include nesting exceeded"); + return; + } + + /* If filespec "<file>", call os_sysfile to get the pathname of the + * system include file. + */ + if (yytext[yyleng-1] == '<') { + + for (op=hfile; (*op = input()) != EOF; op++) + if (*op == '\n') { + --istkptr; + error (XPP_SYNTAX, "missing > delim in include statement"); + return; + } else if (*op == '>') + break; + + *op = EOS; + + if (os_sysfile (hfile, fname[istkptr], SZ_PATHNAME) == ERR) { + --istkptr; + error (XPP_COMPERR, "cannot find include file"); + return; + } + + } else { + /* Prepend pathname leading to the file in which the current + * include statement was found. Compiler may not have been run + * from the directory containing the source and include file. + */ + if (!hbindefs) { + if ((p = rindex (fname[istkptr-1], '/')) == NULL) + root_len = 0; + else + root_len = p - fname[istkptr-1] + 1; + strncpy (fname[istkptr], fname[istkptr-1], root_len); + + } else { + if ((p = vfn2osfn (HBIN_INCLUDES, 0))) { + root_len = strlen (p); + strncpy (fname[istkptr], p, root_len); + } else { + --istkptr; + error (XPP_COMPERR, "cannot find hbin$ directory"); + return; + } + } + fname[istkptr][root_len] = EOS; + + delim = '"'; + + /* Advance to end of whatever is in the file name string. + */ + for (p=fname[istkptr]; *p != EOS; p++) + ; + /* Concatenate name of referenced file. + */ + while ((*p = input()) != delim) { + if (*p == '\n' || *p == EOF) { + --istkptr; + error (XPP_SYNTAX, "bad include file name"); + return; + } + p++; + } + *p = EOS; + } + + /* If the foreign defs option is in effect, the machine dependent defs + * for a foreign machine are given by a substitute "iraf.h" file named + * on the command line. This foreign machine header file includes + * not only the iraf.h for the foreign machine, but the equivalent of + * all the files named in the array of strings "machdefs". Ignore any + * attempts to include any of these files since they have already been + * included in the foreign definitions header file. + */ + if (foreigndefs) { + char sysfile[SZ_PATHNAME]; + char **files; + + /* + for (files=machdefs; *files != NULL; files++) { + */ + for (files=machdefs; **files; files++) { + memset (sysfile, 0, SZ_PATHNAME); + strcpy (sysfile, HOSTLIB); + strcat (sysfile, *files); + if (strcmp (sysfile, fname[istkptr]) == 0) { + --istkptr; + return; + } + } + } + + if ((yyin = fopen (vfn2osfn(fname[istkptr],0), "r")) == NULL) { + yyin = istk[--istkptr]; + error (XPP_SYNTAX, "Cannot open include file"); + return; + } + + /* Keep track of the line number within the include file. */ + linenum[istkptr] = 1; + + /* Put the newline back so that LEX "^..." matches will work on + * first line of include file. + */ + unput ('\n'); + + yypush_buffer_state(yy_create_buffer( yyin, YY_BUF_SIZE )); + BEGIN(INITIAL); +} + + +/* YYWRAP -- Called by LEX when end of file is reached. If input stack is + * not empty, close off include file and continue on in old file. Return + * nonzero when the stack is empty, i.e., when we reach the end of the + * main file. + */ +int +yywrap() +{ + /* The last line of a file is not necessarily newline terminated. + * Output a newline just in case. + */ + fprintf (yyout, "\n"); + + if (istkptr <= 0) { + /* ALL DONE with main file. + */ + return (1); + + } else { + /* End of include file. Pop old input file and set line number + * for error messages. + */ + fclose (yyin); + /* yyin = istk[--istkptr]; */ + istkptr--; + + yypop_buffer_state (); + if ( !YY_CURRENT_BUFFER ) + yyterminate (); + + if (istkptr == 0) + setline(); + return (0); + } +} + + + +/* YY_INPUT -- Get a character from the input stream. + */ +int +yy_input () +{ + return (input()); +} + + +/* YY_UNPUT -- Put a character back into the input stream. + */ +void +yy_unput (ch) +char ch; +{ + unput(ch); +} diff --git a/unix/boot/spp/xpp/xpp.l.orig b/unix/boot/spp/xpp/xpp.l.orig new file mode 100644 index 00000000..f5c7a375 --- /dev/null +++ b/unix/boot/spp/xpp/xpp.l.orig @@ -0,0 +1,188 @@ +%{ + +#include "xpp.h" + +/* + * Lexical definition for the first pass of the IRAF subset preprocessor. + * This program is a horrible kludge but will suffice until there is time + * to build something better. + */ + +#undef output /* undefine LEX output macro -- we use proc */ +#undef ECHO /* ditto echo */ +#define ECHO outstr (yytext) + +#define OCTAL 8 +#define HEX 16 +#define CHARCON 1 + +extern int linenum[]; /* line numbers in files */ +extern int istkptr; /* istk pointer */ +extern int str_idnum; /* for ST0000 string names */ +extern int nbrace; /* count of braces */ +extern int nswitch; /* number of "switch" stmts */ +extern int errflag; /* set if compiler error */ +extern int errchk; /* sef if error checking */ +extern int context; /* lexical context flags */ +static int dtype; /* set if typed procedure */ + +%} + +D [0-9] +O [0-7] +S [ 0-6]{D} +X [0-9A-F] +W [ \t] +NI [^a-zA-Z0-9_] + +%a 5000 +%o 9000 +%k 500 + +%% + +^"bool"/{NI} typespec (XTY_BOOL); +^"char"/{NI} typespec (XTY_CHAR); +^"short"/{NI} typespec (XTY_SHORT); +^"int"/{NI} typespec (XTY_INT); +^"long"/{NI} typespec (XTY_LONG); +^"real"/{NI} typespec (XTY_REAL); +^"double"/{NI} typespec (XTY_DOUBLE); +^"complex"/{NI} typespec (XTY_COMPLEX); +^"pointer"/{NI} typespec (XTY_POINTER); +^"extern"/{NI} typespec (XTY_EXTERN); + +^{W}*"procedure"/{NI} { + /* Subroutine declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, 0); + } + +"procedure"/{NI} { + /* Function declaration. */ + pushcontext (PROCSTMT); + d_gettok (yytext, YYLMAX-1); + d_newproc (yytext, dtype); + } + +^{W}*"task"/{NI} { if (context & BODY) + ECHO; + else { + process_task_statement(); + setline(); + } + } +^{W}*"TN$DECL" put_dictionary(); +^{W}*"TN$INTERP" put_interpreter(); +^".""help" { + skip_helpblock(); + setline(); + } + +^{W}*"begin"/{NI} { + begin_code(); + setline(); + } +^{W}*"define"{W}+[A-Z0-9_]+{W}+\" { + str_enter(); + } +^{W}*("(")?"define"/{NI} { + pushcontext (DEFSTMT); + ECHO; + } +^{W}*"end"/{NI} { + end_code(); + } +^{W}*"string"/{NI} { + (context & BODY) ? ECHO + : do_string ('"', STR_DECL); + } +^{W}*"data"/{NI} { + if (!(context & BODY)) + pushcontext (DATASTMT); + ECHO; + } + +"switch"/{NI} { + ECHO; + if (context & BODY) + nswitch++; + } + +"#" skipnl(); +^"%"[^\n]* ECHO; + +^{W}*"include"{W}*(\"|<) do_include(); + +[a-zA-Z][a-zA-Z0-9_$]* mapident(); + +{D}+":"{S}(":"{S})?("."{D}*)? hms (yytext); +{O}+("B"|"b") int_constant (yytext, OCTAL); +{X}+("X"|"x") int_constant (yytext, HEX); +\' int_constant (yytext, CHARCON); + +"()" { + if (context & (BODY|PROCSTMT)) + ECHO; + } + +"&&" output ('&'); +"||" output ('|'); + +"{" { + ECHO; + nbrace++; + } +"}" { + ECHO; + nbrace--; + } +"[" output ('('); +"]" output (')'); + +\*\" do_hollerith(); + +\" { + if (context & BODY) + do_string ('"', STR_INLINE); + else + ECHO; + } + +(","|";"){W}*("#"[^\n]*)?"\n" { + /* If statement is continued do not pop + * the context. + */ + ECHO; + linenum[istkptr]++; + } + +"\n" { + /* End of newline and end of statement. + */ + ECHO; + linenum[istkptr]++; + popcontext(); + } + +%% + + +/* TYPESPEC -- Context dependent processing of a type specifier. If in the + * declarations section, process a declarations statement. If in procedure + * body or in a define statement, map the type specifier identifer and output + * the mapped value (intrinsic function name). Otherwise we must be in global + * space, and the type spec begins a function declaration; save the datatype + * code for d_newproc(). + */ +typespec (typecode) +int typecode; +{ + if (context & DECL) + d_declaration (typecode); + else if (context & (BODY|DEFSTMT)) + mapident(); + else + dtype = typecode; +} diff --git a/unix/boot/spp/xpp/xppProto.h b/unix/boot/spp/xpp/xppProto.h new file mode 100644 index 00000000..073aa585 --- /dev/null +++ b/unix/boot/spp/xpp/xppProto.h @@ -0,0 +1,55 @@ + +/* decl.c */ +void d_newproc (char *name, int dtype); +int d_declaration (int dtype); +void d_codegen (register FILE *fp); +void d_runtime (char *text); +//void d_makedecl (struct symbol *sp, FILE *fp); +struct symbol *d_enter (char *name, int dtype, int flags); +struct symbol *d_lookup (char *name); +void d_chksbuf (void); +int d_gettok (char *tokstr, int maxch); +//void d_declfunc (struct symbol *sp, FILE *fp); + + +/* xppcode.c */ +void setcontext (int new_context); +void pushcontext (int new_context); +int popcontext (void); +void hashtbl (void); +int findkw (void); +void mapident (void); +void str_enter (void); +char *str_fetch (register char *strname); +void macro_redef (void); +void setline (void); +void output (char ch); + +void do_type (int type); +void do_char (void); +void skip_helpblock (void); +int parse_task_statement (void); +int get_task (char *task_name, char *proc_name, int maxch); +int get_name (char *outstr, int maxch); +int nextch (void); +void put_dictionary (void); +void put_interpreter (void); +void outstr (char *string); +void begin_code (void); +void end_code (void); +void init_strings (void); +//void write_string_data_statement (struct string *s); +void do_string (char delim, int strtype); +void do_hollerith (void); +void sbuf_check (void); + +char *str_uniqid (void); +void traverse (char delim); +void error (int errcode, char *errmsg); +void xpp_warn (char *warnmsg); +long accum (int base, char **strp); + +int charcon (char *string); +void int_constant (char *string, int base); +void hms (char *number); + diff --git a/unix/boot/spp/xpp/xppcode.c b/unix/boot/spp/xpp/xppcode.c new file mode 100644 index 00000000..e083cb27 --- /dev/null +++ b/unix/boot/spp/xpp/xppcode.c @@ -0,0 +1,1826 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> +#include "xpp.h" +#include "../../bootProto.h" + +#define import_spp +#include <iraf.h> + +/* + * C code for the first pass of the IRAF subset preprocessor (SPP). + * The decision to initially organize the SPP compiler into two passes was + * made to permit maximum use of the existing raftor preprocessor, which is + * the basis for the second pass of the SPP. Eventually the two passes + * should be combined into a single program. Most of the operations performed + * by the first pass (XPP) should be performed AFTER macro substitution, + * rather than before as is the case in the current implementation, which + * processes macros in the second pass (RPP). + * + * Beware that this is not a very good program which was not carefully + * designed and which was never intended to have a long lifetime. The next + * step is to replace the two passes by a single program which is functionally + * very similar, but which is more carefully engineered and which is written + * in the SPP language calling IRAF file i/o. Eventually a true compiler + * will be written, providing many new features, i.e., structures and pointers, + * automatic storage class, mapped arrays, enhanced i/o support, and good + * compile time error checking. This compiler will also feature a table driven + * code generator (generating primitive Fortran statements), which will provide + * greater machine independence. + */ + + +extern char *vfn2osfn(); + +/* Escape sequence characters and their binary equivalents. + */ +char *esc_ch = "ntfr\\\"'"; +char *esc_val = "\n\t\f\r\\\"\'"; + +/* External and internal data stuctures. We need access to the LEX i/o + * buffers because we use the LEX i/o macros, which provide pushback, + * because we must change the streams to process includes, and so on. + * These definitions are VERY Lex dependent. + */ +extern char yytext[]; /* LEX character buffer */ +extern int yyleng; /* length of string in yytext */ +extern FILE *yyin, *yyout; /* LEX input, output files */ + +extern char yytchar, *yysptr, yysbuf[]; +extern int yylineno; + +#define U(x) x +/* +#define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10\ +?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +#define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +*/ + +extern int input(); +extern void yyunput(); +extern void d_codegen (register FILE *fp); +extern void d_runtime (char *text); + +extern char *yytext_ptr; +#define unput(c) yyunput( c, (yytext_ptr) ) + + + +int context = GLOBAL; /* lexical context variable */ +extern int hbindefs, foreigndefs; +char *machdefs[] = { "mach.h", "config.h", "" }; + +/* The task structure is used for TASK declarations. Since this is a + * throwaway program we do not bother with dynamic storage allocation, + * which would remove the limit on the number of tasks in a task statment. + */ +struct task { + char *task_name; /* logical task name */ + char *proc_name; /* name of procedure */ + short name_offset; /* offset of name in dictionary */ +}; + +/* The string structure is used for STRING declarations and for inline + * strings. Strings are stored in a fixed size, statically allocated + * string buffer. + */ +struct string { + char *str_name; /* name of string */ + char *str_text; /* ptr to text of string */ + short str_length; /* length of string */ +}; + +struct task task_list[MAX_TASKS]; +struct string string_list[MAX_STRINGS]; + +FILE *istk[MAX_INCLUDE]; /* stack for input file descriptors */ +int linenum[MAX_INCLUDE]; /* line numbers in files */ +char fname[MAX_INCLUDE][SZ_PATHNAME];/* file names */ +int istkptr = 0; /* istk pointer */ + +char obuf[SZ_OBUF]; /* buffer for body of procedure */ +char dbuf[SZ_DBUF]; /* buffer for misc proc. decls. */ +char sbuf[SZ_SBUF]; /* string buffer */ +char *sp = sbuf; /* string buffer pointer */ +char *op = obuf; /* pointer in output buffer */ +char *dp = dbuf; /* pointer in decls buffer */ +int nstrings = 0; /* number of strings so far */ +int strloopdecl; /* data dummy do index declared? */ + +int ntasks = 0; /* number of tasks in interpreter */ +int str_idnum = 0; /* for generating unique string names */ +int nbrace = 0; /* must be zero when "end" is reached */ +int nswitch = 0; /* number switch stmts in procedure */ +int errflag; +int errhand = NO; /* set if proc employs error handler */ +int errchk = NO; /* set if proc employs error checking */ + + +void skipnl (void); +void setcontext (int new_context); +void pushcontext (int new_context); +int popcontext (void); +void hashtbl (void); +int findkw (void); +void mapident (void); +void str_enter (void); +char *str_fetch (register char *strname); +void macro_redef (void); +void setline (void); +void output (char ch); + +void do_type (int type); +void do_char (void); +void skip_helpblock (void); +int parse_task_statement (void); +int get_task (char *task_name, char *proc_name, int maxch); +int get_name (char *outstr, int maxch); +int nextch (void); +void put_dictionary (void); +void put_interpreter (void); +void outstr (char *string); +void begin_code (void); +void end_code (void); +void init_strings (void); +void write_string_data_statement (struct string *s); +void do_string (char delim, int strtype); +void do_hollerith (void); +void sbuf_check (void); + +char *str_uniqid (void); +void traverse (char delim); +void error (int errcode, char *errmsg); +void xpp_warn (char *warnmsg); +long accum (int base, char **strp); + +int charcon (char *string); +void int_constant (char *string, int base); +void hms (char *number); + + + +/* SKIPNL -- Skip to newline, e.g., when a comment is encountered. + */ +void +skipnl (void) +{ + int c; + while ((c=input()) != '\n') + ; + unput ('\n'); +} + + +/* + * CONTEXT -- Package for setting, saving, and restoring the lexical context. + * The action of the preprocessor in some cases depends upon the context, i.e., + * what type of statement we are processing, whether we are in global space, + * within a procedure, etc. + */ + +#define MAX_CONTEXT 5 /* max nesting of context */ + +int cntxstk[MAX_CONTEXT]; /* for saving context */ +int cntxsp = 0; /* save stack pointer */ + + +/* SETCONTEXT -- Set the context. Clears any saved context. + */ +void +setcontext (int new_context) +{ + context = new_context; + cntxsp = 0; +} + + +/* PUSHCONTEXT -- Push a temporary context. + */ +void +pushcontext (int new_context) +{ + cntxstk[cntxsp++] = context; + context = new_context; + + if (cntxsp > MAX_CONTEXT) + error (XPP_COMPERR, "save context stack overflow"); +} + + +/* POPCONTEXT -- Pop the former context. If the current context is PROCSTMT + * (just finished compiling a procedure statement) then set the context to DECL + * to indicate that we are entering the declarations section of a procedure. + */ +int +popcontext (void) +{ + if (context & PROCSTMT) { + context = DECL; + if (cntxsp > 0) + --cntxsp; + } else if (cntxsp > 0) + context = cntxstk[--cntxsp]; + + return (context); +} + + +/* Keyword table. The simple hashing scheme requires that the keywords appear + * in the table in sorted order. + */ +#define LEN_KWTBL 18 + +struct { + char *keyw; /* keyword name string */ + short opcode; /* opcode from above definitions */ + short nelem; /* number of table elements to skip if + * to get to next character class. + */ +} kwtbl[] = { + { "FALSE", XTY_FALSE, 0 }, + { "TRUE", XTY_TRUE, 0 }, + { "bool", XTY_BOOL, 0 }, + { "char", XTY_CHAR, 1 }, + { "complex", XTY_COMPLEX, 0 }, + { "double", XTY_DOUBLE, 0 }, + { "error", XTY_ERROR, 1 }, + { "extern", XTY_EXTERN, 0 }, + { "false", XTY_FALSE, 0 }, + { "iferr", XTY_IFERR, 2 }, + { "ifnoerr", XTY_IFNOERR, 1 }, + { "int", XTY_INT, 0 }, + { "long", XTY_LONG, 0 }, + { "pointer", XTY_POINTER, 1 }, + { "procedure", XTY_PROC, 0 }, + { "real", XTY_REAL, 0 }, + { "short", XTY_SHORT, 0 }, + { "true", XTY_TRUE, 0 }, +}; + +/* short kwindex[30]; simple alphabetic hash index */ +/* #define CINDEX(ch) (isupper(ch)?ch-'A':ch-'a') */ + +#define MAXCH 128 +short kwindex[MAXCH]; /* simple alphabetic hash index */ +#define CINDEX(ch) (ch) + + +/* HASHTBL -- Hash the keyword table. Initializes the "kwindex" hash table. + * For each character in the alphabet, the index gives the index into the + * sorted keyword table. If there is no keyword name beginning with the index + * character, the index entry is set to -1. + */ +void +hashtbl (void) +{ + int i, j; + + for (i=j=0; i <= MAXCH; i++) { + if (i == CINDEX (kwtbl[j].keyw[0])) { + kwindex[i] = j; + j = min (LEN_KWTBL-1, j + kwtbl[j].nelem + 1); + } else + kwindex[i] = -1; + } +} + + +/* FINDKW -- Lookup an indentifier in the keyword table. Return the opcode + * of the keyword, or ERR if no match. + */ +int +findkw (void) +{ + register char ch, *p, *q; + int i, ilimit; + + if (kwindex[0] == 0) + hashtbl(); + + i = CINDEX (yytext[0]); + if (i < 0 || i >= MAXCH || (i = kwindex[i]) < 0) + return (ERR); + ilimit = i + kwtbl[i].nelem; + + for (; i <= ilimit; i++) { + p = kwtbl[i].keyw + 1; + q = yytext + 1; + + for (; *p != EOS; q++, p++) { + ch = *q; + /* 5DEC95 - Don't case convert keywords. + if (isupper (ch)) + ch = tolower (ch); + */ + if (*p != ch) + break; + } + if (*p == EOS && *q == EOS) + return (kwtbl[i].opcode); + } + return (ERR); +} + + +/* MAPIDENT -- Lookup an identifier in the keyword table. If the identifier is + * not a keyword, output it as is. If a datatype keyword, the action depends + * on whether we are in a procedure body or not (i.e., whether the keyword + * begins a declaration or is a type coercion function). Most of the other + * keywords are mapped into special x$.. identifiers for further processing + * by the second pass. + */ +void +mapident (void) +{ + int i, findkw(); + char *str_fetch(); + register char *ip, *op; + + /* If not keyword and not defined string, output as is. The first + * char must be upper case for the name to be recognized as that of + * a defined string. If we are processing a "define" macro expansion + * is disabled. + */ + if ((i = findkw()) == ERR) { + if (!isupper(yytext[0]) || (context & DEFSTMT) || + (ip = str_fetch (yytext)) == NULL) { + + outstr (yytext); + return; + + } else { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + do_string ('"', STR_DEFINE); + return; + } + } + + /* If datatype keyword, call do_type. */ + if (i <= XTY_POINTER) { + do_type (i); + return; + } + + switch (i) { + case XTY_TRUE: + outstr (".true."); + break; + case XTY_FALSE: + outstr (".false."); + break; + case XTY_IFERR: + case XTY_IFNOERR: + outstr (yytext); + errhand = YES; + errchk = YES; + break; + case XTY_ERROR: + outstr (yytext); + errchk = YES; + break; + + case XTY_EXTERN: + /* UNREACHABLE (due to decl.c additions). + */ + outstr ("x$extn"); + break; + + default: + error (XPP_COMPERR, "Keyword lookup error"); + } +} + + +char st_buf[SZ_STBUF]; +char *st_next = st_buf; + +struct st_def { + char *st_name; + char *st_value; +} st_list[MAX_DEFSTR]; + +int st_nstr = 0; + +/* STR_ENTER -- Enter a defined string into the string table. The string + * table is a kludge to provide the capability to define strings in SPP. + * The problem is that XPP handles strings but RPP handles macros, hence + * strings cannot be defined. We get around this by recognizing defines + * of the form 'define NAME "..."'. If a macro with a quoted value is + * encounted we are called to enter the name and the string into the + * table. LOOKUP, above, subsequently searches the table for defined + * strings. The name must be upper case or the table will not be searched. + * + * N.B.: we are called by the lexical analyser with 'define name "' in + * yytext. The next input() will return the first char of the string. + */ +void +str_enter (void) +{ + register char *ip, *op, ch; + register struct st_def *s; + register int n; + char name[SZ_FNAME+1]; + + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Do not accept statement unless the name is upper case. + */ + if (!isupper (*ip)) { + outstr (yytext); + return; + } + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + + /* Check for a redefinition. */ + for (n=st_nstr, s=st_list, ch=name[0]; --n >= 0; s++) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, name) == 0) + break; + } + + /* Make a new entry?. */ + if (n < 0) { + s = &st_list[st_nstr++]; + if (st_nstr >= MAX_DEFSTR) + error (XPP_COMPERR, "Too many defined strings"); + + /* Put defined NAME in string buffer. */ + for (s->st_name = st_next, (ip=name); (*st_next++ = *ip++); ) + ; + } + + /* Put value in string buffer. + */ + s->st_value = st_next; + traverse ('"'); + for (ip=yytext; (*st_next++ = *ip++) != EOS; ) + ; + *st_next++ = EOS; + + if (st_next - st_buf >= SZ_STBUF) + error (XPP_COMPERR, "Too many defined strings"); +} + + +/* STR_FETCH -- Search the defined string table for the named string + * parameter and return a pointer to the string if found, NULL otherwise. + */ +char * +str_fetch (register char *strname) +{ + register struct st_def *s = st_list; + register int n = st_nstr; + register char ch = strname[0]; + + while (--n >= 0) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, strname) == 0) + return (s->st_value); + s++; + } + + return (NULL); +} + + +/* MACRO_REDEF -- Redefine the macro to automatically add a P2<T> macro + * to struct definitions. + */ +void +macro_redef (void) +{ + register int nb=0; + register char *ip, *op, ch; + char name[SZ_FNAME]; + char value[SZ_LINE]; + + + outstr ("define\t"); + memset (name, 0, SZ_FNAME); + memset (value, 0, SZ_LINE); + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + outstr (name); + outstr ("\t"); + + + /* Modify value. + */ + op = value; + while ( (ch = input()) != EOF ) { + if (ch == '\n') { + break; + } else if (ch == '#') { /* eat a comment */ + while ((ch = input()) != '\n') + ; + break; + + + } else { + if (ch == '[') { + nb++; + if (nb > 1) *op++ = '('; + } else if (ch == ']') { + nb--; + if (nb <= 0) + break; + else + *op++ = ')'; + } else if (nb >= 1) + *op++ = ch; + } + } + + outstr ("Memr("); + if (strcmp (value, "$1") == 0) { +#if defined(MACH64) && defined(AUTO_P2R) + char *emsg[SZ_LINE]; + int strict = 0; +#endif + + /* A macro such as "Memr[$1]" which is typically used as a + * shorthand for an array allocated as TY_REAL and not a part + * of a struct, however it might also be the first element of + * a struct. In this case, print a warning so it can be checked + * manually and just pass it through. + */ +#if defined(MACH64) && defined(AUTO_P2R) + memset (emsg, 0, SZ_LINE); + sprintf (emsg, + "Error in %s: line %d: ambiguous Memr for '%s' needs P2R/P2P", + fname[istkptr], linenum[istkptr], name); + if (strict) + error (XPP_COMPERR, emsg); + else + fprintf (stderr, "%s\n", emsg); +#endif + outstr (value); + + } else if (strncmp ("Mem", value, 3) == 0 || isupper (value[0])) { + /* In this case we assume a complex macro using some other + * Mem element or an upper-case macro. These are again used + * typically as a shorthand and use pointers directly, so pass + * it through unchanged. + */ + outstr (value); + + } else { + /* Assume it's part of a struct, e.g. "Memr[$1+N]". + * + * FIXME -- We should really be more careful to check the syntax. + fprintf (stderr, "INFO %s line %d: ", + fname[istkptr], linenum[istkptr]); + fprintf (stderr, "adding P2R macro for '%s'\n", name); + */ +#if defined(MACH64) && defined(AUTO_P2R) + if (value[0] == '$') { + outstr ("P2R("); + outstr (value); + outstr (")"); + } else + outstr (value); +#else + outstr (value); +#endif + } + outstr (")\n"); + + linenum[istkptr]++; +} + + +/* SETLINE -- Set the file line number. Used by the first pass to set + * line number after processing an include file and in various other + * places. Necessary to get correct line numbers in error messages from + * the second pass. + */ +void +setline (void) +{ + char msg[20]; + + if (istkptr == 0) { /* not in include file */ + sprintf (msg, "#!# %d\n", linenum[istkptr] - 1); + outstr (msg); + } +} + + +/* OUTPUT -- Output a character. If we are processing the body of a procedure + * or a data statement, put the character into the output buffer. Otherwise + * put the character to the output file. + * + * NOTE -- the redirection logic shown below is duplicated in OUTSTR. + */ +void +output (char ch) +{ + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + *op++ = ch; + if (op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + *dp++ = ch; + if (dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + putc (ch, yyout); + } +} + + +/* Datatype keywords for declarations. The special x$.. keywords are + * for communication with the second pass. Note that this table is machine + * dependent, since it maps char into type short. + */ +char *type_decl[] = RPP_TYPES; + + +/* Intrinsic functions used for type coercion. These mappings are machine + * dependent (MACHDEP). If your machine has INTEGER*2 and INTEGER*4, and + * integer cannot be passed as an argument when a short or long is expected, + * and your compiler has INT2 and INT4 type coercion intrinsic functions, + * you should use those here instead of INT (which happens to work for a VAX). + * If you cannot pass an int when a short is expected (i.e., IBM), and you + * do not have an INT2 intrinsic function, you should provide an external + * INTEGER*2 function called "int2" and use that for type coercion. Note + * that it will then be necessary to have the preprocessor automatically + * generate a declaration for the function. This nonsense will all go away + * when we set up a proper table driven code generator!! + */ +char *intrinsic_function[] = { + "", /* table is one-indexed */ + "(0 != ", /* bool(expr) */ + "int", /* char(expr) */ + "int", /* short(expr) */ + "int", /* int(expr) */ + "int", /* long(expr) */ + "real", /* real(expr) */ + "dble", /* double(expr) */ + "cmplx", /* complex(expr) */ + "int" /* pointer(expr) */ +}; + + +/* DO_TYPE -- Process a datatype keyword. The type of processing depends + * on whether we are called when processing a declaration or an expression. + * In expressions, the datatype keyword is the type coercion intrinsic + * function. DEFINE statements are a special case; we treat them as + * expressions, since macros containing datatype keywords are used in + * expressions more than in declarations. This is a kludge until the problem + * is properly resolved by processing macros BEFORE code generation. + * In the current implementation, macros are handled by the second pass (RPP). + */ +void +do_type (int type) +{ + char ch; + + if (context & (BODY|DEFSTMT)) { + switch (type) { + case XTY_BOOL: + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + if (ch != '(') + error (XPP_SYNTAX, "Illegal boolean expr"); + outstr (intrinsic_function[type]); + return; + + case XTY_CHAR: + case XTY_SHORT: + case XTY_INT: + case XTY_LONG: + case XTY_REAL: + case XTY_DOUBLE: + case XTY_COMPLEX: + case XTY_POINTER: + outstr (intrinsic_function[type]); + return; + + default: + error (XPP_SYNTAX, "Illegal type coercion"); + } + + } else { + /* UNREACHABLE when in declarations section of a procedure. + */ + fprintf (yyout, "%s", type_decl[type]); + } +} + + +/* DO_CHAR -- Process a char array declaration. Add "+1" to the first + * dimension to allow space for the EOS. Called after LEX has recognized + * "char name[". If we reach the closing ']', convert it into a right paren + * for the second pass. + */ +void +do_char (void) +{ + char ch; + + for (ch=input(); ch != ',' && ch != ']'; ch=input()) + if (ch == '\n' || ch == EOS) { + error (XPP_SYNTAX, "Missing comma or ']' in char declaration"); + unput ('\n'); + return; + } else + output (ch); + + outstr ("+1"); + if (ch == ']') + output (')'); + else + output (ch); +} + + +/* SKIP_HELPBLOCK -- Skip over a help block (documentation section). + */ +void +skip_helpblock (void) +{ + char ch; + + + /* fgets() no longer works with FLEX + while (fgets (yytext, SZ_LINE, yyin) != NULL) { + if (istkptr == 0) + linenum[istkptr]++; + + if (yytext[0] == '.' && (yytext[1] == 'e' || yytext[1] == 'E')) { + yytext[8] = EOS; + if (strcmp (&yytext[1], "endhelp") == 0 || + strcmp (&yytext[1], "ENDHELP") == 0) + break; + } + } + */ + + while ( (ch = input()) != EOF ) { + if (ch == '.') { /* check for ".endhelp" */ + ch = input (); + if (ch == 'e' || ch == 'E') { + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + break; + } else + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + + } else if (ch == '\n') { /* skip line */ + ; + } else { + for (ch=input(); ch != '\n' && ch != EOS; ch=input()) + ; + } + if (istkptr == 0) + linenum[istkptr]++; + } +} + + +/* PARSE_TASK_STATEMENT -- Parse the task statement, building up a list + * of task_name/procedure_name structures in the "task_list" array. + * + * task task1, task2, task3=proc3, task4, ... + * + * Task names are placed in the string buffer as one big string, with EOS + * delimiters between the names. This "dictionary" string is converted + * into a data statement at "end_code" time, along with any other strings + * in the runtask procedure. The procedure names, which may differ from + * the task names, are saved in the upper half of the output buffer. We can + * do this because we know that the runtask procedure is small and will not + * come close to filling up the output buffer, which buffers only the body + * of the procedure currently being processed. + * N.B.: Upon entry, the input is left positioned to just past the "task" + * keyword. + */ +int +parse_task_statement (void) +{ + register struct task *tp; + register char ch, *ip; + char task_name[SZ_FNAME], proc_name[SZ_FNAME]; + int name_offset; + + /* Set global pointers to where we put task and proc name strings. + */ + sp = sbuf; + op = &obuf[SZ_OBUF/2]; + name_offset = 1; + + for (ntasks=0; ntasks < MAX_TASKS; ntasks++) { + /* Process "taskname" or "taskname=procname". There must be + * at least one task name in the declaration. + */ + if (get_task (task_name, proc_name, SZ_FNAME) == ERR) + return (ERR); + + /* Set up the task declaration structure, and copy name strings + * into the string buffers. + */ + tp = &task_list[ntasks]; + tp->task_name = sp; + tp->proc_name = op; + tp->name_offset = name_offset; + name_offset += strlen (task_name) + 1; + + for (ip=task_name; (*sp++ = *ip++) != EOS; ) + if (sp >= &sbuf[SZ_SBUF]) + goto err; + for (ip=proc_name; (*op++ = *ip++) != EOS; ) + if (op >= &obuf[SZ_OBUF]) + goto err; + + /* If the next character is a comma, skip it and a newline if + * one follows and continue processing. If the next character is + * a newline, we are done. Any other character is an error. + * Note that nextch skips whitespace and comments. + */ + ch = nextch(); + if (ch == ',') { + if ((ch = nextch()) != '\n') + unput (ch); + } else if (ch == '\n') { + linenum[istkptr]++; + ntasks++; /* end of task statement */ + break; + } else + return (ERR); + } + + if (ntasks >= MAX_TASKS) { +err: error (XPP_COMPERR, "too many tasks in task statement"); + return (ERR); + } + + /* Set up the task name dictionary string so that it gets output + * as a data statement when the runtask procedure is output. + */ + string_list[0].str_name = "dict"; + string_list[0].str_text = sbuf; + string_list[0].str_length = (sp - sbuf); + nstrings = 1; + + /* Leave the output buffer pointer pointing to the first half of + * the buffer. + */ + op = obuf; + return (OK); +} + + +/* GET_TASK -- Process a single task declaration of the form "taskname" or + * "taskname = procname". + */ +int +get_task (char *task_name, char *proc_name, int maxch) +{ + register char ch; + + /* Get task name. + */ + if (get_name (task_name, maxch) == ERR) + return (ERR); + + /* Get proc name if given, otherwise the procedure name is assumed + * to be the same as the task name. + */ + if ((ch = nextch()) == '=') { + if (get_name (proc_name, maxch) == ERR) + return (ERR); + } else { + unput (ch); + strncpy (proc_name, task_name, maxch); + } + + return (XOK); +} + + +/* GET_NAME -- Extract identifier from input, placing in the output string. + * ERR is returned if the output string overflows, or if the token is not + * a legal identifier. + */ +int +get_name (char *outstr, int maxch) +{ + register char ch, *op; + register int nchars; + + unput ((ch = nextch())); /* skip leading whitespace */ + + for (nchars=0, op=outstr; nchars < maxch; nchars++) { + ch = input(); + if (isalpha(ch)) { + if (isupper(ch)) + *op++ = tolower(ch); + else + *op++ = ch; + } else if ((isdigit(ch) && nchars > 0) || ch == '_' || ch == '$') { + *op++ = ch; + } else { + *op++ = EOS; + unput (ch); + return (nchars > 0 ? XOK : ERR); + } + } + + return (ERR); +} + + +/* NEXTCH -- Get next nonwhite character from the input stream. Ignore + * comments. Newline is not considered whitespace. + */ +int +nextch (void) +{ + register char ch; + + while ((ch = input()) != EOF) { + if (ch == '#') { /* discard comment */ + while ((ch = input()) != '\n') + ; + return (ch); + } else if (ch != ' ' && ch != '\t') + return (ch); + } + return (EOF); +} + + +/* PUT_DICTIONARY -- We are called when the keyword TN$DECL is encountered, + * i.e., while processing "sysruk.x". This should only happen after the + * task statement has been successfully processed. Our function is to replace + * the TN$DECL macro by the declarations for the DP and DICT structures. + * DP is an integer array giving the offsets of the task name strings in DICT, + * the dictionary string buffer. + */ +#define NDP_PERLINE 8 /* num DP data elements per line */ + +void +put_dictionary (void) +{ + register struct task *tp; + char buf[SZ_LINE]; + int i, j, offset; + + /* Discard anything found on line after the TN$DECL, which is only + * recognized as the first token on the line. + */ + while (input() != '\n') + ; + unput ('\n'); + + /* Output the data statements required to initialize the DP array. + * These statements are spooled into the output buffer and not output + * until all declarations have been processed, since the Fortran std + * requires that data statements follow declarations. + */ + pushcontext (DATASTMT); + tp = task_list; + + for (j=0; j <= ntasks; j += NDP_PERLINE) { + if (!strloopdecl++) { + pushcontext (DECL); + sprintf (buf, "%s\tiyy\n", type_decl[TY_INT]); + outstr (buf); + popcontext(); + } + + sprintf (buf, "data\t(dp(iyy),iyy=%2d,%2d)\t/", + j+1, min (j+NDP_PERLINE, ntasks+1)); + outstr (buf); + + for (i=j; i < j+NDP_PERLINE && i <= ntasks; i++) { + offset = (tp++)->name_offset; + if (i >= ntasks) + sprintf (buf, "%2d/\n", XEOS); + else if (i == j + NDP_PERLINE - 1) + sprintf (buf, "%4d/\n", offset==EOS ? XEOS: offset); + else + sprintf (buf, "%4d,", offset==EOS ? XEOS: offset); + outstr (buf); + } + } + + popcontext(); + + /* Output type declarations for the DP and DICT arrays. The string + * descriptor for string 0 (dict) was prepared when the TASK statement + * was processed. + */ + sprintf (buf, "%s\tdp(%d)\n", type_decl[XTY_INT], ntasks + 1); + outstr (buf); + sprintf (buf, "%s\tdict(%d)\n", type_decl[XTY_CHAR], + string_list[0].str_length); + outstr (buf); +} + + +/* PUT_INTERPRETER -- Output the statements necessary to scan the dictionary + * for a task and call the associated procedure. We are called when the + * keyword TN$INTERP is encountered in the input stream. + */ +void +put_interpreter (void) +{ + char lbuf[SZ_LINE]; + int i; + + while (input() != '\n') /* discard rest of line */ + ; + unput ('\n'); + + for (i=0; i < ntasks; i++) { + sprintf (lbuf, "\tif (streq (task, dict(dp(%d)))) {\n", i+1); + outstr (lbuf); + sprintf (lbuf, "\t call %s\n", task_list[i].proc_name); + outstr (lbuf); + sprintf (lbuf, "\t return (OK)\n"); + outstr (lbuf); + sprintf (lbuf, "\t}\n"); + outstr (lbuf); + } +} + + +/* OUTSTR -- Output a string. Depending on the context, the string will + * either go direct to the output file, or will be buffered in the output + * buffer. + */ +void +outstr (char *string) +{ + register char *ip; + + + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + for (ip=string; (*op++ = *ip++) != EOS; ) + ; + if (--op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + for (ip=string; (*dp++ = *ip++) != EOS; ) + ; + if (--dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + fputs (string, yyout); + } +} + + +/* BEGIN_CODE -- Code that gets executed when the keyword BEGIN is encountered, + * i.e., when we begin processing the executable part of a procedure + * declaration. + */ +void +begin_code (void) +{ + char text[1024]; + + /* If we are already processing the body of a procedure, we probably + * have a missing END. + */ + if (context & BODY) + xpp_warn ("Unmatched BEGIN statement"); + + /* Set context flag noting that we are processing the body of a + * procedure. Output the BEGIN statement, for the benefit of the + * second pass (RPP), which needs to know where the procedure body + * begins. + */ + setcontext (BODY); + d_runtime (text); outstr (text); + outstr ("begin\n"); + linenum[istkptr]++; + + /* Initialization. */ + nbrace = 0; + nswitch = 0; + str_idnum = 1; + errhand = NO; + errchk = NO; +} + + +/* END_CODE -- Code that gets executed when the keyword END is encountered + * in the input. If error checking is used in the procedure, we must declare + * the boolean function XERPOP. If any switches are employed, we must declare + * the switch variables. Next we format and output data statements for any + * strings encountered while processing the procedure body. If the procedure + * being processed is sys_runtask, the task name dictionary string is also + * output. Finally, we output the spooled procedure body, followed by and END + * statement for the benefit of the second pass. + */ +void +end_code (void) +{ + int i; + + /* If the END keyword is encountered outside of the body of a + * procedure, we leave it alone. + */ + if (!(context & BODY)) { + outstr (yytext); + return; + } + + /* Output argument and local variable declarations (see decl.c). + * Note d_enter may have been called during processing of the body + * of a procedure to make entries in the symbol table for intrinsic + * functions, switch variables, etc. (this is not currently done). + */ + d_codegen (yyout); + + setcontext (GLOBAL); + + /* Output declarations for error checking and switches. All variables + * and functions must be declared. + */ + if (errhand) + fprintf (yyout, "x$bool xerpop\n"); + if (errchk) + fprintf (yyout, "errchk error, erract\n"); + errhand = NO; + errchk = NO; + + if (nswitch) { /* declare switch variables */ + fprintf (yyout, "%s\t", type_decl[XTY_INT]); + for (i=1; i < nswitch; i++) + fprintf (yyout, "SW%04d,", i); + fprintf (yyout, "SW%04d\n", i); + } + + /* Output any miscellaneous declarations. These include ERRCHK and + * COMMON declarations - anything not a std type declaration or a + * data statement declaration. + */ + *dp++ = EOS; + fputs (dbuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_DBUF; ) dbuf[i++] = '\0'; } + dp = dbuf; + + /* Output the SAVE statement, which must come after all declarations + * and before any DATA statements. + */ + fputs ("save\n", yyout); + + /* Output data statements to initialize character strings, followed + * by any runtime procedure entry initialization statments, followed + * by the spooled text in the output buffer, followed by the END. + * Clear the string and output buffers. Any user data statements + * will already have been moved into the output buffer, and they + * will come out at the end of the declarations section regardless + * of where they were given in the declarations section. Data stmts + * are not permitted in the procedure body. + */ + init_strings(); + *op++ = EOS; + fputs (obuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_OBUF; ) obuf[i++] = '\0'; } + fputs ("end\n", yyout); fflush (yyout); + + op = obuf; + *op = EOS; + sp = sbuf; + + if (nbrace != 0) { + error (XPP_SYNTAX, "Unmatched brace"); + nbrace = 0; + } +} + + +#define BIG_STRING 9 +#define NPERLINE 8 + +/* INIT_STRINGS -- Output data statements to initialize all strings in a + * procedure ("string" declarations, inline strings, and the runtask + * dictionary). Strings are implemented as integer arrays, using the + * smallest integer datatype provided by the host Fortran compiler, usually + * INTEGER*2 (XTY_CHAR). + */ +void +init_strings (void) +{ + register int str; + + if (nstrings) + for (str=0; str < nstrings && !strloopdecl; str++) + if (string_list[str].str_length >= BIG_STRING) { + fprintf (yyout, "%s\tiyy\n", type_decl[XTY_INT]); + strloopdecl++; + } + + for (str=0; str < nstrings; str++) + write_string_data_statement (&string_list[str]); + + sp = sbuf; /* clear string buffer */ + nstrings = 0; + strloopdecl = 0; +} + + +/* WRITE_STRING_DATA_STATEMENT -- Output data statement to initialize a single + * string. If short string, output a simple whole-array data statement + * that fits all on one line. Large strings are initialized with multiple + * data statements, each of which initializes a section of the string + * using a dummy subscript. This is thought to be more portable than + * a single large data statement with continuation, because the number of + * continuation cards permitted in a data statement depends on the compiler. + * The loop variable in an implied do loop in a data statement must be declared + * on some compilers (crazy but true). Determine if we will be generating any + * implied dos and declare the variable if so. + */ +void +write_string_data_statement (struct string *s) +{ + register int i, len; + register char *ip; + char ch, *name; + int j; + + name = s->str_name; + ip = s->str_text; + len = s->str_length; + + if (len < BIG_STRING) { + fprintf (yyout, "data\t%s\t/", name); + for (i=0; i < len-1; i++) { + if ((ch = *ip++) == EOS) + fprintf (yyout, "%3d,", XEOS); + else + fprintf (yyout, "%3d,", ch); + } + fprintf (yyout, "%2d/\n", XEOS); + + } else { + for (j = 0; j < len; j += NPERLINE) { + fprintf (yyout, "data\t(%s(iyy),iyy=%2d,%2d)\t/", + name, j+1, min(j+NPERLINE, len)); + for (i=j; i < j+NPERLINE; i++) { + if (i >= len-1) { + fprintf (yyout, "%2d/\n", XEOS); + return; + } else if (i == j+NPERLINE-1) { + fprintf (yyout, "%3d/\n", ip[i]==EOS ? XEOS: ip[i]); + } else + fprintf (yyout, "%3d,", ip[i]==EOS ? XEOS: ip[i]); + } + } + } +} + + +/* DO_STRING -- Process a STRING declaration or inline string. Add a new + * string descriptor to the string list, copy text of string into sbuf, + * save name of string array in sbuf. If inline string, manufacture the + * name of the string array. + */ +void +do_string ( + char delim, /* char which delimits string */ + int strtype /* string type */ +) +{ + register char ch, *ip; + register struct string *s; + int readstr = 1; + char *str_uniqid(); + + /* If we run out of space for string storage, print error message, + * dump string decls out early, clear buffer and continue processing. + */ + if (nstrings >= MAX_STRINGS) { + error (XPP_COMPERR, "Too many strings in procedure"); + init_strings(); + } + + s = &string_list[nstrings]; + + switch (strtype) { + + case STR_INLINE: + case STR_DEFINE: + /* Inline strings are implemented as Fortran arrays; generate a + * dummy name for the array and set up the descriptor. + * Defined strings are inline strings, but the name of the text of + * the string is already in yytext when we are called. + */ + s->str_name = sp; + for (ip = str_uniqid(); (*sp++ = *ip++) != EOS; ) + ; + sbuf_check(); + break; + + case STR_DECL: + /* String declaration. Read in name of string, used as name of + * Fortran array. + */ + ch = nextch(); /* skip whitespace */ + if (!isalpha (ch)) + goto sterr; + s->str_name = sp; + *sp++ = ch; + + /* Get rest of string name identifier. */ + while ((ch = input()) != EOF) { + if (isalnum(ch) || ch == '_') { + *sp++ = ch; + sbuf_check(); + } else if (ch == '\n') { +sterr: error (XPP_SYNTAX, "String declaration syntax"); + while (input() != '\n') + ; + unput ('\n'); + return; + } else { + *sp++ = EOS; + break; + } + } + + /* Advance to the ' or " string delimiter, in preparation for + * processing the string itself. If syntax error occurs, skip + * to newline to avoid spurious error messages. If the string + * is not quoted the string value field is taken to be the name + * of a string DEFINE. + */ + delim = nextch(); + + if (!(delim == '"' || delim == '\'')) { + register char *ip, *op; + int ch; + char *str_fetch(); + + /* Fetch name of defined macro into yytext. + */ + op = yytext; + *op++ = delim; + while ((ch = input()) != EOF) + if (isalnum(ch) || ch == '_') + *op++ = ch; + else + break; + unput (ch); + *op = EOS; + + /* Fetch body of string into yytext. + */ + if ((ip = str_fetch (yytext)) != NULL) { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + readstr = 0; + } else { + error (XPP_SYNTAX, + "Undefined macro referenced in string declaration"); + } + } + + break; + } + + /* Get the text of the string. Process escape sequences. String may + * not span multiple lines. In the case of a defined string, the text + * of the string will already be in yytext. + */ + s->str_text = sp; + if (readstr && strtype != STR_DEFINE) + traverse (delim); /* process string into yytext */ + strcpy (sp, yytext); + sp += yyleng + 1; + s->str_length = yyleng + 1; + sbuf_check(); + + /* Output array declaration for string. We want the declaration to + * go into the miscellaneous declarations buffer, so toggle the + * the context to DECL before calling OUTSTR. + */ + { + char lbuf[SZ_LINE]; + + pushcontext (DECL); + sprintf (lbuf, "%s\t%s(%d)\n", type_decl[XTY_CHAR], s->str_name, + s->str_length); + outstr (lbuf); + popcontext(); + } + + /* If inline string, replace the quoted string by the name of the + * string variable. This text goes into the output buffer, rather + * than directly to the output file as is the case with the declaration + * above. + */ + if (strtype == STR_INLINE || strtype == STR_DEFINE) + outstr (s->str_name); + + if (++nstrings >= MAX_STRINGS) + error (XPP_COMPERR, "Too many strings in procedure"); +} + + +/* DO_HOLLERITH -- Process and output a Fortran string. If the output + * compiler is Fortran 77, we output a quoted string; otherwise we output + * a hollerith string. Fortran (packed) strings appear in the SPP source + * as in the statement 'call_f77_sub (arg, *"any string", arg)'. Escape + * sequences are not recognized. + */ +void +do_hollerith (void) +{ + register char *op; + char strbuf[SZ_LINE], outbuf[SZ_LINE]; + int len; + + /* Read the string into strbuf. */ + for (op=strbuf, len=0; (*op = input()) != '"'; op++, len++) + if (*op == '\n' || *op == EOF) + break; + if (*op == '\n') + error (XPP_COMPERR, "Packed string not delimited"); + else + *op = EOS; /* delete delimiter */ + +#ifdef F77 + sprintf (outbuf, "\'%s\'", strbuf); +#else + sprintf (outbuf, "%dH%s", i, strbuf); +#endif + + outstr (outbuf); +} + + +/* SBUF_CHECK -- Check to see that the string buffer has not overflowed. + * It is a fatal error if it does. + */ +void +sbuf_check (void) +{ + if (sp >= &sbuf[SZ_SBUF]) { + error (XPP_COMPERR, "String buffer overflow"); + _exit (1); + } +} + + +/* STR_UNIQID -- Generate a unit identifier name for an inline string. + */ +char * +str_uniqid (void) +{ + static char id[] = "ST0000"; + + sprintf (&id[2], "%04d", str_idnum++); + return (id); +} + + +/* TRAVERSE -- Called by the lexical analyzer when a quoted string has + * been recognized. Characters are input and deposited in yytext (the + * lexical analyzer token buffer) until the trailing quote is seen. + * Strings may not span lines unless the newline is delimited. The + * recognized escape sequences are converted upon input; all others are + * left alone, presumably to later be converted by other code. + * Quotes may be included in the string by escaping them, or by means of + * the double quote convention. + */ +void +traverse (char delim) +{ + register char *op, *cp, ch; + char *index(); + + + for (op=yytext; (*op = input()) != EOF; op++) { + if (*op == delim) { + if ((*op = input()) == EOF) + break; + if (*op == delim) + continue; /* double quote convention; keep one */ + else { + unput (*op); + break; /* normal exit */ + } + + } else if (*op == '\n') { /* error recovery exit */ + unput ('\n'); + xpp_warn ("Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + continue; + } else if ((cp = index (esc_ch, *op)) != NULL) { + *op = esc_val[cp-esc_ch]; + } else if (isdigit (*op)) { /* '\0DD' octal constant */ + *op -= '0'; + while (isdigit (ch = input())) + *op = (*op * 8) + (ch - '0'); + unput (ch); + } else { + ch = *op; /* unknown escape sequence, */ + *op++ = '\\'; /* leave it alone. */ + *op = ch; + } + } + } + + *op = EOS; + yyleng = (op - yytext); +} + + +/* ERROR -- Output an error message and set exit flag so that no linking occurs. + * Do not abort compiler, however, because it is better to keep going and + * find all the errors in a single compilation. + */ +void +error (int errcode, char *errmsg) +{ + fprintf (stderr, "Error on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], errmsg); + fflush (stderr); + errflag |= errcode; +} + + +/* WARN -- Output a warning message. Do not set exit flag since this is only + * a warning message; linking should occur if there are not any more serious + * errors. + */ +void +xpp_warn (char *warnmsg) +{ + fprintf (stderr, "Warning on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], warnmsg); + fflush (stderr); +} + + +/* ACCUM -- Code for conversion of numeric constants to decimal. Convert a + * character string to a binary integer constant, doing the conversion in the + * indicated base. + */ +long +accum (int base, char **strp) +{ + register char *ip; + long sum; + char digit; + + sum = 0; + ip = *strp; + + switch (base) { + case OCTAL: + case DECIMAL: + for (digit = *ip++; isdigit (digit); digit = *ip++) + sum = sum * base + (digit - '0'); + *strp = ip - 1; + break; + case HEX: + while ((digit = *ip++) != EOF) { + if (isdigit (digit)) + sum = sum * base + (digit - '0'); + else if (digit >= 'a' && digit <= 'f') + sum = sum * base + (digit - 'a' + 10); + else if (digit >= 'A' && digit <= 'F') + sum = sum * base + (digit - 'A' + 10); + else { + *strp = ip; + break; + } + } + break; + default: + error (XPP_COMPERR, "Accum: unknown numeric base"); + return (ERR); + } + + return (sum); +} + + +/* CHARCON -- Convert a character constant to a binary integer value. + * The regular escape sequences are recognized; numeric values are assumed + * to be octal. + */ +int +charcon (char *string) +{ + register char *ip, ch; + char *cc, *index(); + char *nump; + + ip = string + 1; /* skip leading apostrophe */ + ch = *ip++; + + /* Handle '\c' and '\0dd' notations. + */ + if (ch == '\\') { + if ((cc = index (esc_ch, *ip)) != NULL) { + return (esc_val[cc-esc_ch]); + } else if (isdigit (*ip)) { + nump = ip; + return (accum (OCTAL, &nump)); + } else + return (ch); + } else { + /* Regular characters, i.e., 'c'; just return ASCII value of char. + */ + return (ch); + } +} + + +/* INT_CONSTANT -- Called to decode an integer constant, i.e., a decimal, hex, + * octal, or sexagesimal number, or a character constant. The numeric string + * is converted in the indicated base and replaced by its decimal value. + */ +void +int_constant (char *string, int base) +{ + char decimal_constant[SZ_NUMBUF], *p; + long accum(), value; + int i; + + p = string; + i = strlen (string); + + switch (base) { + case DECIMAL: + value = accum (10, &p); + break; + case SEXAG: + value = accum (10, &p); + break; + case OCTAL: + value = accum (8, &p); + break; + case HEX: + value = accum (16, &p); + break; + + case CHARCON: + while ((p[i] = input()) != EOF) { + if (p[i] == '\n') { + error (XPP_SYNTAX, "Undelimited character constant"); + return; + } else if (p[i] == '\\') { + p[++i] = input(); + i++; + continue; + } else if (p[i] == '\'') + break; + i += 1; + } + value = charcon (p); + break; + + default: + error (XPP_COMPERR, "Unknown numeric base for integer conversion"); + value = ERR; + } + + /* Output the decimal value of the integer constant. We are simply + * replacing the SPP constant by a decimal constant. + */ + sprintf (decimal_constant, "%ld", value); + outstr (decimal_constant); +} + + +/* HMS -- Convert number in HMS format into a decimal constant, and output + * in that form. Successive : separated fields are scaled to 1/60 th of + * the preceeding field. Thus "12:30" is equivalent to "12.5". Some care + * is taken to preserve the precision of the number. + */ +void +hms (char *number) +{ + char cvalue[SZ_NUMBUF], *ip; + int bvalue, ndigits; + long scale = 10000000; + long units = 1; + long value = 0; + + for (ndigits=0, ip=number; *ip; ip++) + if (isdigit (*ip)) + ndigits++; + + /* Get the unscaled base value part of the number. */ + ip = number; + bvalue = accum (DECIMAL, &ip); + + /* Convert any sexagesimal encoded fields. */ + while (*ip == ':') { + ip++; + units *= 60; + value += (accum (DECIMAL, &ip) * scale / units); + } + + /* Convert the fractional part of the number, if any. + */ + if (*ip++ == '.') + while (isdigit (*ip)) { + units *= 10; + value += (*ip++ - '0') * scale / units; + } + + /* Format the output number. */ + if (ndigits > MIN_REALPREC) + sprintf (cvalue, "%d.%ldD0", bvalue, value); + else + sprintf (cvalue, "%d.%ld", bvalue, value); + cvalue[ndigits+1] = '\0'; + + /* Print the translated number. */ + outstr (cvalue); +} + + +/* + * Revision history (when i remembered) -- + * + * 14-Dec-82: Changed hms conversion, to produce degrees or hours, + * rather than seconds (lex pattern, add hms, delete ':' + * action from accum). + * + * 10-Mar-83 Broke C code and Lex code into separate files. + * Added support for error handling. + * Added additional type coercion functions. + * + * 20-Mar-83 Modified processing of TASK stmt to use file inclusion + * to read the RUNTASK file, making it possible to maintain + * the IRAF main as a .x file, rather than as a .r file. + * + * Dec-83 Fixed bug in processing of TASK stmt which prevented + * compilation of processes with many tasks. Added many + * comments and cleaned up the code a bit. + */ diff --git a/unix/boot/spp/xpp/xppcode.c.bak b/unix/boot/spp/xpp/xppcode.c.bak new file mode 100644 index 00000000..6db614bb --- /dev/null +++ b/unix/boot/spp/xpp/xppcode.c.bak @@ -0,0 +1,1705 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include "xpp.h" + +#define import_spp +#include <iraf.h> + +/* + * C code for the first pass of the IRAF subset preprocessor (SPP). + * The decision to initially organize the SPP compiler into two passes was + * made to permit maximum use of the existing raftor preprocessor, which is + * the basis for the second pass of the SPP. Eventually the two passes + * should be combined into a single program. Most of the operations performed + * by the first pass (XPP) should be performed AFTER macro substitution, + * rather than before as is the case in the current implementation, which + * processes macros in the second pass (RPP). + * + * Beware that this is not a very good program which was not carefully + * designed and which was never intended to have a long lifetime. The next + * step is to replace the two passes by a single program which is functionally + * very similar, but which is more carefully engineered and which is written + * in the SPP language calling IRAF file i/o. Eventually a true compiler + * will be written, providing many new features, i.e., structures and pointers, + * automatic storage class, mapped arrays, enhanced i/o support, and good + * compile time error checking. This compiler will also feature a table driven + * code generator (generating primitive Fortran statements), which will provide + * greater machine independence. + */ + + +extern char *vfn2osfn(); + +/* Escape sequence characters and their binary equivalents. + */ +char *esc_ch = "ntfr\\\"'"; +char *esc_val = "\n\t\f\r\\\"\'"; + +/* External and internal data stuctures. We need access to the LEX i/o + * buffers because we use the LEX i/o macros, which provide pushback, + * because we must change the streams to process includes, and so on. + * These definitions are VERY Lex dependent. + */ +extern char yytext[]; /* LEX character buffer */ +extern int yyleng; /* length of string in yytext */ +extern FILE *yyin, *yyout; /* LEX input, output files */ + +extern char yytchar, *yysptr, yysbuf[]; +extern int yylineno; + +#define U(x) x +/* +#define input() (((yytchar=yysptr>yysbuf?U(*--yysptr):getc(yyin))==10\ +?(yylineno++,yytchar):yytchar)==EOF?0:yytchar) +#define unput(c) {yytchar= (c);if(yytchar=='\n')yylineno--;*yysptr++=yytchar;} +*/ + +extern int input(); +extern void yyunput(); +extern char *yytext_ptr; +#define unput(c) yyunput( c, (yytext_ptr) ) + + + +int context = GLOBAL; /* lexical context variable */ +extern int hbindefs, foreigndefs; +char *machdefs[] = { "mach.h", "config.h", "" }; + +/* The task structure is used for TASK declarations. Since this is a + * throwaway program we do not bother with dynamic storage allocation, + * which would remove the limit on the number of tasks in a task statment. + */ +struct task { + char *task_name; /* logical task name */ + char *proc_name; /* name of procedure */ + short name_offset; /* offset of name in dictionary */ +}; + +/* The string structure is used for STRING declarations and for inline + * strings. Strings are stored in a fixed size, statically allocated + * string buffer. + */ +struct string { + char *str_name; /* name of string */ + char *str_text; /* ptr to text of string */ + short str_length; /* length of string */ +}; + +struct task task_list[MAX_TASKS]; +struct string string_list[MAX_STRINGS]; + +FILE *istk[MAX_INCLUDE]; /* stack for input file descriptors */ +int linenum[MAX_INCLUDE]; /* line numbers in files */ +char fname[MAX_INCLUDE][SZ_PATHNAME];/* file names */ +int istkptr = 0; /* istk pointer */ + +char obuf[SZ_OBUF]; /* buffer for body of procedure */ +char dbuf[SZ_DBUF]; /* buffer for misc proc. decls. */ +char sbuf[SZ_SBUF]; /* string buffer */ +char *sp = sbuf; /* string buffer pointer */ +char *op = obuf; /* pointer in output buffer */ +char *dp = dbuf; /* pointer in decls buffer */ +int nstrings = 0; /* number of strings so far */ +int strloopdecl; /* data dummy do index declared? */ + +int ntasks = 0; /* number of tasks in interpreter */ +int str_idnum = 0; /* for generating unique string names */ +int nbrace = 0; /* must be zero when "end" is reached */ +int nswitch = 0; /* number switch stmts in procedure */ +int errflag; +int errhand = NO; /* set if proc employs error handler */ +int errchk = NO; /* set if proc employs error checking */ + + +/* SKIPNL -- Skip to newline, e.g., when a comment is encountered. + */ +skipnl() +{ + int c; + while ((c=input()) != '\n') + ; + unput ('\n'); +} + + +/* + * CONTEXT -- Package for setting, saving, and restoring the lexical context. + * The action of the preprocessor in some cases depends upon the context, i.e., + * what type of statement we are processing, whether we are in global space, + * within a procedure, etc. + */ + +#define MAX_CONTEXT 5 /* max nesting of context */ + +int cntxstk[MAX_CONTEXT]; /* for saving context */ +int cntxsp = 0; /* save stack pointer */ + + +/* SETCONTEXT -- Set the context. Clears any saved context. + */ +setcontext (new_context) +int new_context; +{ + context = new_context; + cntxsp = 0; +} + + +/* PUSHCONTEXT -- Push a temporary context. + */ +pushcontext (new_context) +int new_context; +{ + cntxstk[cntxsp++] = context; + context = new_context; + + if (cntxsp > MAX_CONTEXT) + error (XPP_COMPERR, "save context stack overflow"); +} + + +/* POPCONTEXT -- Pop the former context. If the current context is PROCSTMT + * (just finished compiling a procedure statement) then set the context to DECL + * to indicate that we are entering the declarations section of a procedure. + */ +popcontext() +{ + if (context & PROCSTMT) { + context = DECL; + if (cntxsp > 0) + --cntxsp; + } else if (cntxsp > 0) + context = cntxstk[--cntxsp]; + + return (context); +} + + +/* Keyword table. The simple hashing scheme requires that the keywords appear + * in the table in sorted order. + */ +#define LEN_KWTBL 18 + +struct { + char *keyw; /* keyword name string */ + short opcode; /* opcode from above definitions */ + short nelem; /* number of table elements to skip if + * to get to next character class. + */ +} kwtbl[] = { + "FALSE", XTY_FALSE, 0, + "TRUE", XTY_TRUE, 0, + "bool", XTY_BOOL, 0, + "char", XTY_CHAR, 1, + "complex", XTY_COMPLEX, 0, + "double", XTY_DOUBLE, 0, + "error", XTY_ERROR, 1, + "extern", XTY_EXTERN, 0, + "false", XTY_FALSE, 0, + "iferr", XTY_IFERR, 2, + "ifnoerr", XTY_IFNOERR, 1, + "int", XTY_INT, 0, + "long", XTY_LONG, 0, + "pointer", XTY_POINTER, 1, + "procedure", XTY_PROC, 0, + "real", XTY_REAL, 0, + "short", XTY_SHORT, 0, + "true", XTY_TRUE, 0, + }; + +/* short kwindex[30]; simple alphabetic hash index */ +/* #define CINDEX(ch) (isupper(ch)?ch-'A':ch-'a') */ + +#define MAXCH 128 +short kwindex[MAXCH]; /* simple alphabetic hash index */ +#define CINDEX(ch) (ch) + + +/* HASHTBL -- Hash the keyword table. Initializes the "kwindex" hash table. + * For each character in the alphabet, the index gives the index into the + * sorted keyword table. If there is no keyword name beginning with the index + * character, the index entry is set to -1. + */ +hashtbl() +{ + int i, j; + + for (i=j=0; i <= MAXCH; i++) { + if (i == CINDEX (kwtbl[j].keyw[0])) { + kwindex[i] = j; + j = min (LEN_KWTBL-1, j + kwtbl[j].nelem + 1); + } else + kwindex[i] = -1; + } +} + + +/* FINDKW -- Lookup an indentifier in the keyword table. Return the opcode + * of the keyword, or ERR if no match. + */ +findkw() +{ + register char ch, *p, *q; + int i, ilimit; + + if (kwindex[0] == 0) + hashtbl(); + + i = CINDEX (yytext[0]); + if (i < 0 || i >= MAXCH || (i = kwindex[i]) < 0) + return (ERR); + ilimit = i + kwtbl[i].nelem; + + for (; i <= ilimit; i++) { + p = kwtbl[i].keyw + 1; + q = yytext + 1; + + for (; *p != EOS; q++, p++) { + ch = *q; + /* 5DEC95 - Don't case convert keywords. + if (isupper (ch)) + ch = tolower (ch); + */ + if (*p != ch) + break; + } + if (*p == EOS && *q == EOS) + return (kwtbl[i].opcode); + } + return (ERR); +} + + +/* MAPIDENT -- Lookup an identifier in the keyword table. If the identifier is + * not a keyword, output it as is. If a datatype keyword, the action depends + * on whether we are in a procedure body or not (i.e., whether the keyword + * begins a declaration or is a type coercion function). Most of the other + * keywords are mapped into special x$.. identifiers for further processing + * by the second pass. + */ +mapident() +{ + int i, findkw(); + char *str_fetch(); + register char *ip, *op; + + /* If not keyword and not defined string, output as is. The first + * char must be upper case for the name to be recognized as that of + * a defined string. If we are processing a "define" macro expansion + * is disabled. + */ + if ((i = findkw()) == ERR) { + if (!isupper(yytext[0]) || (context & DEFSTMT) || + (ip = str_fetch (yytext)) == NULL) { + + outstr (yytext); + return; + + } else { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + do_string ('"', STR_DEFINE); + return; + } + } + + /* If datatype keyword, call do_type. */ + if (i <= XTY_POINTER) { + do_type (i); + return; + } + + switch (i) { + case XTY_TRUE: + outstr (".true."); + break; + case XTY_FALSE: + outstr (".false."); + break; + case XTY_IFERR: + case XTY_IFNOERR: + outstr (yytext); + errhand = YES; + errchk = YES; + break; + case XTY_ERROR: + outstr (yytext); + errchk = YES; + break; + + case XTY_EXTERN: + /* UNREACHABLE (due to decl.c additions). + */ + outstr ("x$extn"); + break; + + default: + error (XPP_COMPERR, "Keyword lookup error"); + } +} + + +char st_buf[SZ_STBUF]; +char *st_next = st_buf; + +struct st_def { + char *st_name; + char *st_value; +} st_list[MAX_DEFSTR]; + +int st_nstr = 0; + +/* STR_ENTER -- Enter a defined string into the string table. The string + * table is a kludge to provide the capability to define strings in SPP. + * The problem is that XPP handles strings but RPP handles macros, hence + * strings cannot be defined. We get around this by recognizing defines + * of the form 'define NAME "..."'. If a macro with a quoted value is + * encounted we are called to enter the name and the string into the + * table. LOOKUP, above, subsequently searches the table for defined + * strings. The name must be upper case or the table will not be searched. + * + * N.B.: we are called by the lexical analyser with 'define name "' in + * yytext. The next input() will return the first char of the string. + */ +str_enter() +{ + register char *ip, *op, ch; + register struct st_def *s; + register int n; + char name[SZ_FNAME+1]; + + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Do not accept statement unless the name is upper case. + */ + if (!isupper (*ip)) { + outstr (yytext); + return; + } + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op = EOS; + + /* Check for a redefinition. */ + for (n=st_nstr, s=st_list, ch=name[0]; --n >= 0; s++) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, name) == 0) + break; + } + + /* Make a new entry?. */ + if (n < 0) { + s = &st_list[st_nstr++]; + if (st_nstr >= MAX_DEFSTR) + error (XPP_COMPERR, "Too many defined strings"); + + /* Put defined NAME in string buffer. */ + for (s->st_name = st_next, ip=name; *st_next++ = *ip++; ) + ; + } + + /* Put value in string buffer. + */ + s->st_value = st_next; + traverse ('"'); + for (ip=yytext; (*st_next++ = *ip++) != EOS; ) + ; + *st_next++ = EOS; + + if (st_next - st_buf >= SZ_STBUF) + error (XPP_COMPERR, "Too many defined strings"); +} + + +/* STR_FETCH -- Search the defined string table for the named string + * parameter and return a pointer to the string if found, NULL otherwise. + */ +char * +str_fetch (strname) +register char *strname; +{ + register struct st_def *s = st_list; + register int n = st_nstr; + register char ch = strname[0]; + + while (--n >= 0) { + if (*(s->st_name) == ch) + if (strcmp (s->st_name, strname) == 0) + return (s->st_value); + s++; + } + + return (NULL); +} + + +/* MACRO_REDEF -- Redefine the macro to automatically add a P2<T> macro + * to struct definitions. + */ +macro_redef () +{ + register int n; + register char *ip, *op, ch; + char name[SZ_FNAME]; + char value[SZ_LINE]; + + + outstr ("define\t"); + memset (name, 0, SZ_FNAME); + memset (value, 0, SZ_LINE); + + /* Skip to the first char of the name string. + */ + ip = yytext; + while (isspace (*ip)) + ip++; + while (!isspace (*ip)) + ip++; + while (isspace (*ip)) + ip++; + + /* Extract macro name. */ + for (op=name; (isalnum(*ip) || *ip == '_'); ) + *op++ = *ip++; + *op++ = '\t'; + *op = EOS; + outstr (name); + + + /* Modify value. + */ + outstr ("Memr(P2R"); + while ( (ch = input()) != EOF ) { + if (ch == '\n') { + break; + } else if (ch == '#') { /* eat a comment */ + while ((ch = input()) != '\n') + ; + break; + } else if (ch == '[') { + outstr ("("); + } else if (ch == ']') { + outstr (")"); + } else { + char chr[2]; + chr[0] = ch; chr[1] = '\0'; + outstr (chr); + } + } + + outstr (")\n"); + linenum[istkptr]++; +} + + +/* SETLINE -- Set the file line number. Used by the first pass to set + * line number after processing an include file and in various other + * places. Necessary to get correct line numbers in error messages from + * the second pass. + */ +setline() +{ + char msg[20]; + + if (istkptr == 0) { /* not in include file */ + sprintf (msg, "#!# %d\n", linenum[istkptr] - 1); + outstr (msg); + } +} + + +/* OUTPUT -- Output a character. If we are processing the body of a procedure + * or a data statement, put the character into the output buffer. Otherwise + * put the character to the output file. + * + * NOTE -- the redirection logic shown below is duplicated in OUTSTR. + */ +output (ch) +char ch; +{ + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + *op++ = ch; + if (op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + *dp++ = ch; + if (dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + putc (ch, yyout); + } +} + + +/* Datatype keywords for declarations. The special x$.. keywords are + * for communication with the second pass. Note that this table is machine + * dependent, since it maps char into type short. + */ +char *type_decl[] = RPP_TYPES; + + +/* Intrinsic functions used for type coercion. These mappings are machine + * dependent (MACHDEP). If your machine has INTEGER*2 and INTEGER*4, and + * integer cannot be passed as an argument when a short or long is expected, + * and your compiler has INT2 and INT4 type coercion intrinsic functions, + * you should use those here instead of INT (which happens to work for a VAX). + * If you cannot pass an int when a short is expected (i.e., IBM), and you + * do not have an INT2 intrinsic function, you should provide an external + * INTEGER*2 function called "int2" and use that for type coercion. Note + * that it will then be necessary to have the preprocessor automatically + * generate a declaration for the function. This nonsense will all go away + * when we set up a proper table driven code generator!! + */ +char *intrinsic_function[] = { + "", /* table is one-indexed */ + "(0 != ", /* bool(expr) */ + "int", /* char(expr) */ + "int", /* short(expr) */ + "int", /* int(expr) */ + "int", /* long(expr) */ + "real", /* real(expr) */ + "dble", /* double(expr) */ + "cmplx", /* complex(expr) */ + "int" /* pointer(expr) */ +}; + + +/* DO_TYPE -- Process a datatype keyword. The type of processing depends + * on whether we are called when processing a declaration or an expression. + * In expressions, the datatype keyword is the type coercion intrinsic + * function. DEFINE statements are a special case; we treat them as + * expressions, since macros containing datatype keywords are used in + * expressions more than in declarations. This is a kludge until the problem + * is properly resolved by processing macros BEFORE code generation. + * In the current implementation, macros are handled by the second pass (RPP). + */ +do_type (type) +int type; +{ + char ch; + + if (context & (BODY|DEFSTMT)) { + switch (type) { + case XTY_BOOL: + for (ch=input(); ch == ' ' || ch == '\t'; ch=input()) + ; + if (ch != '(') + error (XPP_SYNTAX, "Illegal boolean expr"); + outstr (intrinsic_function[type]); + return; + + case XTY_CHAR: + case XTY_SHORT: + case XTY_INT: + case XTY_LONG: + case XTY_REAL: + case XTY_DOUBLE: + case XTY_COMPLEX: + case XTY_POINTER: + outstr (intrinsic_function[type]); + return; + + default: + error (XPP_SYNTAX, "Illegal type coercion"); + } + + } else { + /* UNREACHABLE when in declarations section of a procedure. + */ + fprintf (yyout, type_decl[type]); + } +} + + +/* DO_CHAR -- Process a char array declaration. Add "+1" to the first + * dimension to allow space for the EOS. Called after LEX has recognized + * "char name[". If we reach the closing ']', convert it into a right paren + * for the second pass. + */ +do_char() +{ + char ch; + + for (ch=input(); ch != ',' && ch != ']'; ch=input()) + if (ch == '\n' || ch == EOS) { + error (XPP_SYNTAX, "Missing comma or ']' in char declaration"); + unput ('\n'); + return; + } else + output (ch); + + outstr ("+1"); + if (ch == ']') + output (')'); + else + output (ch); +} + + +/* SKIP_HELPBLOCK -- Skip over a help block (documentation section). + */ +skip_helpblock() +{ + char ch; + + + /* fgets() no longer works with FLEX + while (fgets (yytext, SZ_LINE, yyin) != NULL) { + if (istkptr == 0) + linenum[istkptr]++; + + if (yytext[0] == '.' && (yytext[1] == 'e' || yytext[1] == 'E')) { + yytext[8] = EOS; + if (strcmp (&yytext[1], "endhelp") == 0 || + strcmp (&yytext[1], "ENDHELP") == 0) + break; + } + } + */ + + while ( (ch = input()) != EOF ) { + if (ch == '.') { /* check for ".endhelp" */ + ch = input (); + if (ch == 'e' || ch == 'E') { + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + break; + } else + for (ch = input() ; ch != '\n' && ch != EOS; ch=input()) + ; + + } else if (ch == '\n') { /* skip line */ + ; + } else { + for (ch=input(); ch != '\n' && ch != EOS; ch=input()) + ; + } + if (istkptr == 0) + linenum[istkptr]++; + } +} + + +/* PARSE_TASK_STATEMENT -- Parse the task statement, building up a list + * of task_name/procedure_name structures in the "task_list" array. + * + * task task1, task2, task3=proc3, task4, ... + * + * Task names are placed in the string buffer as one big string, with EOS + * delimiters between the names. This "dictionary" string is converted + * into a data statement at "end_code" time, along with any other strings + * in the runtask procedure. The procedure names, which may differ from + * the task names, are saved in the upper half of the output buffer. We can + * do this because we know that the runtask procedure is small and will not + * come close to filling up the output buffer, which buffers only the body + * of the procedure currently being processed. + * N.B.: Upon entry, the input is left positioned to just past the "task" + * keyword. + */ +parse_task_statement() +{ + register struct task *tp; + register char ch, *ip; + char task_name[SZ_FNAME], proc_name[SZ_FNAME]; + int name_offset; + + /* Set global pointers to where we put task and proc name strings. + */ + sp = sbuf; + op = &obuf[SZ_OBUF/2]; + name_offset = 1; + + for (ntasks=0; ntasks < MAX_TASKS; ntasks++) { + /* Process "taskname" or "taskname=procname". There must be + * at least one task name in the declaration. + */ + if (get_task (task_name, proc_name, SZ_FNAME) == ERR) + return (ERR); + + /* Set up the task declaration structure, and copy name strings + * into the string buffers. + */ + tp = &task_list[ntasks]; + tp->task_name = sp; + tp->proc_name = op; + tp->name_offset = name_offset; + name_offset += strlen (task_name) + 1; + + for (ip=task_name; (*sp++ = *ip++) != EOS; ) + if (sp >= &sbuf[SZ_SBUF]) + goto err; + for (ip=proc_name; (*op++ = *ip++) != EOS; ) + if (op >= &obuf[SZ_OBUF]) + goto err; + + /* If the next character is a comma, skip it and a newline if + * one follows and continue processing. If the next character is + * a newline, we are done. Any other character is an error. + * Note that nextch skips whitespace and comments. + */ + ch = nextch(); + if (ch == ',') { + if ((ch = nextch()) != '\n') + unput (ch); + } else if (ch == '\n') { + linenum[istkptr]++; + ntasks++; /* end of task statement */ + break; + } else + return (ERR); + } + + if (ntasks >= MAX_TASKS) { +err: error (XPP_COMPERR, "too many tasks in task statement"); + return (ERR); + } + + /* Set up the task name dictionary string so that it gets output + * as a data statement when the runtask procedure is output. + */ + string_list[0].str_name = "dict"; + string_list[0].str_text = sbuf; + string_list[0].str_length = (sp - sbuf); + nstrings = 1; + + /* Leave the output buffer pointer pointing to the first half of + * the buffer. + */ + op = obuf; + return (OK); +} + + +/* GET_TASK -- Process a single task declaration of the form "taskname" or + * "taskname = procname". + */ +get_task (task_name, proc_name, maxch) +char *task_name; +char *proc_name; +int maxch; +{ + register char ch; + + /* Get task name. + */ + if (get_name (task_name, maxch) == ERR) + return (ERR); + + /* Get proc name if given, otherwise the procedure name is assumed + * to be the same as the task name. + */ + if ((ch = nextch()) == '=') { + if (get_name (proc_name, maxch) == ERR) + return (ERR); + } else { + unput (ch); + strncpy (proc_name, task_name, maxch); + } + + return (XOK); +} + + +/* GET_NAME -- Extract identifier from input, placing in the output string. + * ERR is returned if the output string overflows, or if the token is not + * a legal identifier. + */ +get_name (outstr, maxch) +char *outstr; +int maxch; +{ + register char ch, *op; + register int nchars; + + unput ((ch = nextch())); /* skip leading whitespace */ + + for (nchars=0, op=outstr; nchars < maxch; nchars++) { + ch = input(); + if (isalpha(ch)) { + if (isupper(ch)) + *op++ = tolower(ch); + else + *op++ = ch; + } else if ((isdigit(ch) && nchars > 0) || ch == '_' || ch == '$') { + *op++ = ch; + } else { + *op++ = EOS; + unput (ch); + return (nchars > 0 ? XOK : ERR); + } + } + + return (ERR); +} + + +/* NEXTCH -- Get next nonwhite character from the input stream. Ignore + * comments. Newline is not considered whitespace. + */ +nextch() +{ + register char ch; + + while ((ch = input()) != EOF) { + if (ch == '#') { /* discard comment */ + while ((ch = input()) != '\n') + ; + return (ch); + } else if (ch != ' ' && ch != '\t') + return (ch); + } + return (EOF); +} + + +/* PUT_DICTIONARY -- We are called when the keyword TN$DECL is encountered, + * i.e., while processing "sysruk.x". This should only happen after the + * task statement has been successfully processed. Our function is to replace + * the TN$DECL macro by the declarations for the DP and DICT structures. + * DP is an integer array giving the offsets of the task name strings in DICT, + * the dictionary string buffer. + */ +#define NDP_PERLINE 8 /* num DP data elements per line */ + +put_dictionary() +{ + register struct task *tp; + char buf[SZ_LINE]; + int i, j, offset; + + /* Discard anything found on line after the TN$DECL, which is only + * recognized as the first token on the line. + */ + while (input() != '\n') + ; + unput ('\n'); + + /* Output the data statements required to initialize the DP array. + * These statements are spooled into the output buffer and not output + * until all declarations have been processed, since the Fortran std + * requires that data statements follow declarations. + */ + pushcontext (DATASTMT); + tp = task_list; + + for (j=0; j <= ntasks; j += NDP_PERLINE) { + if (!strloopdecl++) { + pushcontext (DECL); + sprintf (buf, "%s\tiyy\n", type_decl[TY_INT]); + outstr (buf); + popcontext(); + } + + sprintf (buf, "data\t(dp(iyy),iyy=%2d,%2d)\t/", + j+1, min (j+NDP_PERLINE, ntasks+1)); + outstr (buf); + + for (i=j; i < j+NDP_PERLINE && i <= ntasks; i++) { + offset = (tp++)->name_offset; + if (i >= ntasks) + sprintf (buf, "%2d/\n", XEOS); + else if (i == j + NDP_PERLINE - 1) + sprintf (buf, "%4d/\n", offset==EOS ? XEOS: offset); + else + sprintf (buf, "%4d,", offset==EOS ? XEOS: offset); + outstr (buf); + } + } + + popcontext(); + + /* Output type declarations for the DP and DICT arrays. The string + * descriptor for string 0 (dict) was prepared when the TASK statement + * was processed. + */ + sprintf (buf, "%s\tdp(%d)\n", type_decl[XTY_INT], ntasks + 1); + outstr (buf); + sprintf (buf, "%s\tdict(%d)\n", type_decl[XTY_CHAR], + string_list[0].str_length); + outstr (buf); +} + + +/* PUT_INTERPRETER -- Output the statements necessary to scan the dictionary + * for a task and call the associated procedure. We are called when the + * keyword TN$INTERP is encountered in the input stream. + */ +put_interpreter() +{ + char lbuf[SZ_LINE]; + int i; + + while (input() != '\n') /* discard rest of line */ + ; + unput ('\n'); + + for (i=0; i < ntasks; i++) { + sprintf (lbuf, "\tif (streq (task, dict(dp(%d)))) {\n", i+1); + outstr (lbuf); + sprintf (lbuf, "\t call %s\n", task_list[i].proc_name); + outstr (lbuf); + sprintf (lbuf, "\t return (OK)\n"); + outstr (lbuf); + sprintf (lbuf, "\t}\n"); + outstr (lbuf); + } +} + + +/* OUTSTR -- Output a string. Depending on the context, the string will + * either go direct to the output file, or will be buffered in the output + * buffer. + */ +outstr (string) +char *string; +{ + register char *ip; + + + if (context & (BODY|DATASTMT)) { + /* In body of procedure or in a data statement (which is output + * just preceding the body). + */ + for (ip=string; (*op++ = *ip++) != EOS; ) + ; + if (--op >= &obuf[SZ_OBUF]) { + error (XPP_COMPERR, "Output buffer overflow"); + _exit (1); + } + } else if (context & DECL) { + /* Output of a miscellaneous declaration in the declarations + * section. + */ + for (ip=string; (*dp++ = *ip++) != EOS; ) + ; + if (--dp >= &dbuf[SZ_DBUF]) { + error (XPP_COMPERR, "Declarations buffer overflow"); + _exit (1); + } + } else { + /* Outside of a procedure. + */ + fputs (string, yyout); + } +} + + +/* BEGIN_CODE -- Code that gets executed when the keyword BEGIN is encountered, + * i.e., when we begin processing the executable part of a procedure + * declaration. + */ +begin_code() +{ + char text[1024]; + + /* If we are already processing the body of a procedure, we probably + * have a missing END. + */ + if (context & BODY) + xpp_warn ("Unmatched BEGIN statement"); + + /* Set context flag noting that we are processing the body of a + * procedure. Output the BEGIN statement, for the benefit of the + * second pass (RPP), which needs to know where the procedure body + * begins. + */ + setcontext (BODY); + d_runtime (text); outstr (text); + outstr ("begin\n"); + linenum[istkptr]++; + + /* Initialization. */ + nbrace = 0; + nswitch = 0; + str_idnum = 1; + errhand = NO; + errchk = NO; +} + + +/* END_CODE -- Code that gets executed when the keyword END is encountered + * in the input. If error checking is used in the procedure, we must declare + * the boolean function XERPOP. If any switches are employed, we must declare + * the switch variables. Next we format and output data statements for any + * strings encountered while processing the procedure body. If the procedure + * being processed is sys_runtask, the task name dictionary string is also + * output. Finally, we output the spooled procedure body, followed by and END + * statement for the benefit of the second pass. + */ +end_code() +{ + int i; + + /* If the END keyword is encountered outside of the body of a + * procedure, we leave it alone. + */ + if (!(context & BODY)) { + outstr (yytext); + return; + } + + /* Output argument and local variable declarations (see decl.c). + * Note d_enter may have been called during processing of the body + * of a procedure to make entries in the symbol table for intrinsic + * functions, switch variables, etc. (this is not currently done). + */ + d_codegen (yyout); + + setcontext (GLOBAL); + + /* Output declarations for error checking and switches. All variables + * and functions must be declared. + */ + if (errhand) + fprintf (yyout, "x$bool xerpop\n"); + if (errchk) + fprintf (yyout, "errchk error, erract\n"); + errhand = NO; + errchk = NO; + + if (nswitch) { /* declare switch variables */ + fprintf (yyout, "%s\t", type_decl[XTY_INT]); + for (i=1; i < nswitch; i++) + fprintf (yyout, "SW%04d,", i); + fprintf (yyout, "SW%04d\n", i); + } + + /* Output any miscellaneous declarations. These include ERRCHK and + * COMMON declarations - anything not a std type declaration or a + * data statement declaration. + */ + *dp++ = EOS; + fputs (dbuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_DBUF; ) dbuf[i++] = '\0'; } + dp = dbuf; + + /* Output the SAVE statement, which must come after all declarations + * and before any DATA statements. + */ + fputs ("save\n", yyout); + + /* Output data statements to initialize character strings, followed + * by any runtime procedure entry initialization statments, followed + * by the spooled text in the output buffer, followed by the END. + * Clear the string and output buffers. Any user data statements + * will already have been moved into the output buffer, and they + * will come out at the end of the declarations section regardless + * of where they were given in the declarations section. Data stmts + * are not permitted in the procedure body. + */ + init_strings(); + *op++ = EOS; + fputs (obuf, yyout); fflush (yyout); +{ int i; for (i=0; i < SZ_OBUF; ) obuf[i++] = '\0'; } + fputs ("end\n", yyout); fflush (yyout); + + op = obuf; + *op = EOS; + sp = sbuf; + + if (nbrace != 0) { + error (XPP_SYNTAX, "Unmatched brace"); + nbrace = 0; + } +} + + +#define BIG_STRING 9 +#define NPERLINE 8 + +/* INIT_STRINGS -- Output data statements to initialize all strings in a + * procedure ("string" declarations, inline strings, and the runtask + * dictionary). Strings are implemented as integer arrays, using the + * smallest integer datatype provided by the host Fortran compiler, usually + * INTEGER*2 (XTY_CHAR). + */ +init_strings() +{ + register int str; + + if (nstrings) + for (str=0; str < nstrings && !strloopdecl; str++) + if (string_list[str].str_length >= BIG_STRING) { + fprintf (yyout, "%s\tiyy\n", type_decl[XTY_INT]); + strloopdecl++; + } + + for (str=0; str < nstrings; str++) + write_string_data_statement (&string_list[str]); + + sp = sbuf; /* clear string buffer */ + nstrings = 0; + strloopdecl = 0; +} + + +/* WRITE_STRING_DATA_STATEMENT -- Output data statement to initialize a single + * string. If short string, output a simple whole-array data statement + * that fits all on one line. Large strings are initialized with multiple + * data statements, each of which initializes a section of the string + * using a dummy subscript. This is thought to be more portable than + * a single large data statement with continuation, because the number of + * continuation cards permitted in a data statement depends on the compiler. + * The loop variable in an implied do loop in a data statement must be declared + * on some compilers (crazy but true). Determine if we will be generating any + * implied dos and declare the variable if so. + */ +write_string_data_statement (s) +struct string *s; +{ + register int i, len; + register char *ip; + char ch, *name; + int j; + + name = s->str_name; + ip = s->str_text; + len = s->str_length; + + if (len < BIG_STRING) { + fprintf (yyout, "data\t%s\t/", name); + for (i=0; i < len-1; i++) { + if ((ch = *ip++) == EOS) + fprintf (yyout, "%3d,", XEOS); + else + fprintf (yyout, "%3d,", ch); + } + fprintf (yyout, "%2d/\n", XEOS); + + } else { + for (j = 0; j < len; j += NPERLINE) { + fprintf (yyout, "data\t(%s(iyy),iyy=%2d,%2d)\t/", + name, j+1, min(j+NPERLINE, len)); + for (i=j; i < j+NPERLINE; i++) { + if (i >= len-1) { + fprintf (yyout, "%2d/\n", XEOS); + return; + } else if (i == j+NPERLINE-1) { + fprintf (yyout, "%3d/\n", ip[i]==EOS ? XEOS: ip[i]); + } else + fprintf (yyout, "%3d,", ip[i]==EOS ? XEOS: ip[i]); + } + } + } +} + + +/* DO_STRING -- Process a STRING declaration or inline string. Add a new + * string descriptor to the string list, copy text of string into sbuf, + * save name of string array in sbuf. If inline string, manufacture the + * name of the string array. + */ +do_string (delim, strtype) +char delim; /* char which delimits string */ +int strtype; /* string type */ +{ + register char ch, *ip; + register struct string *s; + int readstr = 1; + char *str_uniqid(); + + /* If we run out of space for string storage, print error message, + * dump string decls out early, clear buffer and continue processing. + */ + if (nstrings >= MAX_STRINGS) { + error (XPP_COMPERR, "Too many strings in procedure"); + init_strings(); + } + + s = &string_list[nstrings]; + + switch (strtype) { + + case STR_INLINE: + case STR_DEFINE: + /* Inline strings are implemented as Fortran arrays; generate a + * dummy name for the array and set up the descriptor. + * Defined strings are inline strings, but the name of the text of + * the string is already in yytext when we are called. + */ + s->str_name = sp; + for (ip = str_uniqid(); (*sp++ = *ip++) != EOS; ) + ; + sbuf_check(); + break; + + case STR_DECL: + /* String declaration. Read in name of string, used as name of + * Fortran array. + */ + ch = nextch(); /* skip whitespace */ + if (!isalpha (ch)) + goto sterr; + s->str_name = sp; + *sp++ = ch; + + /* Get rest of string name identifier. */ + while ((ch = input()) != EOF) { + if (isalnum(ch) || ch == '_') { + *sp++ = ch; + sbuf_check(); + } else if (ch == '\n') { +sterr: error (XPP_SYNTAX, "String declaration syntax"); + while (input() != '\n') + ; + unput ('\n'); + return; + } else { + *sp++ = EOS; + break; + } + } + + /* Advance to the ' or " string delimiter, in preparation for + * processing the string itself. If syntax error occurs, skip + * to newline to avoid spurious error messages. If the string + * is not quoted the string value field is taken to be the name + * of a string DEFINE. + */ + delim = nextch(); + + if (!(delim == '"' || delim == '\'')) { + register char *ip, *op; + int ch; + char *str_fetch(); + + /* Fetch name of defined macro into yytext. + */ + op = yytext; + *op++ = delim; + while ((ch = input()) != EOF) + if (isalnum(ch) || ch == '_') + *op++ = ch; + else + break; + unput (ch); + *op = EOS; + + /* Fetch body of string into yytext. + */ + if ((ip = str_fetch (yytext)) != NULL) { + yyleng = 0; + for (op=yytext; (*op++ = *ip++) != EOS; ) + yyleng++; + readstr = 0; + } else { + error (XPP_SYNTAX, + "Undefined macro referenced in string declaration"); + } + } + + break; + } + + /* Get the text of the string. Process escape sequences. String may + * not span multiple lines. In the case of a defined string, the text + * of the string will already be in yytext. + */ + s->str_text = sp; + if (readstr && strtype != STR_DEFINE) + traverse (delim); /* process string into yytext */ + strcpy (sp, yytext); + sp += yyleng + 1; + s->str_length = yyleng + 1; + sbuf_check(); + + /* Output array declaration for string. We want the declaration to + * go into the miscellaneous declarations buffer, so toggle the + * the context to DECL before calling OUTSTR. + */ + { + char lbuf[SZ_LINE]; + + pushcontext (DECL); + sprintf (lbuf, "%s\t%s(%d)\n", type_decl[XTY_CHAR], s->str_name, + s->str_length); + outstr (lbuf); + popcontext(); + } + + /* If inline string, replace the quoted string by the name of the + * string variable. This text goes into the output buffer, rather + * than directly to the output file as is the case with the declaration + * above. + */ + if (strtype == STR_INLINE || strtype == STR_DEFINE) + outstr (s->str_name); + + if (++nstrings >= MAX_STRINGS) + error (XPP_COMPERR, "Too many strings in procedure"); +} + + +/* DO_HOLLERITH -- Process and output a Fortran string. If the output + * compiler is Fortran 77, we output a quoted string; otherwise we output + * a hollerith string. Fortran (packed) strings appear in the SPP source + * as in the statement 'call_f77_sub (arg, *"any string", arg)'. Escape + * sequences are not recognized. + */ +do_hollerith() +{ + register char *op; + char strbuf[SZ_LINE], outbuf[SZ_LINE]; + int len; + + /* Read the string into strbuf. */ + for (op=strbuf, len=0; (*op = input()) != '"'; op++, len++) + if (*op == '\n' || *op == EOF) + break; + if (*op == '\n') + error (XPP_COMPERR, "Packed string not delimited"); + else + *op = EOS; /* delete delimiter */ + +#ifdef F77 + sprintf (outbuf, "\'%s\'", strbuf); +#else + sprintf (outbuf, "%dH%s", i, strbuf); +#endif + + outstr (outbuf); +} + + +/* SBUF_CHECK -- Check to see that the string buffer has not overflowed. + * It is a fatal error if it does. + */ +sbuf_check() +{ + if (sp >= &sbuf[SZ_SBUF]) { + error (XPP_COMPERR, "String buffer overflow"); + _exit (1); + } +} + + +/* STR_UNIQID -- Generate a unit identifier name for an inline string. + */ +char * +str_uniqid() +{ + static char id[] = "ST0000"; + + sprintf (&id[2], "%04d", str_idnum++); + return (id); +} + + +/* TRAVERSE -- Called by the lexical analyzer when a quoted string has + * been recognized. Characters are input and deposited in yytext (the + * lexical analyzer token buffer) until the trailing quote is seen. + * Strings may not span lines unless the newline is delimited. The + * recognized escape sequences are converted upon input; all others are + * left alone, presumably to later be converted by other code. + * Quotes may be included in the string by escaping them, or by means of + * the double quote convention. + */ +traverse (delim) +char delim; +{ + register char *op, *cp, ch; + char *index(); + + + for (op=yytext; (*op = input()) != EOF; op++) { + if (*op == delim) { + if ((*op = input()) == EOF) + break; + if (*op == delim) + continue; /* double quote convention; keep one */ + else { + unput (*op); + break; /* normal exit */ + } + + } else if (*op == '\n') { /* error recovery exit */ + unput ('\n'); + xpp_warn ("Newline while processing string"); + break; + + } else if (*op == '\\') { + if ((*op = input()) == EOF) { + break; + } else if (*op == '\n') { + --op; /* explicit continuation */ + continue; + } else if ((cp = index (esc_ch, *op)) != NULL) { + *op = esc_val[cp-esc_ch]; + } else if (isdigit (*op)) { /* '\0DD' octal constant */ + *op -= '0'; + while (isdigit (ch = input())) + *op = (*op * 8) + (ch - '0'); + unput (ch); + } else { + ch = *op; /* unknown escape sequence, */ + *op++ = '\\'; /* leave it alone. */ + *op = ch; + } + } + } + + *op = EOS; + yyleng = (op - yytext); +} + + +/* ERROR -- Output an error message and set exit flag so that no linking occurs. + * Do not abort compiler, however, because it is better to keep going and + * find all the errors in a single compilation. + */ +error (errcode, errmsg) +int errcode; +char *errmsg; +{ + fprintf (stderr, "Error on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], errmsg); + fflush (stderr); + errflag |= errcode; +} + + +/* WARN -- Output a warning message. Do not set exit flag since this is only + * a warning message; linking should occur if there are not any more serious + * errors. + */ +xpp_warn (warnmsg) +char *warnmsg; +{ + fprintf (stderr, "Warning on line %d of %s: %s\n", linenum[istkptr], + fname[istkptr], warnmsg); + fflush (stderr); +} + + +/* ACCUM -- Code for conversion of numeric constants to decimal. Convert a + * character string to a binary integer constant, doing the conversion in the + * indicated base. + */ +long +accum (base, strp) +int base; +char **strp; +{ + register char *ip; + long sum; + char digit; + + sum = 0; + ip = *strp; + + switch (base) { + case OCTAL: + case DECIMAL: + for (digit = *ip++; isdigit (digit); digit = *ip++) + sum = sum * base + (digit - '0'); + *strp = ip - 1; + break; + case HEX: + while ((digit = *ip++) != EOF) { + if (isdigit (digit)) + sum = sum * base + (digit - '0'); + else if (digit >= 'a' && digit <= 'f') + sum = sum * base + (digit - 'a' + 10); + else if (digit >= 'A' && digit <= 'F') + sum = sum * base + (digit - 'A' + 10); + else { + *strp = ip; + break; + } + } + break; + default: + error (XPP_COMPERR, "Accum: unknown numeric base"); + return (ERR); + } + + return (sum); +} + + +/* CHARCON -- Convert a character constant to a binary integer value. + * The regular escape sequences are recognized; numeric values are assumed + * to be octal. + */ +charcon (string) +char *string; +{ + register char *ip, ch; + char *cc, *index(); + char *nump; + + ip = string + 1; /* skip leading apostrophe */ + ch = *ip++; + + /* Handle '\c' and '\0dd' notations. + */ + if (ch == '\\') { + if ((cc = index (esc_ch, *ip)) != NULL) { + return (esc_val[cc-esc_ch]); + } else if (isdigit (*ip)) { + nump = ip; + return (accum (OCTAL, &nump)); + } else + return (ch); + } else { + /* Regular characters, i.e., 'c'; just return ASCII value of char. + */ + return (ch); + } +} + + +/* INT_CONSTANT -- Called to decode an integer constant, i.e., a decimal, hex, + * octal, or sexagesimal number, or a character constant. The numeric string + * is converted in the indicated base and replaced by its decimal value. + */ +int_constant (string, base) +char *string; +int base; +{ + char decimal_constant[SZ_NUMBUF], *p; + long accum(), value; + int i; + + p = string; + i = strlen (string); + + switch (base) { + case DECIMAL: + value = accum (10, &p); + break; + case SEXAG: + value = accum (10, &p); + break; + case OCTAL: + value = accum (8, &p); + break; + case HEX: + value = accum (16, &p); + break; + + case CHARCON: + while ((p[i] = input()) != EOF) { + if (p[i] == '\n') { + error (XPP_SYNTAX, "Undelimited character constant"); + return; + } else if (p[i] == '\\') { + p[++i] = input(); + i++; + continue; + } else if (p[i] == '\'') + break; + i += 1; + } + value = charcon (p); + break; + + default: + error (XPP_COMPERR, "Unknown numeric base for integer conversion"); + value = ERR; + } + + /* Output the decimal value of the integer constant. We are simply + * replacing the SPP constant by a decimal constant. + */ + sprintf (decimal_constant, "%ld", value); + outstr (decimal_constant); +} + + +/* HMS -- Convert number in HMS format into a decimal constant, and output + * in that form. Successive : separated fields are scaled to 1/60 th of + * the preceeding field. Thus "12:30" is equivalent to "12.5". Some care + * is taken to preserve the precision of the number. + */ +char * +hms (number) +char *number; +{ + char cvalue[SZ_NUMBUF], *ip; + int bvalue, ndigits; + long scale = 10000000; + long units = 1; + long value = 0; + + for (ndigits=0, ip=number; *ip; ip++) + if (isdigit (*ip)) + ndigits++; + + /* Get the unscaled base value part of the number. */ + ip = number; + bvalue = accum (DECIMAL, &ip); + + /* Convert any sexagesimal encoded fields. */ + while (*ip == ':') { + ip++; + units *= 60; + value += (accum (DECIMAL, &ip) * scale / units); + } + + /* Convert the fractional part of the number, if any. + */ + if (*ip++ == '.') + while (isdigit (*ip)) { + units *= 10; + value += (*ip++ - '0') * scale / units; + } + + /* Format the output number. */ + if (ndigits > MIN_REALPREC) + sprintf (cvalue, "%d.%dD0", bvalue, value); + else + sprintf (cvalue, "%d.%d", bvalue, value); + cvalue[ndigits+1] = '\0'; + + /* Print the translated number. */ + outstr (cvalue); +} + + +/* + * Revision history (when i remembered) -- + * + * 14-Dec-82: Changed hms conversion, to produce degrees or hours, + * rather than seconds (lex pattern, add hms, delete ':' + * action from accum). + * + * 10-Mar-83 Broke C code and Lex code into separate files. + * Added support for error handling. + * Added additional type coercion functions. + * + * 20-Mar-83 Modified processing of TASK stmt to use file inclusion + * to read the RUNTASK file, making it possible to maintain + * the IRAF main as a .x file, rather than as a .r file. + * + * Dec-83 Fixed bug in processing of TASK stmt which prevented + * compilation of processes with many tasks. Added many + * comments and cleaned up the code a bit. + */ diff --git a/unix/boot/spp/xpp/xppmain.c b/unix/boot/spp/xpp/xppmain.c new file mode 100644 index 00000000..766aa41d --- /dev/null +++ b/unix/boot/spp/xpp/xppmain.c @@ -0,0 +1,225 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <stdio.h> +#include <ctype.h> +#include <string.h> +#include <stdlib.h> +#include "xpp.h" +#include "../../bootProto.h" + +#define import_spp +#define import_knames +#include <iraf.h> + +/* + * Main routine for the XPP preprocessor (first pass of the SPP compiler). + */ + +#define IRAFDEFS "host$hlib/iraf.h" + +int errflag; +int foreigndefs; +int hbindefs = 0; +char irafdefs[SZ_PATHNAME]; +char *pkgenv = NULL; +char v_pkgenv[SZ_FNAME]; + +extern FILE *yyin; +extern FILE *yyout; +extern char fname[][SZ_PATHNAME]; +extern int linenum[]; +extern char *vfn2osfn(); +extern char *os_getenv(); +char *dottor(); + +extern void ZZSTRT (void); +extern void ZZSTOP (void); +extern int yylex (void); + +static int isxfile (char *fname); + + +int main (int argc, char *argv[]) +{ + int i, rfflag, nfiles; + FILE *fp_defs, *source; + char *p; + + ZZSTRT(); + + errflag = XPP_OK; + linenum[0] = 1; + rfflag = NO; + nfiles = 0; + + /* Process flags and count the number of files. + */ + for (i=1; argv[i] != NULL; i++) { + if (argv[i][0] == '-') { + switch (argv[i][1]) { + case 'R': + /* Write .r file. */ + rfflag = YES; + break; + case 'r': + /* Not used anymore */ + if ((p = argv[++i]) == NULL) + --i; + break; + case 'h': + /* Use custom irafdefs file. */ + if ((p = argv[++i]) == NULL) + --i; + else { + foreigndefs++; + strcpy (irafdefs, p); + } + break; + case 'A': + /* Use architecture-specific include file. */ + hbindefs++; + break; + case 'p': + /* Load the environment for the named package. */ + if ((pkgenv = argv[++i]) == NULL) + --i; + else + loadpkgenv (pkgenv); + break; + default: + fprintf (stderr, "unknown option '%s'\n", argv[i]); + fflush (stderr); + } + } else if (isxfile (argv[i])) + nfiles++; + } + + /* If no package environment was specified on the command line, + * check if the user has a default package set in their environment. + */ + if (!pkgenv) { + if ((pkgenv = os_getenv("PKGENV"))) { + strcpy (v_pkgenv, pkgenv); + loadpkgenv (pkgenv = v_pkgenv); + } + } + + /* Generate pathname of <iraf.h>. + */ + if (!foreigndefs) + strcpy (irafdefs, vfn2osfn (IRAFDEFS,0)); + + /* Process either the standard input or a list of files. + */ + if (nfiles == 0) { + yyin = stdin; + yyout = stdout; + strcpy (fname[0], "STDIN"); + yylex(); + + } else { + /* Preprocess each file. + */ + for (i=1; argv[i] != NULL; i++) + if (isxfile (argv[i])) { + if (nfiles > 1) { + fprintf (stderr, "%s:\n", argv[i]); + fflush (stderr); + } + + /* Open source file. + */ + if ((source = fopen (vfn2osfn(argv[i],0), "r")) == NULL) { + fprintf (stderr, "cannot read file %s\n", argv[i]); + fflush (stderr); + errflag |= XPP_BADXFILE; + } else { + /* Open output file. + */ + if (rfflag) { + char *osfn; + osfn = vfn2osfn (dottor (argv[i]), 0); + if ((yyout = fopen (osfn, "w")) == NULL) { + fprintf (stderr, + "cannot write output file %s\n", osfn); + fflush (stderr); + errflag |= XPP_BADXFILE; + fclose (yyin); + continue; + } + } else + yyout = stdout; + + /* Open and process hlib$iraf.h. + */ + if ((fp_defs = fopen (irafdefs, "r")) == NULL) { + fprintf (stderr, "cannot open %s\n", irafdefs); + ZZSTOP(); + exit (XPP_COMPERR); + } + yyin = fp_defs; + yylex(); + linenum[0] = 1; + fclose (fp_defs); + + /* Process the source file. + */ + strcpy (fname[0], argv[i]); + yyin = source; + yylex(); + fclose (source); + + if (rfflag) + fclose (yyout); + } + } + } + + ZZSTOP(); + exit (errflag); + + return (0); +} + + +/* ISXFILE -- Does the named file have a ".x" extension. + */ +static int +isxfile (char *fname) +{ + char *p; + + if (fname[0] != '-') { + for (p=fname; *p++ != EOS; ) + ; + while (*--p != '.' && p >= fname) + ; + if (*p == '.' && *(p+1) == 'x') + return (YES); + } + return (NO); +} + + +/* DOTTOR -- Change the extension of the named file to ".r". + */ +char * +dottor (fname) +char *fname; +{ + static char rfname[SZ_PATHNAME+1]; + char *ip, *op, *lastdot; + + lastdot = NULL; + for (ip=fname, op=rfname; (*op = *ip++); op++) + if (*op == '.') + lastdot = op; + + if (lastdot) { + *(lastdot+1) = 'r'; + *(lastdot+2) = EOS; + } + + return (rfname); +} diff --git a/unix/boot/spp/xpp/zztest.x b/unix/boot/spp/xpp/zztest.x new file mode 100644 index 00000000..9cf695b0 --- /dev/null +++ b/unix/boot/spp/xpp/zztest.x @@ -0,0 +1,19 @@ +include <gio.h> + +define FOO Memr[Memi[$1+12]] # test comment + +define BAR Memr[$1] +define BAR1 Memr[$1+1] +define BAR2 Memr[TEST($1)] + +define FOOBAR Memr[$1] + +procedure hello() + +pointer xs, xe +define XS Memr[xs+($1)-1] +define XE Memr[xe+($1)-1] + +begin + call printf ("hello, world: %d\n", FOO(1)) +end |