diff options
Diffstat (limited to 'unix/boot/spp/rpp')
350 files changed, 15839 insertions, 0 deletions
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 + + |