#-h- readme ascii 01/09/84 15:54 Beta Release of Ratfor/Ratp1 and Ratp2 Joe Sventek 9 January 1984 This release of the ratfor pre-processor for the Software Tools User Group consists of three sections, with the following files: 1. Bootstrap section - the files in this section are already pre-processed into FORTRAN. Three sets of files are provided, corresponding to different defined values for a couple of constants: ratp1b???.f - bootstrap version of ratp1, the first pass of the pre-processor. ratp2b???.f - bootstrap version of ratp2, the second pass of the pre-processor. ds???.f - bootstrap version of the dynamic storage routines. lib???.f - bootstrap version of necessary library routines for ratp[12]. ratlib???.f - bootstrap version of primitive functions using FORTRAN I/O. The string `???' takes on one of the values int, 2ch or 4ch. For files where ??? == int, the symbol "character" has been defined as "integer", and the symbol "CHAR_PER_INT" is defined as 1. If ??? == 2ch, "character" is defined as "byte" and "CHAR_PER_INT" is defined to be 2. Finally, if ??? == 4ch, "character" is defined as "byte" and "CHAR_PER_INT" is defined to be 4. If your system supports a byte data type which acts like a SIGNED integer, such that one can compare it with integer literals, then the 2ch or 4ch versions of the files can be used. The ratdef files used to generate each set of files are available as ratdef???. 2. Ratfor versions of the sources with the includes already performed. For each "file.rat", there is an alternate version "filesym.rat", where the latter still references the symbols LETA, DIG0, ... instead of using the character constants. The alternate versions are ready for processing on systems which support the current portable tape processor. This has been done on our UNIX system, which is probably one of the few vanilla implementations of the portable tape. The files available are: ratp1.rat - source for ratp1 ratp2.rat - source for ratp2 ds.rat - source for dynamic storage routines lib.rat - source for library routines used by ratp[12] ratlib.rat - source for portable versions of the primitives. 3. The full blown source and documentation files. These files are: ratfor.z - source and documentation for ratp1 ratp2.z - source and documentation for ratp2 ratlib.z - source and include files for ratlib. A little descriptive explanation is in order. Each of the files ending in .rat or .z are header/trailer archive files. In addition, ratfor.z/ratfor, ratp2.z/ratp2 and ratlib.z/ratlib are also archives. If you have already brought up the previous version of the portable tape, you should be able to start playing with the archives, if need be. The reason that the dynamic storage routines are included are twofold: 1. The routines entdef, ludef and stlu, which have always been referenced by the processor from the portable tape, were not included in the standard library file on the tape. In order to implement the "undefine" construct in ratfor, it was also necessary to provide an rmdef function. 2. The previous version of the dynamic storage routines has several problems which have been solved in parallel by several individuals: a. Allocation failures generated dumps of dynamic storage contents and an abort of the program. It seems much more prudent to place the panic button in the programmer's hands, rather than taking some arbitrary action. As a result, those situations have been modified to return the value LAMBDA to the caller, with the dynamic storage dump routines available to the programmer. b. The original routines assumed that characters were integers, and forced characters to be stored that way, even if your system permitted you to use an intrinsic type different from integer. The solution to this problem was to acknowledge that FORTRAN permits one to equivalence arrays of different intrinsic types (portably). The following changes were made to implement this portable modification which results in a tremendous cost savings on systems which can use smaller data types for characters DS_DECL(Mem,MEMSIZE) generates an integer declaration of Mem(MEMSIZE) and a character declaration of cMEM(arith(CHAR_PER_INT,*,MEMSIZE). It also equivalences Mem(1) with cMem(1). All calls to dsinit, dsget, ... continue to return pointers to the integer array. Those routines which wish to access the character array use the macro cvt_to_cptr on the integer pointer to generate the character pointer. As you might guess, cvt_to_cptr(j) merely results in (j - 1) * CHAR_PER_INT + 1. These changes are achieved at the cost of extending the DS_DECL declaration slightly, and adding the three definitions for CHAR_PER_INT, cvt_to_cptr and LAMBDA. The reason that the current CHAR_PER_WORD was not used is that WORDS are nebulous quantities in some environments, and certainly have no specific linguistic meaning in FORTRAN. Obviously, if you define characters to be integers, CHAR_PER_INT will be 1, and everything collapses to the old system. Let me emphasize, NONE of the calling interfaces have changed. The only code which will be impacted is that which includes DS_DECL in the code for the purpose of manipulating the Mem array. These have obviously been modified in the pre-processor's pass1 and pass2. The file docs is an archive containing the already formatted writeups of ratp1, ratp2, and all user-visible routines in ds.rat, lib.rat and ratlib.rat. Sorry this took so long, but I had to make sure that everything worked as well as possible to avoid the usual hassles of missing files, etc. I have successfully ported this exact system to the 4.1c LBL-CSAM machine and brought it up using the system from the portable tape. The only things that I had to add to the system was the revised definitions for DS_DECL, CHAR_PER_INT, cvt_to_cptr and LAMBDA, as well as linking the two programs to the dynamic storage routines provided in ds.rat. Hope your system comes up as easily. Joe Sventek #-t- readme ascii 01/09/84 15:54 #-h- docs ascii 01/09/84 15:54 #-h- ratfor local 11-may-83 08:56:34 Ratfor (1) 21-Dec-81 Ratfor (1) NAME Ratfor - RatFor preprocessor SYNOPSIS ratp1 [-n] [file] ... | ratp2 >outfile ratfor [-n] [file] ... >outfile rat77 [-n] [file] ... >outfile DESCRIPTION Ratfor translates the ratfor programs in the named files into Fortran. If no input files are given, or the filename '-' appears, the standard input will be read. Unless the '-n' flag has been specified, a file containing general purpose software tools definitions (e.g. EOF, EOS, etc.) will be automatically opened and processed before any of the files specified are read. Syntax: Ratfor has the following syntax: prog: stmt prog stmt stmt: if (expr) stmt if (expr) stmt else stmt while (expr) stmt repeat stmt repeat stmt until (expr) for (init clause; test expr; incr clause) stmt do expr stmt do n expr stmt break break n next next n return (expr) switch (expr) { case expr: stmt ... default: stmt } digits stmt { prog } or [ prog ] other other: anything unrecognizable (i.e. fortran) clause: other clause, other -1- Ratfor (1) 21-Dec-81 Ratfor (1) where 'stmt' is any Fortran or Ratfor statement. A statement is terminated by an end-of-line or a semicolon. Character Translation: The following character translations are performed: < .lt. <= .le. == .eq. != .ne. ^= .ne. ~= .ne. >= .ge. > .gt. | .or. & .and. ! .not. ^ .not. ~ .not. Included files: The statement include file or include "file" will insert the contents of the specified file into the ratfor input in place of the 'include' statement. Quotes must surround the file name if it contains characters other than alphanumerics or underscores. Macro Definitions: The statement define(name,replacement text) defines 'name' as a macro which will be replaced with the indicated text when encountered in the source files. Any occurrences of the strings '$n' in the replacement text, where 1 <= n <= 9, will be replaced with the nth argument when the macro is actually invoked. For example: define(bump, $1 = $1 + 1) will cause the source line bump(i) to be expanded into -2- Ratfor (1) 21-Dec-81 Ratfor (1) i = i + 1 The names of macros may contain letters, digits and underline characters, but must start with a letter. Upper case is not equivalent to lower case in macro names. The replacement text is copied directly into the lookup table with no intepretation of the arguments, which differs from the procedure used in the macro utility. This "deferred evaluation" has the effect of eliminating the need for bracketing strings to get them through the macro processor unchanged. A side effect of the deferred evaluation is that defined names cannot be forced through the processor - i.e. the string "define" will never be output from the preprocessor. The inequivalence of upper and lower case in macro names may be used in this case to force the name of a user defined macro onto the output - i.e. if the user has defined a macro named mymac, the replacement text may contain the string MYMAC, which is not defined, and will pass through the processor. (For compatibility, an "mdefine" macro call has been included which interprets definitions before stacking them, as does the macro tool. When using this version, use "$(" and "$)" to indicate deferred evaluation, rather than the "[" and "]" used by the macro tool.) In addition to define, several other built-in macros are provided: arith(x,op,y) performs the "integer" arithmetic specified by op (+,-,*,/,**) on the two numeric operands and returns the result as its replacement. incr(x) converts the string x to a number, adds one to it, and returns the value as its replacement (as a character string). ifelse(a,b,c,d) compares a and b as character strings; if they are the same, c is pushed back onto the input, else d is pushed back. substr(s,m,n) produces the substring of s which starts at position m (with origin one), of length n. If n is omitted or too big, the rest of the string is used, while if m is out of range the result is a null string. lentok(str) pushes the length of the argument (# of characters) onto the input as a character string. undefine(sym) removes the definition for the symbol `sym', if it is defined. -3- Ratfor (1) 21-Dec-81 Ratfor (1) Note: the statement define name text may also be used, but will not always perform correctly for macros with parameters or multi-line replacement text. The functional form is preferred. Conditional Preprocessing: The statements ifdef(macro) ifnotdef(macro) . . . . . . elsedef elsedef . . . . . . enddef enddef conditionalize the preprocessing upon whether the macro has been previously defined or not. The `elsedef' portions of the conditionals may be omitted, if desired. The conditional bodies may be nested, up to 10 levels deep. String Declarations: The statements string name "character string" or string name(size) "character string" declare 'name' to be a character array long enough to accomodate the ascii codes for the given character string, one per array element. The array is then filled by data statements. The last word of 'name' is initialized to the symbolic parameter EOS, and indicates the end of a string. EOS must be defined either in the standard definitions file or by the user. If a size is given, name is declared to be a character array of 'size' elements. The normal escape sequences are supported in strings; in addition, to embed a quote (") in the string, one must type @". -4- Ratfor (1) 21-Dec-81 Ratfor (1) String Literals: The processing of in-line quoted strings ("..." appearing outside of the scope of a `string' declaration) is dependent upon which version of the processor you are using: ratfor "str" is converted to 3Hstr. This action is identical to previous versions of the pre-processor. ratp1 "str" is converted to an appropriate declaration for a `character' array, and the appropriate data statements are output. The variable name will be of the form STNNNZ, where NNN is replaced by a rotating sequence number. The array will be declared long enough to place the value of EOS in the last element, just as for the `string' declaration. Since these declarations are output immediately, the resulting FORTRAN code must be run through the program `ratp2', which will reorder the code to be ANSI-66 compliant. rat77 "str" is converted to the FORTRAN-77 constant 'str'. It is expected that this version of the preprocessor will NOT automatically load the standard symbols file, thus permitting the use of `rat77' to preprocess F77 code. Regardless of the version used, string literals can be continued across line boundaries by ending the line to be continued with an underline. The underline is not included as part of the literal. Leading blanks and tabs on the next line are ignored. If a quote (") is to be embedded in the string, it must be escaped, as in "a quote (@") in a string" In addition, the normal escape sequences are supported in the `ratp1' version. Character Literals: Character constants of the form 'c' are converted to the decimal integer representation of that character in the ASCII character set. For example: call putc('!') would become -5- Ratfor (1) 21-Dec-81 Ratfor (1) call putc(33) The normal escape characters are supported as character constants. For example '@n' is a NEWLINE (10). Note that this capability pre-empts the use of apostrophes for delimiting string literals. Attempts to pre-process programs utilitizing apostrophes for string literals will generate syntax errors of the form: missing apostrophe in character literal An utility `ratfix' is available for quickly correcting such code. Integer Constants: Integer constants in bases other than decimal may be specified as n%dddd... where 'n' is a decimal number indicating the base and 'dddd...' are digits in that base. For bases > 10, letters are used for digits above 9. Examples include: 8%77 (=63), 16%2ff (=767), 2%0010011 (=19). The number is converted to the equivalent decimal value using multiplication; this may cause sign problems if the number has too many digits. Lines and Continuation: Input is free-format; that is, statements may appear anywhere on a line, and the end of the line is generally considered the end of the statement. However, lines ending in special characters such as comma, +, -, and * are assumed to be continued on the next line. An exception to this rule is within a condition; the line is assumed to be continued if the condition does not fit on one line. Explicit continuation is indicated by ending a line with an underline character (_). The underline character is not copied to the output file. Comments: Comments are preceded by '#' signs and may appear anywhere in the code. -6- Ratfor (1) 21-Dec-81 Ratfor (1) Literal (unprocessed) Lines: Lines can be passed through ratfor without being processed by putting a percent "%" as the first character on the line. The percent will be removed and the line shifted one position to the left, but otherwise will be output without change. Macro invocations, long names, etc., appearing in the line will not be processed. Literal (unprocessed) Character Sequences: Sequences of characters can be passed through the processor, thus avoiding processing, by surrounding then with the tokens %(...%). The surrounding %[()] tokens will be removed and the character sequence will be output without change. Macro invocations, long names, etc. appearing in the character sequence will NOT be processed. Long Variable Name Processing: An optional capability available in the pre-processor, which may be enabled by your local tools support individual, is the capability of converting long variable names (those consisting of more than 6 alpha-numerics, embedded underscores, or both) to 6 character ANSI-66 compliant variable names. If this option is available, and has been used in a pre-processing run, a sequence of FORTRAN comment statements are output at the end of the generated FORTRAN code, with the mapping of long names to generated names. It should be noted that this mapping is not deterministic across separate compilations; as such, if `get_next_input' is compiled and placed in a library, source invocations of `get_next_input' would not map into the identical 6-character name. To permit users to preload the long name table with the names of external routines, the `linkage' statement may be used: linkage long_name external_name The pair of names is entered into the table of known long variable names, preventing any generated names for local long variables from colliding with the external name. The programmer must provide accurate information via this statement to permit access to routines with "long variable names" across compilations. If long variable name processing has not been enabled for your -7- Ratfor (1) 21-Dec-81 Ratfor (1) site, linkage is synonymous with define. NOTE: since long variable name processing is optional, its use will generate code that is inherently non-portable to sites not desiring this capability. Users wishing to write portable code should avoid long variable names. CHANGES This ratfor preprocessor differs from the original (as released by Kernighan and Plauger) in the following ways: The code has been rewritten and reorganized. Hash tables have been added for increased efficiency in searching for macro definitions and Ratfor keywords. The 'string' declaration has been included. The define processor has been augmented to support macros with arguments. Conditional preprocessing upon the definition (or lack therof) of a symbol has been included. Many extraneous gotos have been avoided. Blanks have been included in the output for increased readability. Multi-level 'break' and 'next' statements have been included. The Fortran 'DO' is allowed, as well as the ratfor one. The capability of specifying integer constants in bases other than decimal has been added. Underscores have been allowed in names. The 'define' syntax has been expanded to include the form: define name value The 'return(value)' feature has been added. Quoted file names following 'include' statements have been added to allow for special characters in file names. A method for allowing lines to pass through un-processed has -8- Ratfor (1) 21-Dec-81 Ratfor (1) been added. The 'switch' control statement has been included. Continuation lines have been implemented. Brackets have been allowed to replace braces (but NOT '$(' and '$)' ) Character constants are now supported. Groups of FORTRAN statements are permitted in the init and re-init clauses of the for statement. A method for allowing character sequences to pass through un-processed has been added. An `undefine' command has been added to permit removal of symbol definitions. Three types of literal character string processing are now possible. The default action permanently eliminates the usage of Hollerith constants in portable tools. Long variable names processing can now be enabled as a site-dependent option. FILES A generalized definition file (e.g. 'ratdef') is automatically opened and read. SEE ALSO Kernighan and Plauger's "Software Tools" Kernighan's "RATFOR - A Preprocessor for a Rational Fortran" The Unix command rc in the Unix Manual The tools 'incl' and 'macro' DIAGNOSTICS (The errors marked with asterisk '*' are fatal; all others are simply warning messages.) * arg stack overflow The argument stack for the macro processor has been exceeded. The size of the stack is determined by the symbol ARGSIZE in the source definitions file. o arith error An error occurred while evaluating the built-in macro, `arith'. * buffer overflow -9- Ratfor (1) 21-Dec-81 Ratfor (1) One of the preprocessor's internal buffers overflowed, possibly, but not necessarily, because the string buffers were exceeded. The definition SBUFSIZE in the preprocessor symbols file determines the size of the string buffers. * call stack overflow The call stack (used to store call frames) in the macro processor has been exceeded. The definition CALLSIZE in the source definition file determines the size of this stack. * cannot make identifier unique All attempts to generate an unique short variable name for the long variable name being processed failed. This message will only be seen if the long variable name processing has been enabled. o cannot open standard definitions file The special file containing general purpose ratfor definitions could not be opened, possibly because it did not exist or the user did not have access to the directory on which it resides. o can't open include File to be included could not be located, the user did not have privilege to access it, or the file could not be opened due to some problem in the local primitives. o conditional processing still active at EOF A sufficient number of "enddef" directives have not been encountered before detecting EOF on the input file. * Conditionals nested too deeply The stack for nested conditionals has overflowed. The size of the stack is specified by the value of COND_STACK_DEPTH defined in the preprocessor symbols file. * definition too long The number of characters in the name to be defined exceeded Ratfor's internal array size. The size is defined by the MAXTOK definition in the preprocessor symbols file. o duplicate case label Two case labels with identical values were detected. * EOF in string The macro processor detected an EOF in the current input file while evaluating a macro. * evaluation stack overflow The evaluation stack for the macro processor has been exceeded. This stack's size is determined by the symbol EVALSIZE in the source definition file. * for clause too long The internal buffer used to hold the clauses for the 'for' statement was exceeded. Size of this buffer is determined by the MAXFORSTK definition in the preprocessor symbols -10- Ratfor (1) 21-Dec-81 Ratfor (1) file. * getdef is confused There were horrendous problems when attempting to access the definition table o illegal break Break did not occur inside a valid "while", "for", or "repeat" loop o illegal case or default A "case" or "default" statement was detected which was not in the scope of a "switch" statement. o illegal case syntax The case label was not of the correct form. It may consist of comma-separated constants or ranges of constants. o illegal else Else clause probably did not follow an "if" clause * Illegal enddef encountered An "enddef" directive was encountered while conditional preprocessing was inactive. o illegal next "Next" did not occur inside a valid "for", "while", or "repeat" loop o illegal range in case label A case label specifying a range of values (of the form m-n) was detected in which m > n. o illegal right brace A right brace was found without a matching left brace o in entdef: no room for new definition There is insufficient memory for macro definitions, etc. Increase the MEMSIZE definition in the preprocessor. o includes nested too deeply There is a limit to the level of nesting of included files. It is dependent upon the maximum number of opened files allowed at a time, and is set by the NFILES definition in the preprocessor symbols file. o invalid case label The upper limit of a case label specifying a range was non-numeric. * invalid conditional token The token given as the argument to an "ifdef" or "ifnotdef" directive was not alpha-numeric. o invalid for clause The "for" clause did not contain a valid init, condition, and/or increment section o invalid string size The string format 'string name(size) "..."' was used, but the size was given improperly. * missing `(' in conditional The first non-blank token following an "ifdef" or "ifnotdef" directive was NOT a left parenthesis. -11- Ratfor (1) 21-Dec-81 Ratfor (1) * missing `)' in conditional An "ifdef" of "ifnotdef" directive was not properly terminated with a right parenthesis. * missing `)' in define A define(...) was not properly terminated with a right parenthesis. * missing `(' in undefine The first non-blank token following an "undefine" was NOT a left parenthesis. * missing `)' in undefine An "undefine" directive was not properly terminated with a right parenthesis. o missing apostrophe in character literal An apostrophe-delimited string NOT of the form 'c' or '@c' was encountered. * missing colon in case or default label The list of case labels, or the default label were not followed by a colon. * missing comma in define Definitions of the form 'define(name,defn)' must include the comma as a separator. o missing function name There was an error in declaring a function o missing left brace in switch statement The left brace indicating the start of the block of case labels for the "switch" statement was not encountered. o missing left paren A parenthesis was expected, probably in an "if" statement, but not found o missing literal quote The terminating "%)" to a literally quoted string was not found. o missing parenthesis in condition A right parenthesis was expected, probably in an "if" statement, but not found o missing quote A quoted string was not terminated by a quote o missing right paren A right parenthesis was expected in a Fortran (as opposed to Ratfor) statement but not found o missing string token No array name was given when declaring a string variable * multiple defaults in switch statement More than one "default" statements were detected in the scope of a single "switch" statement. o No room for generated variable name The table space used for generated long variable names has been exhausted. Increase the MEMSIZE definition in the preprocessor. This message cannot appear unless the long variable name processing has been enabled. -12- Ratfor (1) 21-Dec-81 Ratfor (1) o No room for linkage external name The table space used for generated external names has been exhausted. Increase the MEMSIZE definition in the preprocessor. This message cannot appear unless the long variable name processing has been enabled. * non-alphanumeric name Definitions may contain only alphanumeric characters and underscores. * stack overflow in parser Statements were nested at too deep a level. The stack depth is set by the MAXSTACK definition in the preprocessor symbols file. * switch table overflow More case labels were specified than the internal storage can handle. The size of the internal storage is determined by the value of MAXSWITCH defined in the preprocessor symbols file. o token too long A token (word) in the source code was too long to fit into one of Ratfor's internal arrays. The maximum size is set by the MAXTOK definition in the preprocessor symbols file. * too many characters pushed back The source code has illegally specified a Ratfor command, or has used a Ratfor keyword in an illegal manner, and the parser has attempted but failed to make sense out of it. The size of the push-back buffer is set by BUFSIZE in the preprocessor symbols file. o unbalanced parentheses Unbalanced parentheses detected in a Fortran (as opposed to Ratfor) statement o unexpected EOF An end-of-file was reached before all braces had been accounted for. This is usually caused by unmatched braces somewhere deep in the source code. o warning: possible label conflict This message is printed when the user has labeled a statement with a label in the 23000-23999 range. Ratfor statements are assigned in this range and a user-defined one may conflict with a Ratfor-generated one. * "file": cannot open Ratfor could not open an input file specified by the user on the command line. AUTHORS Original by B. Kernighan and P. J. Plauger, with rewrites and enhancements by David Hanson and friends (U. of Arizona), Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory), and Allen Akin (Georgia Institute of Technology). -13- Ratfor (1) 21-Dec-81 Ratfor (1) BUGS/DEFICIENCIES Missing parentheses or braces may cause erratic behavior. Eventually Ratfor should be taught to terminate parenthesis/brace checking at the end of each subroutine. Although one bug was fixed which caused line numbers in error messages to be incorrect, they still aren't quite right. (newlines in macro text are difficult to handle properly). Use them only as a general area in which to look for errors. Extraneous 'continue' statements are generated within Fortran 'do' statements. The 'next' statement does not work properly when used within Fortran 'do' statements. There is no way to explicitly cause a statement to begin in column 6 (i.e. a Fortran continued statement), although implicit continuation is performed. Ratfor is very slow, principally in the lexical analysis, character input, and macro processing routines (in that order). Attempts to speed it up should concentrate on the routines 'gtok', 'ngetch', and 'deftok'. An even better approach would be to re-work the lexical analyzer and parser completely. -14- #-t- ratfor local 11-may-83 08:56:34 #-h- ratp2 local 11-may-83 08:56:55 Ratp2 (1) 10-May-83 Ratp2 (1) NAME Ratp2 - Ratfor second pass processor SYNOPSIS ratp2 [file] ... >outfile DESCRIPTION `ratp2' is the second pass of the new pre-processor. It's function is to re-order the output of the first pass to be ANSI-66 compliant. It's input is simply FORTRAN code, and all statements between successive END statements are re-ordered. If filename arguments are not provided, it reads from standard input. SEE ALSO ratfor, the ratfor preprocessor, for descriptions of the language. AUTHORS Phil Scherrer wrote ratp2. BUGS/DEFICIENCIES -1- #-t- ratp2 local 11-may-83 08:56:55 #-h- clower local 11-may-83 08:56:56 Clower (3) 13-Nov-78 Clower (3) NAME Clower - fold c to lower case SYNOPSIS c = clower(c) character c DESCRIPTION Fold character c to lower case, if not already there. If c is not alphabetic, returns it unchanged. SEE ALSO fold(3), upper(3), clower(3) DIAGNOSTICS None -1- #-t- clower local 11-may-83 08:56:56 #-h- concat local 11-may-83 08:56:57 Concat (3) 23-Jul-80 Concat (3) NAME Concat - concatenate 2 strings together SYNOPSIS call concat(buf1, buf2, outstr) character buf1(ARB), buf2(ARB), outstr(ARB) DESCRIPTION Copies the arrays buf1 and buf2 into the array outstr. All arrays are ascii character arrays stored one character per array element. It is perfectly legal for `buf1' and `outstr' to be the same arrays, which results in `buf2' being appended to `buf1'. SEE ALSO scopy(3), stcopy(3), addset(3) DIAGNOSTICS None -1- #-t- concat local 11-may-83 08:56:57 #-h- ctoi local 11-may-83 08:56:58 Ctoi (3) 13-Nov-78 Ctoi (3) NAME Ctoi - convert string at in(i) to integer, increment i SYNOPSIS n = ctoi(in, i) character in(ARB) integer i # i is incremented integer n is returned as the converted integer DESCRIPTION Ctoi converts the character string at "in(i)" into an integer. A leading minus sign ('-') is allowed. Leading blanks and tabs are ignored; any subsequent digits are converted to the correct numeric value. The first non-digit seen terminates the scan; upon return, "i" points to this position. "n" is returned as the value of the integer. The "in" array is an ascii character array terminated with an EOS marker (or a non-numeric character). Zero is returned if no digits are found. SEE ALSO itoc(3) DIAGNOSTICS There are no checks for machine overflow. -1- #-t- ctoi local 11-may-83 08:56:58 #-h- cupper local 11-may-83 08:56:59 Cupper (3) 13-Nov-78 Cupper (3) NAME Cupper - convert character to upper case SYNOPSIS c = cupper(c) character c DESCRIPTION CUPPER converts ascii character c to upper case, if not already there. Non-alphabetic characters are returned unchanged. SEE ALSO upper(3), clower(3), fold(3) DIAGNOSTICS None -1- #-t- cupper local 11-may-83 08:56:59 #-h- delete local 11-may-83 08:56:59 Delete (3) 23-Mar-80 Delete (3) NAME Delete - remove a symbol from a symbol table SYNOPSIS subroutine delete (symbol, table) character symbol (ARB) pointer table DESCRIPTION 'Delete' removes the character-string symbol given as its first argument from the symbol table given as its second argument. All information associated with the symbol is lost. The symbol table specified must have been generated by the routine 'mktabl'. If the given symbol is not present in the symbol table, 'delete' does nothing; this condition is not considered an error. IMPLEMENTATION 'Delete' calls 'stlu' to determine the location of the given symbol in the symbol table. If present, it is unlinked from its hash chain. The dynamic storage space allocated to the symbol's node is returned to the system by a call to 'dsfree'. CALLS stlu, dsfree SEE ALSO enter(3), lookup(3), mktabl(3), rmtabl(3), stlu(3), dsget(3), dsfree(3), dsinit(3), sctabl(3) -1- #-t- delete local 11-may-83 08:56:59 #-h- dsfree local 11-may-83 08:57:00 Dsfree (3) 23-Mar-80 Dsfree (3) NAME Dsfree - free a block of dynamic storage SYNOPSIS subroutine dsfree (block) pointer block DESCRIPTION 'Dsfree' returns a block of storage allocated by 'dsget' to the available space list. The argument must be a pointer returned by 'dsget'. See the remarks under 'dsget' for required initialization measures. IMPLEMENTATION 'Dsfree' is an implementation of Algorithm B on page 440 of Volume 1 of The Art of Computer Programming, by Donald E. Knuth. The reader is referred to that source for detailed information. 'Dsfree' and 'dsget' maintain a list of free storage blocks, ordered by address. 'Dsfree' searches the list to find the proper location for the block being returned, and inserts the block into the list at that location. If blocks on either side of the newly-returned block are available, they are coalesced with the new block. If the block address does not correspond to the address of any allocated block, 'dsfree' remarks "attempt to free unallocated block" and returns to the user. BUGS/DEFICIENCIES The algorithm itself is not the best. SEE ALSO dsget(3), dsinit(3) -1- #-t- dsfree local 11-may-83 08:57:00 #-h- dsget local 11-may-83 08:57:01 Dsget (3) 23-Mar-80 Dsget (3) NAME Dsget - obtain a block of dynamic storage SYNOPSIS pointer function dsget (w) integer w DESCRIPTION 'Dsget' searches its available memory list for a block that is at least as large as its first argument. If such a block is found, its index in the memory list is returned; otherwise, the constant LAMBDA is returned. In order to use 'dsget', the following declaration must be present: DS_DECL (mem, MEMSIZE) where MEMSIZE is supplied by the user, and may take on any positive value between 6 and 32767, inclusive. Furthermore, memory must have been initialized with a call to 'dsinit': call dsinit (MEMSIZE) IMPLEMENTATION 'Dsget' is an implementation of Algorithm A' on pages 437-438 of Volume 1 of The Art of Computer Programming, by Donald E. Knuth. The reader is referred to that source for detailed information. 'Dsget' searches a linear list of available blocks for one of sufficient size. If none are available, a value of LAMBDA is returned; otherwise, the block found is broken into two pieces, and the index (in array 'mem') of the piece of the desired size is returned to the user. The remaining piece is left on the available space list. Should this procedure cause a block to be left on the available space list that is smaller than a threshhold size, the few extra words are awarded to the user and the block is removed entirely, thus speeding up the next search for space. BUGS/DEFICIENCIES It is somewhat annoying for the user to have to declare the storage area, but Fortran prevents effective use of pointers, so this inconvenience is necessary for now. SEE ALSO dsfree(3), dsinit(3), dsdecl(3) -1- #-t- dsget local 11-may-83 08:57:01 #-h- dsinit local 11-may-83 08:57:03 Dsinit (3) 23-Mar-80 Dsinit (3) NAME Dsinit - initialize dynamic storage space SYNOPSIS subroutine dsinit (w) integer w DESCRIPTION 'Dsinit' initializes an area of storage in the common block CDSMEM so that the routines 'dsget' and 'dsfree' can be used for dynamic storage allocation. The memory to be managed must be supplied by the user, by a declaration of the form: DS_DECL (mem, MEMSIZE) The memory size must be passed to 'dsinit' as its argument: call dsinit (MEMSIZE) IMPLEMENTATION 'Dsinit' sets up an available space list consisting of two blocks, the first empty and the second containing all remaining memory. The first word of memory (below the available space list) is set to the total size of memory; this information is used only by the dump routines 'dsdump' and 'dsdbiu'. CALLS error SEE ALSO dsget(3), dsfree(3), dsdecl(3) -1- #-t- dsinit local 11-may-83 08:57:03 #-h- endst local 11-may-83 08:57:04 Endst (2) 20-Aug-81 Endst (2) NAME Endst - perform system-dependent cleanup and terminate ratfor program SYNOPSIS subroutine endst(status) integer status DESCRIPTION `endst' is normally implicitly called when the `main' subroutine executes a return. `endst' closes all open files, performs any necessary system-dependent cleanup and terminates the program's execution. If it is possible, endst should communicate the termination status (OK/ERR/CHILD_ABORTED) to the outside world. `endst' is also called by `error' to terminate the program. IMPLEMENTATION SEE ALSO close(2), initst(2) DIAGNOSTICS none -1- #-t- endst local 11-may-83 08:57:04 #-h- entdef local 11-may-83 08:57:05 Entdef (3) 14-Mar-82 Entdef (3) NAME Entdef - enter a new symbol definition, discarding any old one SYNOPSIS subroutine entdef(name, defn, table) character name(ARB), defn(ARB) pointer table DESCRIPTION `entdef' enters a (name,defn) pair into the symbol table `table'. If any old definitions for `name' exist, they are purged. `table' must have been obtained by a call to `mktabl'. If the (name,defn) pair cannot be stored in the table, the error message in entdef: no room for new definition. is displayed on error output. SEE ALSO mktabl(3), ludef(3) DIAGNOSTICS If the symbol definition cannot be entered, an error message is displayed to the user. -1- #-t- entdef local 11-may-83 08:57:05 #-h- enter local 11-may-83 08:57:05 Enter (3) 23-Mar-80 Enter (3) NAME Enter - place symbol in symbol table SYNOPSIS integer function enter (symbol, info, table) character symbol (ARB) integer info (ARB) pointer table DESCRIPTION 'Enter' places the character-string symbol given as its first argument, along with the information given in its second argument, into the symbol table given as its third argument. If the symbol is successfully entered in the table, the value of OK is returned; otherwise, the value ERR is returned. The symbol table used must have been created by the routine 'mktabl'. The size of the info array must be at least as large as the symbol table node size, determined at table creation time. Should the given symbol already be present in the symbol table, its information field will simply be overwritten with the new information. 'Enter' uses the dynamic storage management routines, which require initialization by the user; see 'dsinit' for further details. IMPLEMENTATION 'Enter' calls 'stlu' to find the proper location for the symbol. If the symbol is not present in the table, a call to 'dsget' fetches a block of memory of sufficient size, which is then linked onto the proper chain from the hash table. Once the location of the node for the given symbol is known, the contents of the information array are copied into the node's information field. CALLS stlu, dsget SEE ALSO lookup(3), delete(3), mktabl(3), rmtabl(3), stlu(3), dsget(3), dsfree(3), dsinit(3), sctabl(3) -1- #-t- enter local 11-may-83 08:57:05 #-h- equal local 11-may-83 08:57:07 Equal (3) 13-Nov-78 Equal (3) NAME Equal - compare str1 to str2; return YES if equal SYNOPSIS stat = equal(str1, str2) character str1(ARB), str2(ARB) integer stat is returned as YES/NO DESCRIPTION Compares two strings, returning YES if they are the same, NO if they differ. Each string is an ascii character array terminated with an EOS marker. SEE ALSO strcmp(3) DIAGNOSTICS None -2- #-t- equal local 11-may-83 08:57:07 #-h- error local 11-may-83 08:57:08 Error (3) 23-Jul-80 Error (3) NAME Error - print single-line message and terminate execution SYNOPSIS call error (message) integer message #message is a hollerith array DESCRIPTION Error writes the message onto the standard error file ERROUT. A NEWLINE is always generated, even though one may not appear in the message. Endst is called and execution ceases. Error is essentially a call to 'remark' and then to 'endst'. The message array is a Fortran hollerith string in the format generated by the Ratfor quoted string capability. On some systems, it may be necessary to terminate the string with a '.' or other end-of-string marker. SEE ALSO remark(2), putlin(2), prompt(2), endst(2) DIAGNOSTICS None -1- #-t- error local 11-may-83 08:57:08 #-h- esc local 11-may-83 08:57:09 Esc (3) 23-Jul-80 Esc (3) NAME Esc - map array(i) into escaped character, if appropriate SYNOPSIS character function esc(array, i) character array(ARB) integer i # i will be incremented DESCRIPTION This function checks array(i) for the existence of an escape character (as defined by ESCAPE in the general symbol definitions). If an escape is found and is appropriate, array(i+1) is returned as the escaped character. If no escape is found, the character `array(i)' is returned. Those characters which have special meaning are: b backspace (BS) ^H f formfeed (FF) ^L l linefeed (LF) ^J n newline (LF) ^J r return (CR) ^M t tab (HT) ^I In addition, specifying '@ddd', where '0' <= d <= '7', results in the encoding of a character with that octal representation. Therefore, a ^Z character (SUB or 8%026) could be specified as '@026'. If the character after the escape is not one of the above or a string of digits, then that character is returned, unchanged. SEE ALSO index(3), type(3) DIAGNOSTICS None -1- #-t- esc local 11-may-83 08:57:09 #-h- fold local 11-may-83 08:57:10 Fold (3) 13-Nov-78 Fold (3) NAME Fold - convert string to lower case SYNOPSIS call fold (str) character str(ARB) DESCRIPTION Converts the array 'str' to lower case characters. Non-alphabetic characters are left unchanged. The 'str' array is ascii characters terminated by an EOS marker. SEE ALSO clower(3), cupper(3), upper(3) DIAGNOSTICS None -1- #-t- fold local 11-may-83 08:57:10 #-h- getch local 11-may-83 08:57:11 Getch (2) 20-Aug-81 Getch (2) NAME Getch - read character from file SYNOPSIS character function getch( c, fd) character c filedes fd DESCRIPTION `getch' reads the next character from the file specified by `fd'. The character is returned in ASCII format both as the functional return and in the parameter `c'. If the end of a line has been encountered, NEWLINE is returned. If the end of the file has been encountered, EOF is returned. If the unit `fd' is a RAW or RARE terminal unit, then getch actually gets the next character from the terminal WITH NO ECHO. IMPLEMENTATION Interspersed calls to `getch' and `getlin' should interleave properly. A common implementation is to have `getlin' make repeated calls to `getch'. If the input file is not ASCII, characters are mapped into their ASCII equivalent. SEE ALSO getlin(2), putch(2), putlin(2), stmode(2) DIAGNOSTICS If an error occurs during the reading of the file, the value ERR is returned. -1- #-t- getch local 11-may-83 08:57:11 #-h- getlin local 11-may-83 08:57:12 Getlin (2) 21-Aug-81 Getlin (2) NAME Getlin - get next line from file SYNOPSIS integer function getlin( line, fd) character line(MAXLINE) filedes fd DESCRIPTION `getlin' copies the next line from the file specified by the internal identifier `fd' into the character array `line'. Characters are copied until a NEWLINE character is found or until MAXLINE-1 characters have been copied. The characters are returned with the character array terminated by an EOS character. `getlin' returns EOF when it encounters an end-of-file, otherwise it returns the line length (including NEWLINE, excluding EOS). Interspersed calls to `getlin' and `getch' are permitted and should work properly. IMPLEMENTATION If the external representation of characters is not ASCII, the characters are mapped into their ASCII equivalents. `getlin' assumes a maximum size (MAXLINE) of the array `line'. If the input line exceeds the limit, only the first "limit-1" characters are returned, with the remainder of the line either being ignored or returned on the next `getlin' call. A common implementation is to have `getlin' call getch until a NEWLINE character is found (or the buffer size is exceeded or EOF is reached). If the underlying disk structure is record oriented (as opposed to stream oriented), it may be more efficient to have `getlin' get the next record in the same way that `getch' does, to avoid the overhead of repeated calls to `getch'. Use of `getlin' on RAW terminal units is of questionable utility, since the repeated `getch' calls perform a READ WITH NO ECHO, and would only terminate when the user types a CTRL/J (LINEFEED) character. All utilities which use RAW I/O have their own line gathering routines. SEE ALSO getch(2), putch(2), putlin(2), stmode(2) -1- Getlin (2) 21-Aug-81 Getlin (2) DIAGNOSTICS none -2- #-t- getlin local 11-may-83 08:57:12 #-h- index local 11-may-83 08:57:14 Index (3) 13-Nov-78 Index (3) NAME Index - find character c in string str SYNOPSIS loc = index(str, c) character str(ARB), c integer loc is returned as the location is str where c was located DESCRIPTION Returns the index of the first character in 'str' that matches 'c', or zero if 'c' isn't in the array. 'Str' is an ascii character array terminated with an EOS marker. 'c' is a single ascii character. SEE ALSO match(3), getpat(3), indexs(3) DIAGNOSTICS None -1- #-t- index local 11-may-83 08:57:14 #-h- initst local 11-may-83 08:57:15 Initst (2) 20-Aug-81 Initst (2) NAME Initst - initialize ratfor runtime environment SYNOPSIS subroutine initst DESCRIPTION Normally, `initst' is implicitly called before the main subroutine of the user's program is called. `initst' opens STDIN, STDOUT and ERROUT, performing any redirections specified in the command line and masking those redirections from the current process. The remainder of the command line arguments are prepared for retrieval via `getarg', and any other system-dependent initialization is performed. IMPLEMENTATION The standard I/O units are generally opened in the order ERROUT, STDIN and STDOUT. If an error occurs during the opening of ERROUT, some system-dependent method of reporting the error will need to be used, whereas if an error occurs while opening STDIN or STDOUT, ERROUT can be used to report it. The fetching of command line arguments from the operating system is in the domain of `initst', as well as any initializations of common data areas needed by the other primitive functions. SEE ALSO endst(2), getarg(2), delarg(2) DIAGNOSTICS If `initst' cannot function for some reason, the program should abort with a diagnostic message. -1- #-t- initst local 11-may-83 08:57:15 #-h- itoc local 11-may-83 08:57:17 Itoc (3) 13-Nov-78 Itoc (3) NAME Itoc - convert integer to character string SYNOPSIS length = itoc(int, str, size) integer int, size character str(ARB) integer length returned as the number of characters needed DESCRIPTION Converts an integer 'int' to characters in array 'str', which is at most 'size' characters long. 'length' is returned as the number of characters the integer took, not including the EOS marker. Characters are stored in ascii character arrays terminated with an EOS marker. Negative numbers are handled correctly. SEE ALSO ctoi(3), putdec(3), putint(3), gitocf(3) DIAGNOSTICS None -1- #-t- itoc local 11-may-83 08:57:17 #-h- length local 11-may-83 08:57:17 Length (3) 13-Nov-78 Length (3) NAME Length - compute length of string SYNOPSIS n = length(str) character str(ARB) integer n returned as the number of characters in str DESCRIPTION Computes the length of a character string, excluding the EOS. The string is an ascii character array terminated with an EOS marker. SEE ALSO DIAGNOSTICS None -1- #-t- length local 11-may-83 08:57:17 #-h- lookup local 11-may-83 08:57:18 Lookup (3) 23-Mar-80 Lookup (3) NAME Lookup - retrieve information from a symbol table SYNOPSIS integer function lookup (symbol, info, table) character symbol (ARB) integer info (ARB) pointer table DESCRIPTION 'Lookup' examines the symbol table given as its third argument for the presence of the character-string symbol given as its first argument. If the symbol is not present, 'lookup' returns 'NO'. If the symbol is present, the information associated with it is copied into the information array passed as the second argument to 'lookup', and 'lookup' returns 'YES'. The symbol table used must have been created by the routine 'mktabl'. The size of the information array must be at least as great as the symbol table node size, specified at its creation. Note that all symbol table routines use dynamic storage space, which must have been previously initialized by a call to 'dsinit'. IMPLEMENTATION 'Lookup' calls 'stlu' to determine the location of the symbol in the table. If 'stlu' returns NO, then the symbol is not present, and 'lookup' returns NO. Otherwise, 'lookup' copies the information field from the appropriate node of the symbol table into the information array and returns YES. ARGUMENTS MODIFIED info CALLS stlu SEE ALSO enter(3), delete(3), mktabl(3), rmtabl(3), stlu(3), sctabl(3), dsinit(3), dsget(3), dsfree(3) -1- #-t- lookup local 11-may-83 08:57:18 #-h- ludef local 11-may-83 08:58:09 Ludef (3) 14-Mar-82 Ludef (3) NAME Ludef - look up a defined symbol, returning its definition SYNOPSIS integer function ludef(name, defn, table) character name(ARB), defn(ARB) pointer table DESCRIPTION `ludef' looks up `name' in the symbol table `table', returning its definition in `defn'. If the symbol is found, a value of YES is returned as the function value, otherwise, NO. `defn' is assumed to be large enough to hold the definition stored. `table' must have been obtained by a call to `mktabl'. SEE ALSO mktabl(3), entdef(3) DIAGNOSTICS Returns a value of NO if the symbol cannot be found. -1- #-t- ludef local 11-may-83 08:58:09 #-h- mktabl local 11-may-83 08:58:10 Mktabl (3) 23-Mar-80 Mktabl (3) NAME Mktabl - make a symbol table SYNOPSIS pointer function mktabl (nodesize) integer nodesize DESCRIPTION 'Mktabl' creates a symbol table for manipulation by the routines 'enter', 'lookup', 'delete', and 'rmtabl'. The symbol table is a general means of associating data with a symbol identified by a character string. The sole argument to 'mktabl' is the number of (integer) words of information that are to be associated with each symbol. The function return is the address of the symbol table in dynamic storage space (see 'dsinit' and 'dsget'). This value must be passed to the other symbol table routines to select the symbol table to be manipulated. If an allocation failure occurs, the value LAMBDA is returned. Note that dynamic storage space must be initialized by a call to 'dsinit' before using any symbol table routines. IMPLEMENTATION 'Mktabl' calls 'dsget' to allocate space for a hash table in dynamic memory. Each entry in the hash table is the head of a linked list (with zero used as a null link) of symbol table nodes. 'Mktabl' also records the nodesize specified by the user, so 'enter' will know how much space to allocate when a new symbol is entered in the table. CALLS dsget SEE ALSO enter(3), lookup(3), delete(3), rmtabl(3), stlu(3), dsget(3), dsfree(3), dsinit(3), sctabl(3) DIAGNOSTICS If an allocation failure occurs, the value LAMBDA is returned. -1- #-t- mktabl local 11-may-83 08:58:10 #-h- putch local 11-may-83 08:58:11 Putch (2) 20-Aug-81 Putch (2) NAME Putch - write character to file SYNOPSIS subroutine putch( c, fd) character c filedes fd DESCRIPTION `putch' writes the character `c' onto the file specified by `fd'. If `c' is the NEWLINE character, the appropriate action is taken to indicate the end of the record on the file. The character is assumed to be in ASCII format; if the external representation is not ASCII, the necessary conversion is done. If fd' corresponds to a RAW or RARE terminal unit, the character `c' is immediately written to the terminal with no interpretation by the native operating system's terminal handler. IMPLEMENTATION Interspersed calls to `putch' and `putlin' should work properly. SEE ALSO putlin(2), getch(2), getlin(2), stmode(2) DIAGNOSTICS If an error occurs when a record is flushed, an ugly error message will appear on your terminal. -1- #-t- putch local 11-may-83 08:58:11 #-h- putlin local 11-may-83 08:58:11 Putlin (2) 20-Aug-81 Putlin (2) NAME Putlin - output a line onto a given file SYNOPSIS subroutine putlin( line, fd) character line(ARB) filedes fd DESCRIPTION `putlin' outputs the character array `line' onto the file specified by `fd'. `line' is an ASCII character array terminated with an EOS character. NEWLINE characters are permitted in the array, with the effect of flushing the record since the last NEWLINE character. If none is specified, no carriage-return (or end-of-record) is assumed. If the external representation is not ASCII, translation occurs before writing the record. If `fd' is a RAW or RARE mode terminal unit, the `line' buffer is written immediately to the terminal, with no interpretation by the terminal driver. IMPLEMENTATION Interspersed calls to `putch' and `putlin' are permitted. A common implementation for COOKED mode units is to have `putlin' call `putch' until an EOS character is found. SEE ALSO putch(2), getch(2), getlin(2), stmode(2) DIAGNOSTICS none -1- #-t- putlin local 11-may-83 08:58:11 #-h- remark local 11-may-83 08:58:12 Remark (2) 20-Aug-80 Remark (2) NAME Remark - print single-line message SYNOPSIS subroutine remark(messag) character messag(ARB) DESCRIPTION `remark' writes the message onto the standard error file ERROUT. A NEWLINE is always generated, even though one may not appear in the message. The `messag' array is generally a Fortran hollerith string in the format generated by the Ratfor quoted string capability. It may also be an character array terminated with an EOS character. IMPLEMENTATION If a quoted string is used as the argument to remark, it should, by convention, be terminated by a PERIOD (`.'). This permits all implementations to locate the end of the string to print. If a NEWLINE character is not found at the end of the string, one must be `putch'ed to ERROUT. SEE ALSO putlin(2) DIAGNOSTICS none -1- #-t- remark local 11-may-83 08:58:12 #-h- rmdef local 11-may-83 08:58:13 Rmdef (3) 17-Dec-82 Rmdef (3) NAME Rmdef - remove a symbol and its definition from a symbol table SYNOPSIS subroutine rmdef(symbol, table) character symbol(ARB) pointer table DESCRIPTION `rmdef' removes a symbol and its definition from the symbol table `table'. `table' must have been obtained by a call to `mktabl'. SEE ALSO mktabl(3), ludef(3), entdef(3) DIAGNOSTICS -1- #-t- rmdef local 11-may-83 08:58:13 #-h- rmtabl local 11-may-83 08:58:13 Rmtabl (3) 23-Mar-80 Rmtabl (3) NAME Rmtabl - remove a symbol table SYNOPSIS subroutine rmtabl (table) pointer table DESCRIPTION 'Rmtabl' is used to remove a symbol table created by 'mktabl'. The sole argument is the address of a symbol table in dynamic storage space, as returned by 'mktabl'. 'Rmtabl' deletes each symbol still in the symbol table, so it is normally not necessary to empty a symbol table before deleting it. However, if the information associated with a symbol includes a pointer to dynamic storage space, the space will not be reclaimed. (This problem can be averted by scanning the symbol table with 'sctabl' and freeing dynamic objects, then removing the symbol table with 'rmtabl'.) Please see the manual entry for 'dsinit' for instructions on initializing the dynamic storage space used by the symbol table routines. IMPLEMENTATION 'Rmtabl' traverses each chain headed by the hash table created by 'mktabl'. Each symbol table node encountered along the way is returned to free storage by a call to 'dsfree'. Once all symbols are removed, the hash table itself is returned by a similar call. CALLS dsfree SEE ALSO mktabl(3), enter(3), lookup(3), delete(3), dsget(3), dsfree(3), dsinit(3), sctabl(3) -1- #-t- rmtabl local 11-may-83 08:58:13 #-h- scopy local 11-may-83 08:58:15 Scopy (3) 13-Nov-78 Scopy (3) NAME Scopy - copy string at from(i) to to(j) SYNOPSIS call scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j DESCRIPTION Copies the (sub)string of 'from', starting in location 'i', into array 'to', starting at 'j'. SEE ALSO stcopy(3), addset(3), concat(3) DIAGNOSTICS None -1- #-t- scopy local 11-may-83 08:58:15 #-h- sctabl local 11-may-83 08:58:15 Sctabl (3) 16-Mar-80 Sctabl (3) NAME Sctabl - scan all symbols in a symbol table SYNOPSIS integer function sctabl (table, symbol, info, posn) pointer table, posn integer info (ARB) character symbol (ARB) DESCRIPTION 'Sctabl' provides a means of accessing all symbols present in a symbol table (c.f. 'mktabl') without knowledge of the table's internal structure. After a simple initialization (see below), successive calls to 'sctabl' return symbols and their associated information. When the return value of 'sctabl' is EOF, the entire table has been scanned. The first argument is the index in dynamic storage of the symbol table to be accessed. (This should be the value returned by 'mktabl'.) The second and third arguments receive the character text of and integer information associated with the symbol currently under scan. The fourth argument is used to keep track of the current position in the symbol table. It must be initialized to zero before 'sctabl' is called for the first time for a given scan. The function return is EOF when the entire table has been scanned, not EOF otherwise. IMPLEMENTATION If 'posn' is zero, 'sctabl' assigns the location of a two-word block in the table header to it. These words are used to keep track of (1) the hash table bucket currently in use and (2) the position in the bucket's list of the next symbol. If a symbol is available in the current list, 'sctabl' returns its data and records the position of the next symbol in the list; otherwise, it moves to the next bucket and examines that list. If there are no more buckets in the symbol table, EOF is returned as the function value and 'posn' is set to zero. ARGUMENTS MODIFIED symbol, info, posn CALLS dsget, dsfree BUGS/DEFICIENCIES -1- Sctabl (3) 16-Mar-80 Sctabl (3) A call to 'enter' must be made to update the information associated with a symbol. If new symbols are entered or old symbols deleted during a scan, the results are unpredictable. The argument order is bogus; all the other symbol table routines have the table pointer as the last argument. SEE ALSO lookup(3), delete(3), mktabl(3), rmtabl(3), stlu(3), dsget(3), dsfree(3), dsinit(3) -2- #-t- sctabl local 11-may-83 08:58:15 #-h- sdupl local 11-may-83 08:58:17 Sdupl (3) 14-Mar-82 Sdupl (3) NAME Sdupl - duplicate a string in dynamic storage SYNOPSIS pointer function sdupl(str) character str(ARB) DESCRIPTION `sdupl' allocates space for `str' in dynamic storage, and copies the string into the allocated space. A pointer to the dynamic space is returned as the value of the function. If the allocation fails, a value of LAMBDA is returned. `dsinit' must have been called before this function can be called. SEE ALSO dsinit(3) DIAGNOSTICS Returns a value of LAMBDA if the allocation fails. -1- #-t- sdupl local 11-may-83 08:58:17 #-h- skipbl local 11-may-83 08:58:17 Skipbl (3) 13-Nov-78 Skipbl (3) NAME Skipbl - skip blanks and tabs at str(i) SYNOPSIS call skipbl(str, i) character str(ARB) integer i # i is incremented DESCRIPTION Starting at position 'i' of array 'str', increments i while str(i) is a BLANK or TAB. 'Str' is an ascii character array terminated with an EOS marker. SEE ALSO getwrd(3) DIAGNOSTICS None -1- #-t- skipbl local 11-may-83 08:58:17 #-h- stlu local 11-may-83 08:58:18 Stlu (3) 14-Mar-82 Stlu (3) NAME Stlu - symbol table lookup primitive SYNOPSIS integer function stlu(symbol, node, pred, table) character symbol(ARB) pointer node, pred, table DESCRIPTION `stlu' looks up the token `symbol' in the symbol table `table', returning a pointer to the symbol in `node' if it found. The variable `pred' is used as a scratch pointer during the search. If the symbol is found, a value of YES is returned, otherwise, NO. `table' is the return value of `mktabl', and the symbol would have been entered by using the `enter' function. SEE ALSO mktabl(3), enter(3) DIAGNOSTICS A value of NO is returned if the symbol cannot be found in the table. -1- #-t- stlu local 11-may-83 08:58:18 #-h- type local 11-may-83 08:58:19 Type (3) 13-Nov-78 Type (3) NAME Type - determine type of character SYNOPSIS t = type(c) character c character t is returned as LETTER, DIGIT, or c DESCRIPTION This function determines whether the character 'c' is a letter, a digit, or something else; it returns LETTER, DIGIT, or the character itself. SEE ALSO index(3) DIAGNOSTICS None -1- #-t- type local 11-may-83 08:58:19 #-h- upper local 11-may-83 08:58:19 Upper (3) 13-Nov-78 Upper (3) NAME Upper - convert string to upper case SYNOPSIS call upper(str) character str(ARB) DESCRIPTION Converts the array 'str' to upper case, if not already there. If any characters are non-alphabetic, it leaves them unchanged. 'Str' is an ascii character array terminated with an EOS marker. SEE ALSO cupper(3), fold(3), clower(3) DIAGNOSTICS None -1- #-t- upper local 11-may-83 08:58:19 #-h- ratfix local 11-may-83 14:38:39 Ratfix (1) 10-May-83 Ratfix (1) NAME Ratfix - Convert old style ratfor to new style SYNOPSIS ratfix [file] ... DESCRIPTION `ratfix' converts ratfor which was valid for the last Software Tools distributed version of the ratfor pre-processor to a form which is valid for the newly released version of the processor. Two items are corrected: 1. Quoted strings which are delimited by '...' are converted to "...". This is necessary, since apostrophe's are now used to delimit character constants ('a'). 2. The syntax of the conditional pre-processing statements has changed. The old functional form ifdef(symbol,stuff to pre-process) has now been superceded by a more general form ifdef(symbol) * * * elsedef * * * enddef where the elsedef clause is optional. A similar form is provided for ifnotdef. `ratfix' will convert the functional form to the new form. There is an additional feature which may be enabled by defining the symbol INTELLIGENT_STRING_HANDLING. If this is defined when `ratfix' is built, then all quoted strings which end in a bare period "?*[!.]." will have that final period removed. The period was the canonical character to place at the end of a quoted string to permit `remark' to find the end of the hollerith string. Since `ratp1' & `ratp2' now do away with the hollerith type for all non-system-specific applications, the landmark period is no longer necessary. -1- Ratfix (1) 10-May-83 Ratfix (1) SEE ALSO ratfor, the ratfor preprocessor, for descriptions of the language. ratp2 - the second pass of the pre-processor AUTHORS Joe Sventek wrote ratfix. BUGS/DEFICIENCIES -2- #-t- ratfix local 11-may-83 14:38:39 #-t- docs ascii 01/09/84 15:54 #-h- ds.rat ascii 01/09/84 15:54 #-h- dsdef local 10-may-83 11:06:54 # Defines for support library routines # Defines for memory management routines: define(DS_MEMEND,1) # pointer to end of memory define(DS_AVAIL,2) # start of available space list define(DS_CLOSE,8) # threshhold for close-fitting blocks define(DS_LINK,1) # link field of storage block define(DS_SIZE,0) # size field of storage block define(DS_OHEAD,2) # total words of overhead per block # Defines for symbol table routines: define(ST_LINK,0) # offset of link field in symbol table node define(ST_DATA,1) # offset of data field in symbol table node define(ST_HTABSIZE,29) # should be a prime number define(ST_SCANPOSN,arith(ST_HTABSIZE,+,1)) # offset to two word block # for context of table scan #-t- dsdef local 10-may-83 11:06:54 #-h- dsinit local 10-may-83 11:06:55 ## 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 #-t- dsinit local 10-may-83 11:06:55 #-h- dsfree local 10-may-83 11:06:55 ## 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 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." ) 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 #-t- dsfree local 10-may-83 11:06:55 #-h- dsget local 10-may-83 11:06:56 ## 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 n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA ) return(p) 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 #-t- dsget local 10-may-83 11:06:56 #-h- dsdump local 10-may-83 11:06:56 ## 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( ' ', 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( ' ', 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 #-t- dsdump local 10-may-83 11:06:56 #-h- dsdbiu local 10-may-83 11:06:57 ## DSDBIU -- Dump contents of block-in-use. subroutine dsdbiu( b, form) pointer b character form DS_DECL( Mem, 1) integer l, s, lmax, t, j string blanks " " call putint( b, 5, ERROUT) call putch( ' ', 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) l = l + 1 } elif( form == LETTER ) { t = cvt_to_cptr(b) for( j = 1 ; j <= CHAR_PER_INT ; j = j + 1 ) { call putch( cMem(t), ERROUT) t = t + 1 } l = l + CHAR_PER_INT } if( l >= lmax ) { l = 0 call putch( '@n', ERROUT) } } if( l != 0 ) call putch( '@n', ERROUT) return end #-t- dsdbiu local 10-may-83 11:06:57 #-h- mktabl local 10-may-83 11:06:58 ## 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 + 3 ) # +3 for record of nodsiz # and 2-word block for scan context mktabl = st if( st != LAMBDA ) # allocation succeeded { Mem(st) = nodsiz for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { st = st + 1 Mem(st) = LAMBDA # null link } } return end #-t- mktabl local 10-may-83 11:06:58 #-h- rmtabl local 10-may-83 11:06:58 ## RmTabl -- Remove a symbol table, deleting all entries. subroutine rmtabl(st) pointer st DS_DECL( Mem, 1) integer i pointer bucket, node, walker bucket = st for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { bucket = bucket + 1 walker = Mem(bucket) while( walker != LAMBDA ) { node = walker walker = Mem( node + ST_LINK ) call dsfree(node) } } call dsfree(st) return end #-t- rmtabl local 10-may-83 11:06:58 #-h- sctabl local 10-may-83 11:06:59 ## ScTabl - Scan symbol table, returning next entry or EOF. integer function sctabl(table, sym, info, posn) pointer posn, table character sym(ARB) integer info(ARB) DS_DECL( Mem, 1) pointer bucket, walker integer nodsiz, i, j if( posn == 0 ) # just starting scan? { posn = table + ST_SCANPOSN # index to 2-word scan context block 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 i = cvt_to_cptr(i) j = 1 while( cMem(i) != EOS ) { sym(j) = cMem(i) i = i + 1 j = j + 1 } sym(j) = EOS j = walker + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(j) j = j + 1 } Mem(posn) = bucket # save position of next symbol Mem( posn + 1 ) = Mem( walker + ST_LINK ) return(1) # not EOF } else { bucket = bucket + 1 if( bucket > ST_HTABSIZE ) break j = table + bucket walker = Mem(j) } } posn = 0 return(EOF) end #-t- sctabl local 10-may-83 11:06:59 #-h- stlu local 10-may-83 11:06:59 ## 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 integer equal 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 j = cvt_to_cptr(j) while( symbol(i) == cMem(j) ) { if( symbol(i) == EOS ) return(YES) i = i + 1 j = j + 1 } pred = node node = Mem( pred + ST_LINK ) } return(NO) end #-t- stlu local 10-may-83 11:06:59 #-h- delete local 10-may-83 11:07:00 ## 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 #-t- delete local 10-may-83 11:07:00 #-h- lookup local 10-may-83 11:07:00 ## 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 ) return(NO) nodsiz = Mem(st) kluge = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(kluge) kluge = kluge + 1 } return(YES) end #-t- lookup local 10-may-83 11:07:00 #-h- enter local 10-may-83 11:07:01 ## Enter -- Place a symbol in the symbol table, updating if already present. integer function 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) + CHAR_PER_INT ) / CHAR_PER_INT ) if( node == LAMBDA ) return(ERR) Mem( node + ST_LINK ) = LAMBDA Mem( pred + ST_LINK ) = node i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) != EOS ) { cMem(j) = symbol(i) i = i + 1 j = j + 1 } cMem(j) = EOS } j = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { Mem(j) = info(i) j = j + 1 } return(OK) end #-t- enter local 10-may-83 11:07:01 #-h- sdupl local 10-may-83 11:07:01 ## SDupl -- Duplicate a string in dynamic storage space. pointer function sdupl(str) character str(ARB) DS_DECL( Mem, 1) integer i, k integer length pointer j pointer dsget j = dsget( ( length(str) + CHAR_PER_INT ) / CHAR_PER_INT ) sdupl = j if( j != LAMBDA ) { k = cvt_to_cptr(j) for( i = 1 ; str(i) != EOS ; i = i + 1 ) { cMem(k) = str(i) k = k + 1 } cMem(k) = EOS } return end #-t- sdupl local 10-may-83 11:07:01 #-h- entdef local 10-may-83 11:07:02 ## EntDef -- Enter a new symbol definition, discarding any old one. subroutine entdef( name, defn, table) character name(ARB), defn(ARB) pointer table integer lookup, enter pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "in entdef: no room for new definition." ) return end #-t- entdef local 10-may-83 11:07:02 #-h- ludef local 10-may-83 11:07:02 ## LuDef -- Look up a defined identifier, return its definition. integer function ludef( id, defn, table) character id(ARB), defn(ARB) pointer table DS_DECL( Mem, 1) integer i, j integer lookup pointer locn ludef = lookup( id, locn, table) if( ludef == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end #-t- ludef local 10-may-83 11:07:02 #-h- rmdef local 10-may-83 11:07:03 ## Rmdef -- remove symbol and definition from a symbol table subroutine rmdef(symbol, table) character symbol(ARB) pointer table integer lookup pointer text if (lookup(symbol, text, table) == YES) # remove (symbol,defn) pair { call dsfree(text) call delete(symbol, table) } return end #-t- rmdef local 10-may-83 11:07:03 #-t- ds.rat ascii 01/09/84 15:54 #-h- ds2ch.f ascii 01/09/84 15:54 SUBROUTINE DSINIT(W) INTEGER W INTEGER MEM( 1) BYTE C MEM(2) INTEGER T BYTE ST001Z(43) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST001Z(1)/105/,ST001Z(2)/110/,ST001Z(3)/32/,ST001Z(4)/100/, *ST001Z(5)/115/,ST001Z(6)/105/,ST001Z(7)/110/,ST001Z(8)/105/,ST001Z *(9)/116/,ST001Z(10)/58/,ST001Z(11)/32/,ST001Z(12)/117/,ST001Z(13)/ *110/,ST001Z(14)/114/,ST001Z(15)/101/,ST001Z(16)/97/,ST001Z(17)/115 */,ST001Z(18)/111/,ST001Z(19)/110/,ST001Z(20)/97/,ST001Z(21)/98/, *ST001Z(22)/108/,ST001Z(23)/121/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/109/,ST001Z(27)/97/,ST001Z(28)/108/,ST001Z(29)/108/, *ST001Z(30)/32/,ST001Z(31)/109/,ST001Z(32)/101/,ST001Z(33)/109/, *ST001Z(34)/111/,ST001Z(35)/114/,ST001Z(36)/121/,ST001Z(37)/32/, *ST001Z(38)/115/,ST001Z(39)/105/,ST001Z(40)/122/,ST001Z(41)/101/, *ST001Z(42)/46/,ST001Z(43)/0/ IF (.NOT.( W .LT. 2 * 2 + 2 ))GOTO 23000 CALL ERROR( ST001Z ) 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 SUBROUTINE DSFREE(BLOCK) INTEGER BLOCK INTEGER MEM( 1) BYTE C MEM(2) INTEGER P0, P, Q INTEGER N BYTE ST002Z(47) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST002Z(1)/105/,ST002Z(2)/110/,ST002Z(3)/32/,ST002Z(4)/100/, *ST002Z(5)/115/,ST002Z(6)/102/,ST002Z(7)/114/,ST002Z(8)/101/,ST002Z *(9)/101/,ST002Z(10)/58/,ST002Z(11)/32/,ST002Z(12)/32/,ST002Z(13)/9 *7/,ST002Z(14)/116/,ST002Z(15)/116/,ST002Z(16)/101/,ST002Z(17)/109/ *,ST002Z(18)/112/,ST002Z(19)/116/,ST002Z(20)/32/,ST002Z(21)/116/, *ST002Z(22)/111/,ST002Z(23)/32/,ST002Z(24)/102/,ST002Z(25)/114/, *ST002Z(26)/101/,ST002Z(27)/101/,ST002Z(28)/32/,ST002Z(29)/117/, *ST002Z(30)/110/,ST002Z(31)/97/,ST002Z(32)/108/,ST002Z(33)/108/, *ST002Z(34)/111/,ST002Z(35)/99/,ST002Z(36)/97/,ST002Z(37)/116/, *ST002Z(38)/101/,ST002Z(39)/100/,ST002Z(40)/32/,ST002Z(41)/98/, *ST002Z(42)/108/,ST002Z(43)/111/,ST002Z(44)/99/,ST002Z(45)/107/, *ST002Z(46)/46/,ST002Z(47)/0/ P0 = BLOCK - 2 N = MEM( P0 + 0 ) Q = 2 23002 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 .OR. P .GT. P0 ))GOTO 23005 GOTO 23004 23005 CONTINUE Q = P 23003 GOTO 23002 23004 CONTINUE IF (.NOT.( Q + MEM( Q + 0 ) .GT. P0 ))GOTO 23007 CALL REMARK( ST002Z ) RETURN 23007 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 INTEGER FUNCTION DSGET(W) INTEGER W INTEGER MEM( 1) BYTE C MEM(2) INTEGER P, Q, L INTEGER N, K COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) N = W + 2 Q = 2 23013 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 ))GOTO 23016 DSGET=(P) RETURN 23016 CONTINUE IF (.NOT.( MEM( P + 0 ) .GE. N ))GOTO 23018 GOTO 23015 23018 CONTINUE Q = P 23014 GOTO 23013 23015 CONTINUE K = MEM( P + 0 ) - N IF (.NOT.( K .GE. 8 ))GOTO 23020 MEM( P + 0 ) = K L = P + K MEM( L + 0 ) = N GOTO 23021 23020 CONTINUE MEM( Q + 1 ) = MEM( P + 1 ) L = P 23021 CONTINUE DSGET=( L + 2 ) RETURN END SUBROUTINE DSDUMP(FORM) BYTE FORM INTEGER MEM( 1) BYTE C MEM(2) INTEGER P, T, Q BYTE ST003Z(28) BYTE ST004Z(15) BYTE ST005Z(18) BYTE ST006Z(16) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST003Z(1)/42/,ST003Z(2)/42/,ST003Z(3)/32/,ST003Z(4)/68/, *ST003Z(5)/89/,ST003Z(6)/78/,ST003Z(7)/65/,ST003Z(8)/77/,ST003Z(9)/ *73/,ST003Z(10)/67/,ST003Z(11)/32/,ST003Z(12)/83/,ST003Z(13)/84/, *ST003Z(14)/79/,ST003Z(15)/82/,ST003Z(16)/65/,ST003Z(17)/71/,ST003Z *(18)/69/,ST003Z(19)/32/,ST003Z(20)/68/,ST003Z(21)/85/,ST003Z(22)/7 *7/,ST003Z(23)/80/,ST003Z(24)/32/,ST003Z(25)/42/,ST003Z(26)/42/, *ST003Z(27)/46/,ST003Z(28)/0/ DATA ST004Z(1)/32/,ST004Z(2)/119/,ST004Z(3)/111/,ST004Z(4)/114/, *ST004Z(5)/100/,ST004Z(6)/115/,ST004Z(7)/32/,ST004Z(8)/105/,ST004Z( *9)/110/,ST004Z(10)/32/,ST004Z(11)/117/,ST004Z(12)/115/,ST004Z(13)/ *101/,ST004Z(14)/46/,ST004Z(15)/0/ DATA ST005Z(1)/32/,ST005Z(2)/119/,ST005Z(3)/111/,ST005Z(4)/114/, *ST005Z(5)/100/,ST005Z(6)/115/,ST005Z(7)/32/,ST005Z(8)/97/,ST005Z(9 *)/118/,ST005Z(10)/97/,ST005Z(11)/105/,ST005Z(12)/108/,ST005Z(13)/9 *7/,ST005Z(14)/98/,ST005Z(15)/108/,ST005Z(16)/101/,ST005Z(17)/46/, *ST005Z(18)/0/ DATA ST006Z(1)/42/,ST006Z(2)/42/,ST006Z(3)/32/,ST006Z(4)/69/, *ST006Z(5)/78/,ST006Z(6)/68/,ST006Z(7)/32/,ST006Z(8)/68/,ST006Z(9)/ *85/,ST006Z(10)/77/,ST006Z(11)/80/,ST006Z(12)/32/,ST006Z(13)/42/, *ST006Z(14)/42/,ST006Z(15)/46/,ST006Z(16)/0/ T = 2 CALL REMARK( ST003Z ) CALL PUTINT( 1, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( 2 + 1, 0, 3) CALL REMARK( ST004Z ) P = MEM( T + 1 ) 23022 IF (.NOT.( P .NE. 0 ))GOTO 23023 CALL PUTINT( P, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( P + 0 ), 0, 3) CALL REMARK( ST005Z ) Q = P + MEM( P + 0 ) 23024 IF (.NOT.( Q .NE. MEM( P + 1 ) .AND. Q .LT. MEM( 1 ) ))GOTO 23025 CALL DSDBIU( Q, FORM) GOTO 23024 23025 CONTINUE P = MEM( P + 1 ) GOTO 23022 23023 CONTINUE CALL REMARK( ST006Z ) RETURN END SUBROUTINE DSDBIU( B, FORM) INTEGER B BYTE FORM INTEGER MEM( 1) BYTE C MEM(2) INTEGER L, S, LMAX, T, J BYTE BLANKS(11) BYTE ST007Z(15) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA BLANKS(1)/32/,BLANKS(2)/32/,BLANKS(3)/32/,BLANKS(4)/32/, *BLANKS(5)/32/,BLANKS(6)/32/,BLANKS(7)/32/,BLANKS(8)/32/,BLANKS(9)/ *32/,BLANKS(10)/32/,BLANKS(11)/0/ DATA ST007Z(1)/32/,ST007Z(2)/119/,ST007Z(3)/111/,ST007Z(4)/114/, *ST007Z(5)/100/,ST007Z(6)/115/,ST007Z(7)/32/,ST007Z(8)/105/,ST007Z( *9)/110/,ST007Z(10)/32/,ST007Z(11)/117/,ST007Z(12)/115/,ST007Z(13)/ *101/,ST007Z(14)/46/,ST007Z(15)/0/ CALL PUTINT( B, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( B + 0 ), 0, 3) CALL REMARK( ST007Z ) L = 0 S = B + MEM( B + 0 ) IF (.NOT.( FORM .EQ. 2 ))GOTO 23026 LMAX = 5 GOTO 23027 23026 CONTINUE LMAX = 50 23027 CONTINUE B = B + 2 23028 IF (.NOT.(B .LT. S ))GOTO 23030 IF (.NOT.( L .EQ. 0 ))GOTO 23031 CALL PUTLIN( BLANKS, 3) 23031 CONTINUE IF (.NOT.( FORM .EQ. 2 ))GOTO 23033 CALL PUTINT( MEM(B), 10, 3) L = L + 1 GOTO 23034 23033 CONTINUE IF (.NOT.( FORM .EQ. 1 ))GOTO 23035 T = (2*(B-1)+1) J = 1 23037 IF (.NOT.(J .LE. 2 ))GOTO 23039 CALL PUTCH( CMEM(T), 3) T = T + 1 23038 J = J + 1 GOTO 23037 23039 CONTINUE L = L + 2 23035 CONTINUE 23034 CONTINUE IF (.NOT.( L .GE. LMAX ))GOTO 23040 L = 0 CALL PUTCH( 10, 3) 23040 CONTINUE 23029 B = B + 1 GOTO 23028 23030 CONTINUE IF (.NOT.( L .NE. 0 ))GOTO 23042 CALL PUTCH( 10, 3) 23042 CONTINUE RETURN END INTEGER FUNCTION MKTABL(NODSIZ) INTEGER NODSIZ INTEGER MEM( 1) BYTE C MEM(2) INTEGER ST INTEGER DSGET INTEGER I COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) ST = DSGET( 29 + 3 ) MKTABL = ST IF (.NOT.( ST .NE. 0 ))GOTO 23044 MEM(ST) = NODSIZ I = 1 23046 IF (.NOT.(I .LE. 29 ))GOTO 23048 ST = ST + 1 MEM(ST) = 0 23047 I = I + 1 GOTO 23046 23048 CONTINUE 23044 CONTINUE RETURN END SUBROUTINE RMTABL(ST) INTEGER ST INTEGER MEM( 1) BYTE C MEM(2) INTEGER I INTEGER BUCKET, NODE, WALKER COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) BUCKET = ST I = 1 23049 IF (.NOT.(I .LE. 29 ))GOTO 23051 BUCKET = BUCKET + 1 WALKER = MEM(BUCKET) 23052 IF (.NOT.( WALKER .NE. 0 ))GOTO 23053 NODE = WALKER WALKER = MEM( NODE + 0 ) CALL DSFREE(NODE) GOTO 23052 23053 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE CALL DSFREE(ST) RETURN END INTEGER FUNCTION SCTABL(TABLE, SYM, INFO, POSN) INTEGER POSN, TABLE BYTE SYM(100) INTEGER INFO(100) INTEGER MEM( 1) BYTE C MEM(2) INTEGER BUCKET, WALKER INTEGER NODSIZ, I, J COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( POSN .EQ. 0 ))GOTO 23054 POSN = TABLE + 30 MEM(POSN) = 1 MEM( POSN + 1 ) = MEM( TABLE + 1 ) 23054 CONTINUE BUCKET = MEM(POSN) WALKER = MEM( POSN + 1 ) NODSIZ = MEM(TABLE) 23056 CONTINUE IF (.NOT.( WALKER .NE. 0 ))GOTO 23059 I = WALKER + 1 + NODSIZ I = (2*(I-1)+1) J = 1 23061 IF (.NOT.( CMEM(I) .NE. 0 ))GOTO 23062 SYM(J) = CMEM(I) I = I + 1 J = J + 1 GOTO 23061 23062 CONTINUE SYM(J) = 0 J = WALKER + 1 I = 1 23063 IF (.NOT.(I .LE. NODSIZ ))GOTO 23065 INFO(I) = MEM(J) J = J + 1 23064 I = I + 1 GOTO 23063 23065 CONTINUE MEM(POSN) = BUCKET MEM( POSN + 1 ) = MEM( WALKER + 0 ) SCTABL=(1) RETURN 23059 CONTINUE BUCKET = BUCKET + 1 IF (.NOT.( BUCKET .GT. 29 ))GOTO 23066 GOTO 23058 23066 CONTINUE J = TABLE + BUCKET WALKER = MEM(J) 23060 CONTINUE 23057 GOTO 23056 23058 CONTINUE POSN = 0 SCTABL=(-1) RETURN END INTEGER FUNCTION STLU( SYMBOL, NODE, PRED, ST) BYTE SYMBOL(100) INTEGER NODE, PRED, ST INTEGER MEM( 1) BYTE C MEM(2) INTEGER HASH, I, J, NODSIZ INTEGER EQUAL COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) HASH = 0 I = 1 23068 IF (.NOT.(SYMBOL(I) .NE. 0 ))GOTO 23070 HASH = HASH + SYMBOL(I) 23069 I = I + 1 GOTO 23068 23070 CONTINUE HASH = MOD( HASH, 29 ) + 1 PRED = ST + HASH NODE = MEM(PRED) 23071 IF (.NOT.( NODE .NE. 0 ))GOTO 23072 I = 1 J = NODE + 1 + NODSIZ J = (2*(J-1)+1) 23073 IF (.NOT.( SYMBOL(I) .EQ. CMEM(J) ))GOTO 23074 IF (.NOT.( SYMBOL(I) .EQ. 0 ))GOTO 23075 STLU=(1) RETURN 23075 CONTINUE I = I + 1 J = J + 1 GOTO 23073 23074 CONTINUE PRED = NODE NODE = MEM( PRED + 0 ) GOTO 23071 23072 CONTINUE STLU=(0) RETURN END SUBROUTINE DELETE( SYMBOL, ST) BYTE SYMBOL(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(2) INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 1 ))GOTO 23077 MEM( PRED + 0 ) = MEM( NODE + 0 ) CALL DSFREE(NODE) 23077 CONTINUE RETURN END INTEGER FUNCTION LOOKUP(SYMBOL, INFO, ST) BYTE SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(2) INTEGER I, NODSIZ, KLUGE INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23079 LOOKUP=(0) RETURN 23079 CONTINUE NODSIZ = MEM(ST) KLUGE = NODE + 1 I = 1 23081 IF (.NOT.(I .LE. NODSIZ ))GOTO 23083 INFO(I) = MEM(KLUGE) KLUGE = KLUGE + 1 23082 I = I + 1 GOTO 23081 23083 CONTINUE LOOKUP=(1) RETURN END INTEGER FUNCTION ENTER(SYMBOL, INFO, ST) BYTE SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(2) INTEGER I, NODSIZ, J INTEGER STLU, LENGTH INTEGER NODE, PRED INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23084 NODE = DSGET( 1 + NODSIZ + ( LENGTH(SYMBOL) + 2 ) / 2 ) IF (.NOT.( NODE .EQ. 0 ))GOTO 23086 ENTER=(-3) RETURN 23086 CONTINUE MEM( NODE + 0 ) = 0 MEM( PRED + 0 ) = NODE I = 1 J = NODE + 1 + NODSIZ J = (2*(J-1)+1) 23088 IF (.NOT.( SYMBOL(I) .NE. 0 ))GOTO 23089 CMEM(J) = SYMBOL(I) I = I + 1 J = J + 1 GOTO 23088 23089 CONTINUE CMEM(J) = 0 23084 CONTINUE J = NODE + 1 I = 1 23090 IF (.NOT.(I .LE. NODSIZ ))GOTO 23092 MEM(J) = INFO(I) J = J + 1 23091 I = I + 1 GOTO 23090 23092 CONTINUE ENTER=(0) RETURN END INTEGER FUNCTION SDUPL(STR) BYTE STR(100) INTEGER MEM( 1) BYTE C MEM(2) INTEGER I, K INTEGER LENGTH INTEGER J INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) J = DSGET( ( LENGTH(STR) + 2 ) / 2 ) SDUPL = J IF (.NOT.( J .NE. 0 ))GOTO 23093 K = (2*(J-1)+1) I = 1 23095 IF (.NOT.(STR(I) .NE. 0 ))GOTO 23097 CMEM(K) = STR(I) K = K + 1 23096 I = I + 1 GOTO 23095 23097 CONTINUE CMEM(K) = 0 23093 CONTINUE RETURN END SUBROUTINE ENTDEF( NAME, DEFN, TABLE) BYTE NAME(100), DEFN(100) INTEGER TABLE INTEGER LOOKUP, ENTER INTEGER TEXT INTEGER SDUPL BYTE ST008Z(39) DATA ST008Z(1)/105/,ST008Z(2)/110/,ST008Z(3)/32/,ST008Z(4)/101/, *ST008Z(5)/110/,ST008Z(6)/116/,ST008Z(7)/100/,ST008Z(8)/101/,ST008Z *(9)/102/,ST008Z(10)/58/,ST008Z(11)/32/,ST008Z(12)/110/,ST008Z(13)/ *111/,ST008Z(14)/32/,ST008Z(15)/114/,ST008Z(16)/111/,ST008Z(17)/111 */,ST008Z(18)/109/,ST008Z(19)/32/,ST008Z(20)/102/,ST008Z(21)/111/, *ST008Z(22)/114/,ST008Z(23)/32/,ST008Z(24)/110/,ST008Z(25)/101/, *ST008Z(26)/119/,ST008Z(27)/32/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/105/, *ST008Z(34)/116/,ST008Z(35)/105/,ST008Z(36)/111/,ST008Z(37)/110/, *ST008Z(38)/46/,ST008Z(39)/0/ IF (.NOT.( LOOKUP( NAME, TEXT, TABLE) .EQ. 1 ))GOTO 23098 CALL DSFREE(TEXT) 23098 CONTINUE TEXT = SDUPL(DEFN) IF (.NOT.( TEXT .NE. 0 ))GOTO 23100 IF (.NOT.( ENTER( NAME, TEXT, TABLE) .EQ. 0 ))GOTO 23102 RETURN 23102 CONTINUE CALL DSFREE(TEXT) 23103 CONTINUE 23100 CONTINUE CALL REMARK( ST008Z ) RETURN END INTEGER FUNCTION LUDEF( ID, DEFN, TABLE) BYTE ID(100), DEFN(100) INTEGER TABLE INTEGER MEM( 1) BYTE C MEM(2) INTEGER I, J INTEGER LOOKUP INTEGER LOCN COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) LUDEF = LOOKUP( ID, LOCN, TABLE) IF (.NOT.( LUDEF .EQ. 1 ))GOTO 23104 I = 1 J = (2*(LOCN-1)+1) 23106 IF (.NOT.(CMEM(J) .NE. 0 ))GOTO 23108 DEFN(I) = CMEM(J) I = I + 1 23107 J = J + 1 GOTO 23106 23108 CONTINUE DEFN(I) = 0 GOTO 23105 23104 CONTINUE DEFN(1) = 0 23105 CONTINUE RETURN END SUBROUTINE RMDEF(SYMBOL, TABLE) BYTE SYMBOL(100) INTEGER TABLE INTEGER LOOKUP INTEGER TEXT IF (.NOT.(LOOKUP(SYMBOL, TEXT, TABLE) .EQ. 1))GOTO 23109 CALL DSFREE(TEXT) CALL DELETE(SYMBOL, TABLE) 23109 CONTINUE RETURN END #-t- ds2ch.f ascii 01/09/84 15:54 #-h- ds4ch.f ascii 01/09/84 15:54 SUBROUTINE DSINIT(W) INTEGER W INTEGER MEM( 1) BYTE C MEM(4) INTEGER T BYTE ST001Z(43) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST001Z(1)/105/,ST001Z(2)/110/,ST001Z(3)/32/,ST001Z(4)/100/, *ST001Z(5)/115/,ST001Z(6)/105/,ST001Z(7)/110/,ST001Z(8)/105/,ST001Z *(9)/116/,ST001Z(10)/58/,ST001Z(11)/32/,ST001Z(12)/117/,ST001Z(13)/ *110/,ST001Z(14)/114/,ST001Z(15)/101/,ST001Z(16)/97/,ST001Z(17)/115 */,ST001Z(18)/111/,ST001Z(19)/110/,ST001Z(20)/97/,ST001Z(21)/98/, *ST001Z(22)/108/,ST001Z(23)/121/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/109/,ST001Z(27)/97/,ST001Z(28)/108/,ST001Z(29)/108/, *ST001Z(30)/32/,ST001Z(31)/109/,ST001Z(32)/101/,ST001Z(33)/109/, *ST001Z(34)/111/,ST001Z(35)/114/,ST001Z(36)/121/,ST001Z(37)/32/, *ST001Z(38)/115/,ST001Z(39)/105/,ST001Z(40)/122/,ST001Z(41)/101/, *ST001Z(42)/46/,ST001Z(43)/0/ IF (.NOT.( W .LT. 2 * 2 + 2 ))GOTO 23000 CALL ERROR( ST001Z ) 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 SUBROUTINE DSFREE(BLOCK) INTEGER BLOCK INTEGER MEM( 1) BYTE C MEM(4) INTEGER P0, P, Q INTEGER N BYTE ST002Z(47) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST002Z(1)/105/,ST002Z(2)/110/,ST002Z(3)/32/,ST002Z(4)/100/, *ST002Z(5)/115/,ST002Z(6)/102/,ST002Z(7)/114/,ST002Z(8)/101/,ST002Z *(9)/101/,ST002Z(10)/58/,ST002Z(11)/32/,ST002Z(12)/32/,ST002Z(13)/9 *7/,ST002Z(14)/116/,ST002Z(15)/116/,ST002Z(16)/101/,ST002Z(17)/109/ *,ST002Z(18)/112/,ST002Z(19)/116/,ST002Z(20)/32/,ST002Z(21)/116/, *ST002Z(22)/111/,ST002Z(23)/32/,ST002Z(24)/102/,ST002Z(25)/114/, *ST002Z(26)/101/,ST002Z(27)/101/,ST002Z(28)/32/,ST002Z(29)/117/, *ST002Z(30)/110/,ST002Z(31)/97/,ST002Z(32)/108/,ST002Z(33)/108/, *ST002Z(34)/111/,ST002Z(35)/99/,ST002Z(36)/97/,ST002Z(37)/116/, *ST002Z(38)/101/,ST002Z(39)/100/,ST002Z(40)/32/,ST002Z(41)/98/, *ST002Z(42)/108/,ST002Z(43)/111/,ST002Z(44)/99/,ST002Z(45)/107/, *ST002Z(46)/46/,ST002Z(47)/0/ P0 = BLOCK - 2 N = MEM( P0 + 0 ) Q = 2 23002 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 .OR. P .GT. P0 ))GOTO 23005 GOTO 23004 23005 CONTINUE Q = P 23003 GOTO 23002 23004 CONTINUE IF (.NOT.( Q + MEM( Q + 0 ) .GT. P0 ))GOTO 23007 CALL REMARK( ST002Z ) RETURN 23007 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 INTEGER FUNCTION DSGET(W) INTEGER W INTEGER MEM( 1) BYTE C MEM(4) INTEGER P, Q, L INTEGER N, K COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) N = W + 2 Q = 2 23013 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 ))GOTO 23016 DSGET=(P) RETURN 23016 CONTINUE IF (.NOT.( MEM( P + 0 ) .GE. N ))GOTO 23018 GOTO 23015 23018 CONTINUE Q = P 23014 GOTO 23013 23015 CONTINUE K = MEM( P + 0 ) - N IF (.NOT.( K .GE. 8 ))GOTO 23020 MEM( P + 0 ) = K L = P + K MEM( L + 0 ) = N GOTO 23021 23020 CONTINUE MEM( Q + 1 ) = MEM( P + 1 ) L = P 23021 CONTINUE DSGET=( L + 2 ) RETURN END SUBROUTINE DSDUMP(FORM) BYTE FORM INTEGER MEM( 1) BYTE C MEM(4) INTEGER P, T, Q BYTE ST003Z(28) BYTE ST004Z(15) BYTE ST005Z(18) BYTE ST006Z(16) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST003Z(1)/42/,ST003Z(2)/42/,ST003Z(3)/32/,ST003Z(4)/68/, *ST003Z(5)/89/,ST003Z(6)/78/,ST003Z(7)/65/,ST003Z(8)/77/,ST003Z(9)/ *73/,ST003Z(10)/67/,ST003Z(11)/32/,ST003Z(12)/83/,ST003Z(13)/84/, *ST003Z(14)/79/,ST003Z(15)/82/,ST003Z(16)/65/,ST003Z(17)/71/,ST003Z *(18)/69/,ST003Z(19)/32/,ST003Z(20)/68/,ST003Z(21)/85/,ST003Z(22)/7 *7/,ST003Z(23)/80/,ST003Z(24)/32/,ST003Z(25)/42/,ST003Z(26)/42/, *ST003Z(27)/46/,ST003Z(28)/0/ DATA ST004Z(1)/32/,ST004Z(2)/119/,ST004Z(3)/111/,ST004Z(4)/114/, *ST004Z(5)/100/,ST004Z(6)/115/,ST004Z(7)/32/,ST004Z(8)/105/,ST004Z( *9)/110/,ST004Z(10)/32/,ST004Z(11)/117/,ST004Z(12)/115/,ST004Z(13)/ *101/,ST004Z(14)/46/,ST004Z(15)/0/ DATA ST005Z(1)/32/,ST005Z(2)/119/,ST005Z(3)/111/,ST005Z(4)/114/, *ST005Z(5)/100/,ST005Z(6)/115/,ST005Z(7)/32/,ST005Z(8)/97/,ST005Z(9 *)/118/,ST005Z(10)/97/,ST005Z(11)/105/,ST005Z(12)/108/,ST005Z(13)/9 *7/,ST005Z(14)/98/,ST005Z(15)/108/,ST005Z(16)/101/,ST005Z(17)/46/, *ST005Z(18)/0/ DATA ST006Z(1)/42/,ST006Z(2)/42/,ST006Z(3)/32/,ST006Z(4)/69/, *ST006Z(5)/78/,ST006Z(6)/68/,ST006Z(7)/32/,ST006Z(8)/68/,ST006Z(9)/ *85/,ST006Z(10)/77/,ST006Z(11)/80/,ST006Z(12)/32/,ST006Z(13)/42/, *ST006Z(14)/42/,ST006Z(15)/46/,ST006Z(16)/0/ T = 2 CALL REMARK( ST003Z ) CALL PUTINT( 1, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( 2 + 1, 0, 3) CALL REMARK( ST004Z ) P = MEM( T + 1 ) 23022 IF (.NOT.( P .NE. 0 ))GOTO 23023 CALL PUTINT( P, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( P + 0 ), 0, 3) CALL REMARK( ST005Z ) Q = P + MEM( P + 0 ) 23024 IF (.NOT.( Q .NE. MEM( P + 1 ) .AND. Q .LT. MEM( 1 ) ))GOTO 23025 CALL DSDBIU( Q, FORM) GOTO 23024 23025 CONTINUE P = MEM( P + 1 ) GOTO 23022 23023 CONTINUE CALL REMARK( ST006Z ) RETURN END SUBROUTINE DSDBIU( B, FORM) INTEGER B BYTE FORM INTEGER MEM( 1) BYTE C MEM(4) INTEGER L, S, LMAX, T, J BYTE BLANKS(11) BYTE ST007Z(15) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA BLANKS(1)/32/,BLANKS(2)/32/,BLANKS(3)/32/,BLANKS(4)/32/, *BLANKS(5)/32/,BLANKS(6)/32/,BLANKS(7)/32/,BLANKS(8)/32/,BLANKS(9)/ *32/,BLANKS(10)/32/,BLANKS(11)/0/ DATA ST007Z(1)/32/,ST007Z(2)/119/,ST007Z(3)/111/,ST007Z(4)/114/, *ST007Z(5)/100/,ST007Z(6)/115/,ST007Z(7)/32/,ST007Z(8)/105/,ST007Z( *9)/110/,ST007Z(10)/32/,ST007Z(11)/117/,ST007Z(12)/115/,ST007Z(13)/ *101/,ST007Z(14)/46/,ST007Z(15)/0/ CALL PUTINT( B, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( B + 0 ), 0, 3) CALL REMARK( ST007Z ) L = 0 S = B + MEM( B + 0 ) IF (.NOT.( FORM .EQ. 2 ))GOTO 23026 LMAX = 5 GOTO 23027 23026 CONTINUE LMAX = 50 23027 CONTINUE B = B + 2 23028 IF (.NOT.(B .LT. S ))GOTO 23030 IF (.NOT.( L .EQ. 0 ))GOTO 23031 CALL PUTLIN( BLANKS, 3) 23031 CONTINUE IF (.NOT.( FORM .EQ. 2 ))GOTO 23033 CALL PUTINT( MEM(B), 10, 3) L = L + 1 GOTO 23034 23033 CONTINUE IF (.NOT.( FORM .EQ. 1 ))GOTO 23035 T = (4*(B-1)+1) J = 1 23037 IF (.NOT.(J .LE. 4 ))GOTO 23039 CALL PUTCH( CMEM(T), 3) T = T + 1 23038 J = J + 1 GOTO 23037 23039 CONTINUE L = L + 4 23035 CONTINUE 23034 CONTINUE IF (.NOT.( L .GE. LMAX ))GOTO 23040 L = 0 CALL PUTCH( 10, 3) 23040 CONTINUE 23029 B = B + 1 GOTO 23028 23030 CONTINUE IF (.NOT.( L .NE. 0 ))GOTO 23042 CALL PUTCH( 10, 3) 23042 CONTINUE RETURN END INTEGER FUNCTION MKTABL(NODSIZ) INTEGER NODSIZ INTEGER MEM( 1) BYTE C MEM(4) INTEGER ST INTEGER DSGET INTEGER I COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) ST = DSGET( 29 + 3 ) MKTABL = ST IF (.NOT.( ST .NE. 0 ))GOTO 23044 MEM(ST) = NODSIZ I = 1 23046 IF (.NOT.(I .LE. 29 ))GOTO 23048 ST = ST + 1 MEM(ST) = 0 23047 I = I + 1 GOTO 23046 23048 CONTINUE 23044 CONTINUE RETURN END SUBROUTINE RMTABL(ST) INTEGER ST INTEGER MEM( 1) BYTE C MEM(4) INTEGER I INTEGER BUCKET, NODE, WALKER COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) BUCKET = ST I = 1 23049 IF (.NOT.(I .LE. 29 ))GOTO 23051 BUCKET = BUCKET + 1 WALKER = MEM(BUCKET) 23052 IF (.NOT.( WALKER .NE. 0 ))GOTO 23053 NODE = WALKER WALKER = MEM( NODE + 0 ) CALL DSFREE(NODE) GOTO 23052 23053 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE CALL DSFREE(ST) RETURN END INTEGER FUNCTION SCTABL(TABLE, SYM, INFO, POSN) INTEGER POSN, TABLE BYTE SYM(100) INTEGER INFO(100) INTEGER MEM( 1) BYTE C MEM(4) INTEGER BUCKET, WALKER INTEGER NODSIZ, I, J COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( POSN .EQ. 0 ))GOTO 23054 POSN = TABLE + 30 MEM(POSN) = 1 MEM( POSN + 1 ) = MEM( TABLE + 1 ) 23054 CONTINUE BUCKET = MEM(POSN) WALKER = MEM( POSN + 1 ) NODSIZ = MEM(TABLE) 23056 CONTINUE IF (.NOT.( WALKER .NE. 0 ))GOTO 23059 I = WALKER + 1 + NODSIZ I = (4*(I-1)+1) J = 1 23061 IF (.NOT.( CMEM(I) .NE. 0 ))GOTO 23062 SYM(J) = CMEM(I) I = I + 1 J = J + 1 GOTO 23061 23062 CONTINUE SYM(J) = 0 J = WALKER + 1 I = 1 23063 IF (.NOT.(I .LE. NODSIZ ))GOTO 23065 INFO(I) = MEM(J) J = J + 1 23064 I = I + 1 GOTO 23063 23065 CONTINUE MEM(POSN) = BUCKET MEM( POSN + 1 ) = MEM( WALKER + 0 ) SCTABL=(1) RETURN 23059 CONTINUE BUCKET = BUCKET + 1 IF (.NOT.( BUCKET .GT. 29 ))GOTO 23066 GOTO 23058 23066 CONTINUE J = TABLE + BUCKET WALKER = MEM(J) 23060 CONTINUE 23057 GOTO 23056 23058 CONTINUE POSN = 0 SCTABL=(-1) RETURN END INTEGER FUNCTION STLU( SYMBOL, NODE, PRED, ST) BYTE SYMBOL(100) INTEGER NODE, PRED, ST INTEGER MEM( 1) BYTE C MEM(4) INTEGER HASH, I, J, NODSIZ INTEGER EQUAL COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) HASH = 0 I = 1 23068 IF (.NOT.(SYMBOL(I) .NE. 0 ))GOTO 23070 HASH = HASH + SYMBOL(I) 23069 I = I + 1 GOTO 23068 23070 CONTINUE HASH = MOD( HASH, 29 ) + 1 PRED = ST + HASH NODE = MEM(PRED) 23071 IF (.NOT.( NODE .NE. 0 ))GOTO 23072 I = 1 J = NODE + 1 + NODSIZ J = (4*(J-1)+1) 23073 IF (.NOT.( SYMBOL(I) .EQ. CMEM(J) ))GOTO 23074 IF (.NOT.( SYMBOL(I) .EQ. 0 ))GOTO 23075 STLU=(1) RETURN 23075 CONTINUE I = I + 1 J = J + 1 GOTO 23073 23074 CONTINUE PRED = NODE NODE = MEM( PRED + 0 ) GOTO 23071 23072 CONTINUE STLU=(0) RETURN END SUBROUTINE DELETE( SYMBOL, ST) BYTE SYMBOL(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(4) INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 1 ))GOTO 23077 MEM( PRED + 0 ) = MEM( NODE + 0 ) CALL DSFREE(NODE) 23077 CONTINUE RETURN END INTEGER FUNCTION LOOKUP(SYMBOL, INFO, ST) BYTE SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(4) INTEGER I, NODSIZ, KLUGE INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23079 LOOKUP=(0) RETURN 23079 CONTINUE NODSIZ = MEM(ST) KLUGE = NODE + 1 I = 1 23081 IF (.NOT.(I .LE. NODSIZ ))GOTO 23083 INFO(I) = MEM(KLUGE) KLUGE = KLUGE + 1 23082 I = I + 1 GOTO 23081 23083 CONTINUE LOOKUP=(1) RETURN END INTEGER FUNCTION ENTER(SYMBOL, INFO, ST) BYTE SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) BYTE C MEM(4) INTEGER I, NODSIZ, J INTEGER STLU, LENGTH INTEGER NODE, PRED INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23084 NODE = DSGET( 1 + NODSIZ + ( LENGTH(SYMBOL) + 4 ) / 4 ) IF (.NOT.( NODE .EQ. 0 ))GOTO 23086 ENTER=(-3) RETURN 23086 CONTINUE MEM( NODE + 0 ) = 0 MEM( PRED + 0 ) = NODE I = 1 J = NODE + 1 + NODSIZ J = (4*(J-1)+1) 23088 IF (.NOT.( SYMBOL(I) .NE. 0 ))GOTO 23089 CMEM(J) = SYMBOL(I) I = I + 1 J = J + 1 GOTO 23088 23089 CONTINUE CMEM(J) = 0 23084 CONTINUE J = NODE + 1 I = 1 23090 IF (.NOT.(I .LE. NODSIZ ))GOTO 23092 MEM(J) = INFO(I) J = J + 1 23091 I = I + 1 GOTO 23090 23092 CONTINUE ENTER=(0) RETURN END INTEGER FUNCTION SDUPL(STR) BYTE STR(100) INTEGER MEM( 1) BYTE C MEM(4) INTEGER I, K INTEGER LENGTH INTEGER J INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) J = DSGET( ( LENGTH(STR) + 4 ) / 4 ) SDUPL = J IF (.NOT.( J .NE. 0 ))GOTO 23093 K = (4*(J-1)+1) I = 1 23095 IF (.NOT.(STR(I) .NE. 0 ))GOTO 23097 CMEM(K) = STR(I) K = K + 1 23096 I = I + 1 GOTO 23095 23097 CONTINUE CMEM(K) = 0 23093 CONTINUE RETURN END SUBROUTINE ENTDEF( NAME, DEFN, TABLE) BYTE NAME(100), DEFN(100) INTEGER TABLE INTEGER LOOKUP, ENTER INTEGER TEXT INTEGER SDUPL BYTE ST008Z(39) DATA ST008Z(1)/105/,ST008Z(2)/110/,ST008Z(3)/32/,ST008Z(4)/101/, *ST008Z(5)/110/,ST008Z(6)/116/,ST008Z(7)/100/,ST008Z(8)/101/,ST008Z *(9)/102/,ST008Z(10)/58/,ST008Z(11)/32/,ST008Z(12)/110/,ST008Z(13)/ *111/,ST008Z(14)/32/,ST008Z(15)/114/,ST008Z(16)/111/,ST008Z(17)/111 */,ST008Z(18)/109/,ST008Z(19)/32/,ST008Z(20)/102/,ST008Z(21)/111/, *ST008Z(22)/114/,ST008Z(23)/32/,ST008Z(24)/110/,ST008Z(25)/101/, *ST008Z(26)/119/,ST008Z(27)/32/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/105/, *ST008Z(34)/116/,ST008Z(35)/105/,ST008Z(36)/111/,ST008Z(37)/110/, *ST008Z(38)/46/,ST008Z(39)/0/ IF (.NOT.( LOOKUP( NAME, TEXT, TABLE) .EQ. 1 ))GOTO 23098 CALL DSFREE(TEXT) 23098 CONTINUE TEXT = SDUPL(DEFN) IF (.NOT.( TEXT .NE. 0 ))GOTO 23100 IF (.NOT.( ENTER( NAME, TEXT, TABLE) .EQ. 0 ))GOTO 23102 RETURN 23102 CONTINUE CALL DSFREE(TEXT) 23103 CONTINUE 23100 CONTINUE CALL REMARK( ST008Z ) RETURN END INTEGER FUNCTION LUDEF( ID, DEFN, TABLE) BYTE ID(100), DEFN(100) INTEGER TABLE INTEGER MEM( 1) BYTE C MEM(4) INTEGER I, J INTEGER LOOKUP INTEGER LOCN COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) LUDEF = LOOKUP( ID, LOCN, TABLE) IF (.NOT.( LUDEF .EQ. 1 ))GOTO 23104 I = 1 J = (4*(LOCN-1)+1) 23106 IF (.NOT.(CMEM(J) .NE. 0 ))GOTO 23108 DEFN(I) = CMEM(J) I = I + 1 23107 J = J + 1 GOTO 23106 23108 CONTINUE DEFN(I) = 0 GOTO 23105 23104 CONTINUE DEFN(1) = 0 23105 CONTINUE RETURN END SUBROUTINE RMDEF(SYMBOL, TABLE) BYTE SYMBOL(100) INTEGER TABLE INTEGER LOOKUP INTEGER TEXT IF (.NOT.(LOOKUP(SYMBOL, TEXT, TABLE) .EQ. 1))GOTO 23109 CALL DSFREE(TEXT) CALL DELETE(SYMBOL, TABLE) 23109 CONTINUE RETURN END #-t- ds4ch.f ascii 01/09/84 15:54 #-h- dsint.f ascii 01/09/84 15:54 SUBROUTINE DSINIT(W) INTEGER W INTEGER MEM( 1) INTEGER C MEM(1) INTEGER T INTEGER ST001Z(43) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST001Z(1)/105/,ST001Z(2)/110/,ST001Z(3)/32/,ST001Z(4)/100/, *ST001Z(5)/115/,ST001Z(6)/105/,ST001Z(7)/110/,ST001Z(8)/105/,ST001Z *(9)/116/,ST001Z(10)/58/,ST001Z(11)/32/,ST001Z(12)/117/,ST001Z(13)/ *110/,ST001Z(14)/114/,ST001Z(15)/101/,ST001Z(16)/97/,ST001Z(17)/115 */,ST001Z(18)/111/,ST001Z(19)/110/,ST001Z(20)/97/,ST001Z(21)/98/, *ST001Z(22)/108/,ST001Z(23)/121/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/109/,ST001Z(27)/97/,ST001Z(28)/108/,ST001Z(29)/108/, *ST001Z(30)/32/,ST001Z(31)/109/,ST001Z(32)/101/,ST001Z(33)/109/, *ST001Z(34)/111/,ST001Z(35)/114/,ST001Z(36)/121/,ST001Z(37)/32/, *ST001Z(38)/115/,ST001Z(39)/105/,ST001Z(40)/122/,ST001Z(41)/101/, *ST001Z(42)/46/,ST001Z(43)/0/ IF (.NOT.( W .LT. 2 * 2 + 2 ))GOTO 23000 CALL ERROR( ST001Z ) 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 SUBROUTINE DSFREE(BLOCK) INTEGER BLOCK INTEGER MEM( 1) INTEGER C MEM(1) INTEGER P0, P, Q INTEGER N INTEGER ST002Z(47) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST002Z(1)/105/,ST002Z(2)/110/,ST002Z(3)/32/,ST002Z(4)/100/, *ST002Z(5)/115/,ST002Z(6)/102/,ST002Z(7)/114/,ST002Z(8)/101/,ST002Z *(9)/101/,ST002Z(10)/58/,ST002Z(11)/32/,ST002Z(12)/32/,ST002Z(13)/9 *7/,ST002Z(14)/116/,ST002Z(15)/116/,ST002Z(16)/101/,ST002Z(17)/109/ *,ST002Z(18)/112/,ST002Z(19)/116/,ST002Z(20)/32/,ST002Z(21)/116/, *ST002Z(22)/111/,ST002Z(23)/32/,ST002Z(24)/102/,ST002Z(25)/114/, *ST002Z(26)/101/,ST002Z(27)/101/,ST002Z(28)/32/,ST002Z(29)/117/, *ST002Z(30)/110/,ST002Z(31)/97/,ST002Z(32)/108/,ST002Z(33)/108/, *ST002Z(34)/111/,ST002Z(35)/99/,ST002Z(36)/97/,ST002Z(37)/116/, *ST002Z(38)/101/,ST002Z(39)/100/,ST002Z(40)/32/,ST002Z(41)/98/, *ST002Z(42)/108/,ST002Z(43)/111/,ST002Z(44)/99/,ST002Z(45)/107/, *ST002Z(46)/46/,ST002Z(47)/0/ P0 = BLOCK - 2 N = MEM( P0 + 0 ) Q = 2 23002 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 .OR. P .GT. P0 ))GOTO 23005 GOTO 23004 23005 CONTINUE Q = P 23003 GOTO 23002 23004 CONTINUE IF (.NOT.( Q + MEM( Q + 0 ) .GT. P0 ))GOTO 23007 CALL REMARK( ST002Z ) RETURN 23007 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 INTEGER FUNCTION DSGET(W) INTEGER W INTEGER MEM( 1) INTEGER C MEM(1) INTEGER P, Q, L INTEGER N, K COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) N = W + 2 Q = 2 23013 CONTINUE P = MEM( Q + 1 ) IF (.NOT.( P .EQ. 0 ))GOTO 23016 DSGET=(P) RETURN 23016 CONTINUE IF (.NOT.( MEM( P + 0 ) .GE. N ))GOTO 23018 GOTO 23015 23018 CONTINUE Q = P 23014 GOTO 23013 23015 CONTINUE K = MEM( P + 0 ) - N IF (.NOT.( K .GE. 8 ))GOTO 23020 MEM( P + 0 ) = K L = P + K MEM( L + 0 ) = N GOTO 23021 23020 CONTINUE MEM( Q + 1 ) = MEM( P + 1 ) L = P 23021 CONTINUE DSGET=( L + 2 ) RETURN END SUBROUTINE DSDUMP(FORM) INTEGER FORM INTEGER MEM( 1) INTEGER C MEM(1) INTEGER P, T, Q INTEGER ST003Z(28) INTEGER ST004Z(15) INTEGER ST005Z(18) INTEGER ST006Z(16) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA ST003Z(1)/42/,ST003Z(2)/42/,ST003Z(3)/32/,ST003Z(4)/68/, *ST003Z(5)/89/,ST003Z(6)/78/,ST003Z(7)/65/,ST003Z(8)/77/,ST003Z(9)/ *73/,ST003Z(10)/67/,ST003Z(11)/32/,ST003Z(12)/83/,ST003Z(13)/84/, *ST003Z(14)/79/,ST003Z(15)/82/,ST003Z(16)/65/,ST003Z(17)/71/,ST003Z *(18)/69/,ST003Z(19)/32/,ST003Z(20)/68/,ST003Z(21)/85/,ST003Z(22)/7 *7/,ST003Z(23)/80/,ST003Z(24)/32/,ST003Z(25)/42/,ST003Z(26)/42/, *ST003Z(27)/46/,ST003Z(28)/0/ DATA ST004Z(1)/32/,ST004Z(2)/119/,ST004Z(3)/111/,ST004Z(4)/114/, *ST004Z(5)/100/,ST004Z(6)/115/,ST004Z(7)/32/,ST004Z(8)/105/,ST004Z( *9)/110/,ST004Z(10)/32/,ST004Z(11)/117/,ST004Z(12)/115/,ST004Z(13)/ *101/,ST004Z(14)/46/,ST004Z(15)/0/ DATA ST005Z(1)/32/,ST005Z(2)/119/,ST005Z(3)/111/,ST005Z(4)/114/, *ST005Z(5)/100/,ST005Z(6)/115/,ST005Z(7)/32/,ST005Z(8)/97/,ST005Z(9 *)/118/,ST005Z(10)/97/,ST005Z(11)/105/,ST005Z(12)/108/,ST005Z(13)/9 *7/,ST005Z(14)/98/,ST005Z(15)/108/,ST005Z(16)/101/,ST005Z(17)/46/, *ST005Z(18)/0/ DATA ST006Z(1)/42/,ST006Z(2)/42/,ST006Z(3)/32/,ST006Z(4)/69/, *ST006Z(5)/78/,ST006Z(6)/68/,ST006Z(7)/32/,ST006Z(8)/68/,ST006Z(9)/ *85/,ST006Z(10)/77/,ST006Z(11)/80/,ST006Z(12)/32/,ST006Z(13)/42/, *ST006Z(14)/42/,ST006Z(15)/46/,ST006Z(16)/0/ T = 2 CALL REMARK( ST003Z ) CALL PUTINT( 1, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( 2 + 1, 0, 3) CALL REMARK( ST004Z ) P = MEM( T + 1 ) 23022 IF (.NOT.( P .NE. 0 ))GOTO 23023 CALL PUTINT( P, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( P + 0 ), 0, 3) CALL REMARK( ST005Z ) Q = P + MEM( P + 0 ) 23024 IF (.NOT.( Q .NE. MEM( P + 1 ) .AND. Q .LT. MEM( 1 ) ))GOTO 23025 CALL DSDBIU( Q, FORM) GOTO 23024 23025 CONTINUE P = MEM( P + 1 ) GOTO 23022 23023 CONTINUE CALL REMARK( ST006Z ) RETURN END SUBROUTINE DSDBIU( B, FORM) INTEGER B INTEGER FORM INTEGER MEM( 1) INTEGER C MEM(1) INTEGER L, S, LMAX, T, J INTEGER BLANKS(11) INTEGER ST007Z(15) COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) DATA BLANKS(1)/32/,BLANKS(2)/32/,BLANKS(3)/32/,BLANKS(4)/32/, *BLANKS(5)/32/,BLANKS(6)/32/,BLANKS(7)/32/,BLANKS(8)/32/,BLANKS(9)/ *32/,BLANKS(10)/32/,BLANKS(11)/0/ DATA ST007Z(1)/32/,ST007Z(2)/119/,ST007Z(3)/111/,ST007Z(4)/114/, *ST007Z(5)/100/,ST007Z(6)/115/,ST007Z(7)/32/,ST007Z(8)/105/,ST007Z( *9)/110/,ST007Z(10)/32/,ST007Z(11)/117/,ST007Z(12)/115/,ST007Z(13)/ *101/,ST007Z(14)/46/,ST007Z(15)/0/ CALL PUTINT( B, 5, 3) CALL PUTCH( 32, 3) CALL PUTINT( MEM( B + 0 ), 0, 3) CALL REMARK( ST007Z ) L = 0 S = B + MEM( B + 0 ) IF (.NOT.( FORM .EQ. 2 ))GOTO 23026 LMAX = 5 GOTO 23027 23026 CONTINUE LMAX = 50 23027 CONTINUE B = B + 2 23028 IF (.NOT.(B .LT. S ))GOTO 23030 IF (.NOT.( L .EQ. 0 ))GOTO 23031 CALL PUTLIN( BLANKS, 3) 23031 CONTINUE IF (.NOT.( FORM .EQ. 2 ))GOTO 23033 CALL PUTINT( MEM(B), 10, 3) L = L + 1 GOTO 23034 23033 CONTINUE IF (.NOT.( FORM .EQ. 1 ))GOTO 23035 T = (1*(B-1)+1) J = 1 23037 IF (.NOT.(J .LE. 1 ))GOTO 23039 CALL PUTCH( CMEM(T), 3) T = T + 1 23038 J = J + 1 GOTO 23037 23039 CONTINUE L = L + 1 23035 CONTINUE 23034 CONTINUE IF (.NOT.( L .GE. LMAX ))GOTO 23040 L = 0 CALL PUTCH( 10, 3) 23040 CONTINUE 23029 B = B + 1 GOTO 23028 23030 CONTINUE IF (.NOT.( L .NE. 0 ))GOTO 23042 CALL PUTCH( 10, 3) 23042 CONTINUE RETURN END INTEGER FUNCTION MKTABL(NODSIZ) INTEGER NODSIZ INTEGER MEM( 1) INTEGER C MEM(1) INTEGER ST INTEGER DSGET INTEGER I COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) ST = DSGET( 29 + 3 ) MKTABL = ST IF (.NOT.( ST .NE. 0 ))GOTO 23044 MEM(ST) = NODSIZ I = 1 23046 IF (.NOT.(I .LE. 29 ))GOTO 23048 ST = ST + 1 MEM(ST) = 0 23047 I = I + 1 GOTO 23046 23048 CONTINUE 23044 CONTINUE RETURN END SUBROUTINE RMTABL(ST) INTEGER ST INTEGER MEM( 1) INTEGER C MEM(1) INTEGER I INTEGER BUCKET, NODE, WALKER COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) BUCKET = ST I = 1 23049 IF (.NOT.(I .LE. 29 ))GOTO 23051 BUCKET = BUCKET + 1 WALKER = MEM(BUCKET) 23052 IF (.NOT.( WALKER .NE. 0 ))GOTO 23053 NODE = WALKER WALKER = MEM( NODE + 0 ) CALL DSFREE(NODE) GOTO 23052 23053 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE CALL DSFREE(ST) RETURN END INTEGER FUNCTION SCTABL(TABLE, SYM, INFO, POSN) INTEGER POSN, TABLE INTEGER SYM(100) INTEGER INFO(100) INTEGER MEM( 1) INTEGER C MEM(1) INTEGER BUCKET, WALKER INTEGER NODSIZ, I, J COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( POSN .EQ. 0 ))GOTO 23054 POSN = TABLE + 30 MEM(POSN) = 1 MEM( POSN + 1 ) = MEM( TABLE + 1 ) 23054 CONTINUE BUCKET = MEM(POSN) WALKER = MEM( POSN + 1 ) NODSIZ = MEM(TABLE) 23056 CONTINUE IF (.NOT.( WALKER .NE. 0 ))GOTO 23059 I = WALKER + 1 + NODSIZ I = (1*(I-1)+1) J = 1 23061 IF (.NOT.( CMEM(I) .NE. 0 ))GOTO 23062 SYM(J) = CMEM(I) I = I + 1 J = J + 1 GOTO 23061 23062 CONTINUE SYM(J) = 0 J = WALKER + 1 I = 1 23063 IF (.NOT.(I .LE. NODSIZ ))GOTO 23065 INFO(I) = MEM(J) J = J + 1 23064 I = I + 1 GOTO 23063 23065 CONTINUE MEM(POSN) = BUCKET MEM( POSN + 1 ) = MEM( WALKER + 0 ) SCTABL=(1) RETURN 23059 CONTINUE BUCKET = BUCKET + 1 IF (.NOT.( BUCKET .GT. 29 ))GOTO 23066 GOTO 23058 23066 CONTINUE J = TABLE + BUCKET WALKER = MEM(J) 23060 CONTINUE 23057 GOTO 23056 23058 CONTINUE POSN = 0 SCTABL=(-1) RETURN END INTEGER FUNCTION STLU( SYMBOL, NODE, PRED, ST) INTEGER SYMBOL(100) INTEGER NODE, PRED, ST INTEGER MEM( 1) INTEGER C MEM(1) INTEGER HASH, I, J, NODSIZ INTEGER EQUAL COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) HASH = 0 I = 1 23068 IF (.NOT.(SYMBOL(I) .NE. 0 ))GOTO 23070 HASH = HASH + SYMBOL(I) 23069 I = I + 1 GOTO 23068 23070 CONTINUE HASH = MOD( HASH, 29 ) + 1 PRED = ST + HASH NODE = MEM(PRED) 23071 IF (.NOT.( NODE .NE. 0 ))GOTO 23072 I = 1 J = NODE + 1 + NODSIZ J = (1*(J-1)+1) 23073 IF (.NOT.( SYMBOL(I) .EQ. CMEM(J) ))GOTO 23074 IF (.NOT.( SYMBOL(I) .EQ. 0 ))GOTO 23075 STLU=(1) RETURN 23075 CONTINUE I = I + 1 J = J + 1 GOTO 23073 23074 CONTINUE PRED = NODE NODE = MEM( PRED + 0 ) GOTO 23071 23072 CONTINUE STLU=(0) RETURN END SUBROUTINE DELETE( SYMBOL, ST) INTEGER SYMBOL(100) INTEGER ST INTEGER MEM( 1) INTEGER C MEM(1) INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 1 ))GOTO 23077 MEM( PRED + 0 ) = MEM( NODE + 0 ) CALL DSFREE(NODE) 23077 CONTINUE RETURN END INTEGER FUNCTION LOOKUP(SYMBOL, INFO, ST) INTEGER SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) INTEGER C MEM(1) INTEGER I, NODSIZ, KLUGE INTEGER STLU INTEGER NODE, PRED COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23079 LOOKUP=(0) RETURN 23079 CONTINUE NODSIZ = MEM(ST) KLUGE = NODE + 1 I = 1 23081 IF (.NOT.(I .LE. NODSIZ ))GOTO 23083 INFO(I) = MEM(KLUGE) KLUGE = KLUGE + 1 23082 I = I + 1 GOTO 23081 23083 CONTINUE LOOKUP=(1) RETURN END INTEGER FUNCTION ENTER(SYMBOL, INFO, ST) INTEGER SYMBOL(100) INTEGER INFO(100) INTEGER ST INTEGER MEM( 1) INTEGER C MEM(1) INTEGER I, NODSIZ, J INTEGER STLU, LENGTH INTEGER NODE, PRED INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) NODSIZ = MEM(ST) IF (.NOT.( STLU( SYMBOL, NODE, PRED, ST) .EQ. 0 ))GOTO 23084 NODE = DSGET( 1 + NODSIZ + ( LENGTH(SYMBOL) + 1 ) / 1 ) IF (.NOT.( NODE .EQ. 0 ))GOTO 23086 ENTER=(-3) RETURN 23086 CONTINUE MEM( NODE + 0 ) = 0 MEM( PRED + 0 ) = NODE I = 1 J = NODE + 1 + NODSIZ J = (1*(J-1)+1) 23088 IF (.NOT.( SYMBOL(I) .NE. 0 ))GOTO 23089 CMEM(J) = SYMBOL(I) I = I + 1 J = J + 1 GOTO 23088 23089 CONTINUE CMEM(J) = 0 23084 CONTINUE J = NODE + 1 I = 1 23090 IF (.NOT.(I .LE. NODSIZ ))GOTO 23092 MEM(J) = INFO(I) J = J + 1 23091 I = I + 1 GOTO 23090 23092 CONTINUE ENTER=(0) RETURN END INTEGER FUNCTION SDUPL(STR) INTEGER STR(100) INTEGER MEM( 1) INTEGER C MEM(1) INTEGER I, K INTEGER LENGTH INTEGER J INTEGER DSGET COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) J = DSGET( ( LENGTH(STR) + 1 ) / 1 ) SDUPL = J IF (.NOT.( J .NE. 0 ))GOTO 23093 K = (1*(J-1)+1) I = 1 23095 IF (.NOT.(STR(I) .NE. 0 ))GOTO 23097 CMEM(K) = STR(I) K = K + 1 23096 I = I + 1 GOTO 23095 23097 CONTINUE CMEM(K) = 0 23093 CONTINUE RETURN END SUBROUTINE ENTDEF( NAME, DEFN, TABLE) INTEGER NAME(100), DEFN(100) INTEGER TABLE INTEGER LOOKUP, ENTER INTEGER TEXT INTEGER SDUPL INTEGER ST008Z(39) DATA ST008Z(1)/105/,ST008Z(2)/110/,ST008Z(3)/32/,ST008Z(4)/101/, *ST008Z(5)/110/,ST008Z(6)/116/,ST008Z(7)/100/,ST008Z(8)/101/,ST008Z *(9)/102/,ST008Z(10)/58/,ST008Z(11)/32/,ST008Z(12)/110/,ST008Z(13)/ *111/,ST008Z(14)/32/,ST008Z(15)/114/,ST008Z(16)/111/,ST008Z(17)/111 */,ST008Z(18)/109/,ST008Z(19)/32/,ST008Z(20)/102/,ST008Z(21)/111/, *ST008Z(22)/114/,ST008Z(23)/32/,ST008Z(24)/110/,ST008Z(25)/101/, *ST008Z(26)/119/,ST008Z(27)/32/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/105/, *ST008Z(34)/116/,ST008Z(35)/105/,ST008Z(36)/111/,ST008Z(37)/110/, *ST008Z(38)/46/,ST008Z(39)/0/ IF (.NOT.( LOOKUP( NAME, TEXT, TABLE) .EQ. 1 ))GOTO 23098 CALL DSFREE(TEXT) 23098 CONTINUE TEXT = SDUPL(DEFN) IF (.NOT.( TEXT .NE. 0 ))GOTO 23100 IF (.NOT.( ENTER( NAME, TEXT, TABLE) .EQ. 0 ))GOTO 23102 RETURN 23102 CONTINUE CALL DSFREE(TEXT) 23103 CONTINUE 23100 CONTINUE CALL REMARK( ST008Z ) RETURN END INTEGER FUNCTION LUDEF( ID, DEFN, TABLE) INTEGER ID(100), DEFN(100) INTEGER TABLE INTEGER MEM( 1) INTEGER C MEM(1) INTEGER I, J INTEGER LOOKUP INTEGER LOCN COMMON /CDSMEM/ MEM EQUIVALENCE (C MEM(1), MEM(1)) LUDEF = LOOKUP( ID, LOCN, TABLE) IF (.NOT.( LUDEF .EQ. 1 ))GOTO 23104 I = 1 J = (1*(LOCN-1)+1) 23106 IF (.NOT.(CMEM(J) .NE. 0 ))GOTO 23108 DEFN(I) = CMEM(J) I = I + 1 23107 J = J + 1 GOTO 23106 23108 CONTINUE DEFN(I) = 0 GOTO 23105 23104 CONTINUE DEFN(1) = 0 23105 CONTINUE RETURN END SUBROUTINE RMDEF(SYMBOL, TABLE) INTEGER SYMBOL(100) INTEGER TABLE INTEGER LOOKUP INTEGER TEXT IF (.NOT.(LOOKUP(SYMBOL, TEXT, TABLE) .EQ. 1))GOTO 23109 CALL DSFREE(TEXT) CALL DELETE(SYMBOL, TABLE) 23109 CONTINUE RETURN END #-t- dsint.f ascii 01/09/84 15:54 #-h- dssym.rat ascii 01/09/84 15:54 #-h- dsdef local 10-may-83 11:06:54 # Defines for support library routines # Defines for memory management routines: define(DS_MEMEND,1) # pointer to end of memory define(DS_AVAIL,2) # start of available space list define(DS_CLOSE,8) # threshhold for close-fitting blocks define(DS_LINK,1) # link field of storage block define(DS_SIZE,0) # size field of storage block define(DS_OHEAD,2) # total words of overhead per block # Defines for symbol table routines: define(ST_LINK,0) # offset of link field in symbol table node define(ST_DATA,1) # offset of data field in symbol table node define(ST_HTABSIZE,29) # should be a prime number define(ST_SCANPOSN,arith(ST_HTABSIZE,+,1)) # offset to two word block # for context of table scan #-t- dsdef local 10-may-83 11:06:54 #-h- dsinit local 10-may-83 11:06:55 ## 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 #-t- dsinit local 10-may-83 11:06:55 #-h- dsfree local 10-may-83 11:06:55 ## 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 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." ) 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 #-t- dsfree local 10-may-83 11:06:55 #-h- dsget local 10-may-83 11:06:56 ## 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 n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA ) return(p) 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 #-t- dsget local 10-may-83 11:06:56 #-h- dsdump local 10-may-83 11:06:56 ## 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 #-t- dsdump local 10-may-83 11:06:56 #-h- dsdbiu local 10-may-83 11:06:57 ## DSDBIU -- Dump contents of block-in-use. subroutine dsdbiu( b, form) pointer b character form DS_DECL( Mem, 1) integer l, s, lmax, t, j 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) l = l + 1 } elif( form == LETTER ) { t = cvt_to_cptr(b) for( j = 1 ; j <= CHAR_PER_INT ; j = j + 1 ) { call putch( cMem(t), ERROUT) t = t + 1 } l = l + CHAR_PER_INT } if( l >= lmax ) { l = 0 call putch( NEWLINE, ERROUT) } } if( l != 0 ) call putch( NEWLINE, ERROUT) return end #-t- dsdbiu local 10-may-83 11:06:57 #-h- mktabl local 10-may-83 11:06:58 ## 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 + 3 ) # +3 for record of nodsiz # and 2-word block for scan context mktabl = st if( st != LAMBDA ) # allocation succeeded { Mem(st) = nodsiz for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { st = st + 1 Mem(st) = LAMBDA # null link } } return end #-t- mktabl local 10-may-83 11:06:58 #-h- rmtabl local 10-may-83 11:06:58 ## RmTabl -- Remove a symbol table, deleting all entries. subroutine rmtabl(st) pointer st DS_DECL( Mem, 1) integer i pointer bucket, node, walker bucket = st for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { bucket = bucket + 1 walker = Mem(bucket) while( walker != LAMBDA ) { node = walker walker = Mem( node + ST_LINK ) call dsfree(node) } } call dsfree(st) return end #-t- rmtabl local 10-may-83 11:06:58 #-h- sctabl local 10-may-83 11:06:59 ## ScTabl - Scan symbol table, returning next entry or EOF. integer function sctabl(table, sym, info, posn) pointer posn, table character sym(ARB) integer info(ARB) DS_DECL( Mem, 1) pointer bucket, walker integer nodsiz, i, j if( posn == 0 ) # just starting scan? { posn = table + ST_SCANPOSN # index to 2-word scan context block 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 i = cvt_to_cptr(i) j = 1 while( cMem(i) != EOS ) { sym(j) = cMem(i) i = i + 1 j = j + 1 } sym(j) = EOS j = walker + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(j) j = j + 1 } Mem(posn) = bucket # save position of next symbol Mem( posn + 1 ) = Mem( walker + ST_LINK ) return(1) # not EOF } else { bucket = bucket + 1 if( bucket > ST_HTABSIZE ) break j = table + bucket walker = Mem(j) } } posn = 0 return(EOF) end #-t- sctabl local 10-may-83 11:06:59 #-h- stlu local 10-may-83 11:06:59 ## 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 integer equal 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 j = cvt_to_cptr(j) while( symbol(i) == cMem(j) ) { if( symbol(i) == EOS ) return(YES) i = i + 1 j = j + 1 } pred = node node = Mem( pred + ST_LINK ) } return(NO) end #-t- stlu local 10-may-83 11:06:59 #-h- delete local 10-may-83 11:07:00 ## 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 #-t- delete local 10-may-83 11:07:00 #-h- lookup local 10-may-83 11:07:00 ## 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 ) return(NO) nodsiz = Mem(st) kluge = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(kluge) kluge = kluge + 1 } return(YES) end #-t- lookup local 10-may-83 11:07:00 #-h- enter local 10-may-83 11:07:01 ## Enter -- Place a symbol in the symbol table, updating if already present. integer function 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) + CHAR_PER_INT ) / CHAR_PER_INT ) if( node == LAMBDA ) return(ERR) Mem( node + ST_LINK ) = LAMBDA Mem( pred + ST_LINK ) = node i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) != EOS ) { cMem(j) = symbol(i) i = i + 1 j = j + 1 } cMem(j) = EOS } j = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { Mem(j) = info(i) j = j + 1 } return(OK) end #-t- enter local 10-may-83 11:07:01 #-h- sdupl local 10-may-83 11:07:01 ## SDupl -- Duplicate a string in dynamic storage space. pointer function sdupl(str) character str(ARB) DS_DECL( Mem, 1) integer i, k integer length pointer j pointer dsget j = dsget( ( length(str) + CHAR_PER_INT ) / CHAR_PER_INT ) sdupl = j if( j != LAMBDA ) { k = cvt_to_cptr(j) for( i = 1 ; str(i) != EOS ; i = i + 1 ) { cMem(k) = str(i) k = k + 1 } cMem(k) = EOS } return end #-t- sdupl local 10-may-83 11:07:01 #-h- entdef local 10-may-83 11:07:02 ## EntDef -- Enter a new symbol definition, discarding any old one. subroutine entdef( name, defn, table) character name(ARB), defn(ARB) pointer table integer lookup, enter pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "in entdef: no room for new definition." ) return end #-t- entdef local 10-may-83 11:07:02 #-h- ludef local 10-may-83 11:07:02 ## LuDef -- Look up a defined identifier, return its definition. integer function ludef( id, defn, table) character id(ARB), defn(ARB) pointer table DS_DECL( Mem, 1) integer i, j integer lookup pointer locn ludef = lookup( id, locn, table) if( ludef == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end #-t- ludef local 10-may-83 11:07:02 #-h- rmdef local 10-may-83 11:07:03 ## Rmdef -- remove symbol and definition from a symbol table subroutine rmdef(symbol, table) character symbol(ARB) pointer table integer lookup pointer text if (lookup(symbol, text, table) == YES) # remove (symbol,defn) pair { call dsfree(text) call delete(symbol, table) } return end #-t- rmdef local 10-may-83 11:07:03 #-t- dssym.rat ascii 01/09/84 15:54 #-h- lib.rat ascii 01/09/84 15:54 #-h- error local 10-may-83 12:17:41 subroutine error(buf) character buf(ARB) call remark(buf) call endst(ERR) end #-t- error local 10-may-83 12:17:41 #-h- remark local 10-may-83 12:17:41 subroutine remark(buf) character buf(ARB) integer i for (i = 1; buf(i) != EOS; i = i + 1) ; i = i - 1 call putlin(buf, ERROUT) if (i > 0) if (buf(i) == '@n') return call putch('@n', ERROUT) return end #-t- remark local 10-may-83 12:17:41 #-h- fold local 10-may-83 12:17:41 ## fold - fold all letters to lower case subroutine fold (token) character token(ARB), clower integer i for (i=1; token(i) != EOS; i=i+1) token(i) = clower(token(i)) return end #-t- fold local 10-may-83 12:17:41 #-h- length local 10-may-83 12:17:41 integer function length(buf) character buf(ARB) integer n for (n = 1; buf(n) != EOS; n = n + 1) ; return (n - 1) end #-t- length local 10-may-83 12:17:41 #-h- scopy local 10-may-83 12:17:42 subroutine scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j integer k, l l = j for (k = i; from(k) != EOS; k = k + 1) { to(l) = from(k) l = l + 1 } to(l) = EOS return end #-t- scopy local 10-may-83 12:17:42 #-h- skipbl local 10-may-83 12:17:42 subroutine skipbl(buf, i) character buf(ARB) integer i while (buf(i) == ' ' | buf(i) == '@t') i = i + 1 return end #-t- skipbl local 10-may-83 12:17:42 #-h- type local 10-may-83 12:17:42 ## type - determine type of character integer function type (c) character c integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" string digits "0123456789" # for (i = 1; digits(i) != EOS; i = i + 1) if (digits(i) == c) return(DIGIT) for (i = 1; locase(i) != EOS; i = i + 1) if (locase(i) == c) return(LETTER) for (i = 1; upcase(i) != EOS; i = i + 1) if (upcase(i) == c) return(LETTER) return(c) end #-t- type local 10-may-83 12:17:42 #-h- clower local 10-may-83 12:17:42 ## clower - change letter to lower case character function clower(c) character c, retch integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" retch = c # assume not upper case for (i = 1; upcase(i) != EOS; i = i + 1) if (upcase(i) == c) { retch = locase(i) break } return (retch) end #-t- clower local 10-may-83 12:17:42 #-h- cupper local 10-may-83 12:17:43 ## cupper - change letter to upper case character function cupper(c) character c, retch integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" retch = c # assume not lower case for (i = 1; locase(i) != EOS; i = i + 1) if (locase(i) == c) { retch = upcase(i) break } return (retch) end #-t- cupper local 10-may-83 12:17:43 #-h- upper local 10-may-83 12:17:43 ## upper - force all letters to upper case subroutine upper (token) character token(ARB), cupper integer i for (i=1; token(i) != EOS; i=i+1) token(i) = cupper(token(i)) return end #-t- upper local 10-may-83 12:17:43 #-h- concat local 10-may-83 12:17:43 subroutine concat(first, second, out) character first(ARB), second(ARB), out(ARB) integer i, j j = 1 for (i = 1; first(i) != EOS; i = i + 1) { out(j) = first(i) j = j + 1 } for (i = 1; second(i) != EOS; i = i + 1) { out(j) = second(i) j = j + 1 } out(j) = EOS return end #-t- concat local 10-may-83 12:17:43 #-h- ctoi local 10-may-83 12:17:44 ## CToI -- Convert string at `in(i)' to integer; increment `i'. integer function ctoi( in, i) character in(ARB) integer index # function(s) integer d, i, sign string digits "0123456789" while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 sign = 1 if( in(i) == '-' ) { sign = -1 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( sign * ctoi ) end #-t- ctoi local 10-may-83 12:17:44 #-h- equal local 10-may-83 12:17:44 ## 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) { equal = YES return } equal = NO return end #-t- equal local 10-may-83 12:17:44 #-h- index local 10-may-83 12:17:44 ## index - find character c in string str integer function index(str, c) character c, str(ARB) for (index = 1; str(index) != EOS; index = index + 1) if (str(index) == c) return index = 0 return end #-t- index local 10-may-83 12:17:44 #-h- itoc local 10-may-83 12:17:44 ## IToC -- Convert integer `int' to character string in `str'. integer function itoc( int, str, size) integer mod # function(s) integer d, i, int, intval, j, k, size character str(size) string digits "0123456789" intval = abs(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) = '-' } 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 #-t- itoc local 10-may-83 12:17:44 #-h- esc local 10-may-83 12:17:45 ## Esc -- Map `array(i)' into escaped character, if appropriate. character function esc( array, i) character array(ARB), c character clower # function(s) integer i, j if( array(i) != ESCAPE ) esc = array(i) else if( array( i + 1 ) == EOS ) # ESCAPE not special at end esc = ESCAPE else { i = i + 1 c = clower( array(i) ) if( c == 'n' ) esc = '@n' else if( c == 't' ) esc = '@t' else if( c == 'r' ) esc = '@r' else if( c == 'b' ) esc = '@b' else if( c == 'e' ) esc = EOS else if( c == 'f' ) esc = '@f' else if( c == 'l' ) esc = '@l' else if( c >= '0' & c <= '7' ) { esc = 0 for( j=i ; j < i+3 & ( array(j) >= '0' & array(j) <= '7' ) ; j=j+1 ) esc = 8 * esc + ( array(j) - '0' ) i = j - 1 } else esc = c } return end #-t- esc local 10-may-83 12:17:45 #-t- lib.rat ascii 01/09/84 15:54 #-h- lib2ch.f ascii 01/09/84 15:54 SUBROUTINE ERROR(BUF) BYTE BUF(100) CALL REMARK(BUF) CALL ENDST(-3) END SUBROUTINE REMARK(BUF) BYTE BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END SUBROUTINE FOLD (TOKEN) BYTE TOKEN(100), CLOWER INTEGER I I=1 23007 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23009 TOKEN(I) = CLOWER(TOKEN(I)) 23008 I=I+1 GOTO 23007 23009 CONTINUE RETURN END INTEGER FUNCTION LENGTH(BUF) BYTE BUF(100) INTEGER N N = 1 23010 IF (.NOT.(BUF(N) .NE. 0))GOTO 23012 23011 N = N + 1 GOTO 23010 23012 CONTINUE LENGTH=(N - 1) RETURN END SUBROUTINE SCOPY(FROM, I, TO, J) BYTE FROM(100), TO(100) INTEGER I, J INTEGER K, L L = J K = I 23013 IF (.NOT.(FROM(K) .NE. 0))GOTO 23015 TO(L) = FROM(K) L = L + 1 23014 K = K + 1 GOTO 23013 23015 CONTINUE TO(L) = 0 RETURN END SUBROUTINE SKIPBL(BUF, I) BYTE BUF(100) INTEGER I 23016 IF (.NOT.(BUF(I) .EQ. 32 .OR. BUF(I) .EQ. 9))GOTO 23017 I = I + 1 GOTO 23016 23017 CONTINUE RETURN END INTEGER FUNCTION TYPE (C) BYTE C INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) BYTE DIGITS(11) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ 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)/0/ I = 1 23018 IF (.NOT.(DIGITS(I) .NE. 0))GOTO 23020 IF (.NOT.(DIGITS(I) .EQ. C))GOTO 23021 TYPE=(2) RETURN 23021 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE I = 1 23023 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23025 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23026 TYPE=(1) RETURN 23026 CONTINUE 23024 I = I + 1 GOTO 23023 23025 CONTINUE I = 1 23028 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23030 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23031 TYPE=(1) RETURN 23031 CONTINUE 23029 I = I + 1 GOTO 23028 23030 CONTINUE TYPE=(C) RETURN END BYTE FUNCTION CLOWER(C) BYTE C, RETCH INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23033 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23035 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23036 RETCH = LOCASE(I) GOTO 23035 23036 CONTINUE 23034 I = I + 1 GOTO 23033 23035 CONTINUE CLOWER=(RETCH) RETURN END BYTE FUNCTION CUPPER(C) BYTE C, RETCH INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23038 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23040 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23041 RETCH = UPCASE(I) GOTO 23040 23041 CONTINUE 23039 I = I + 1 GOTO 23038 23040 CONTINUE CUPPER=(RETCH) RETURN END SUBROUTINE UPPER (TOKEN) BYTE TOKEN(100), CUPPER INTEGER I I=1 23043 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23045 TOKEN(I) = CUPPER(TOKEN(I)) 23044 I=I+1 GOTO 23043 23045 CONTINUE RETURN END SUBROUTINE CONCAT(FIRST, SECOND, OUT) BYTE FIRST(100), SECOND(100), OUT(100) INTEGER I, J J = 1 I = 1 23046 IF (.NOT.(FIRST(I) .NE. 0))GOTO 23048 OUT(J) = FIRST(I) J = J + 1 23047 I = I + 1 GOTO 23046 23048 CONTINUE I = 1 23049 IF (.NOT.(SECOND(I) .NE. 0))GOTO 23051 OUT(J) = SECOND(I) J = J + 1 23050 I = I + 1 GOTO 23049 23051 CONTINUE OUT(J) = 0 RETURN END INTEGER FUNCTION CTOI( IN, I) BYTE IN(100) INTEGER INDEX INTEGER D, I, SIGN BYTE 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)/0/ 23052 IF (.NOT.( IN(I) .EQ. 32 .OR. IN(I) .EQ. 9 ))GOTO 23053 I = I + 1 GOTO 23052 23053 CONTINUE SIGN = 1 IF (.NOT.( IN(I) .EQ. 45 ))GOTO 23054 SIGN = -1 I = I + 1 23054 CONTINUE CTOI = 0 23056 IF (.NOT.(IN(I) .NE. 0 ))GOTO 23058 D = INDEX( DIGITS, IN(I) ) IF (.NOT.( D .EQ. 0 ))GOTO 23059 GOTO 23058 23059 CONTINUE CTOI = 10 * CTOI + D - 1 23057 I = I + 1 GOTO 23056 23058 CONTINUE CTOI=( SIGN * CTOI ) RETURN END INTEGER FUNCTION EQUAL (STR1, STR2) BYTE STR1(100), STR2(100) INTEGER I I=1 23061 IF (.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23063 IF (.NOT.(STR1(I) .EQ. 0))GOTO 23064 EQUAL = 1 RETURN 23064 CONTINUE 23062 I=I+1 GOTO 23061 23063 CONTINUE EQUAL = 0 RETURN END INTEGER FUNCTION INDEX(STR, C) BYTE C, STR(100) INDEX = 1 23066 IF (.NOT.(STR(INDEX) .NE. 0))GOTO 23068 IF (.NOT.(STR(INDEX) .EQ. C))GOTO 23069 RETURN 23069 CONTINUE 23067 INDEX = INDEX + 1 GOTO 23066 23068 CONTINUE INDEX = 0 RETURN END INTEGER FUNCTION ITOC( INT, STR, SIZE) INTEGER MOD INTEGER D, I, INT, INTVAL, J, K, SIZE BYTE STR(SIZE) BYTE 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)/0/ INTVAL = IABS(INT) STR(1) = 0 I = 1 23071 CONTINUE I = I + 1 D = MOD( INTVAL, 10) STR(I) = DIGITS( D + 1 ) INTVAL = INTVAL / 10 23072 IF (.NOT.( INTVAL .EQ. 0 .OR. I .GE. SIZE ))GOTO 23071 23073 CONTINUE IF (.NOT.( INT .LT. 0 .AND. I .LT. SIZE ))GOTO 23074 I = I + 1 STR(I) = 45 23074 CONTINUE ITOC = I - 1 J = 1 23076 IF (.NOT.(J .LT. I ))GOTO 23078 K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 23077 J = J + 1 GOTO 23076 23078 CONTINUE RETURN END BYTE FUNCTION ESC( ARRAY, I) BYTE ARRAY(100), C BYTE CLOWER INTEGER I, J IF (.NOT.( ARRAY(I) .NE. 64 ))GOTO 23079 ESC = ARRAY(I) GOTO 23080 23079 CONTINUE IF (.NOT.( ARRAY( I + 1 ) .EQ. 0 ))GOTO 23081 ESC = 64 GOTO 23082 23081 CONTINUE I = I + 1 C = CLOWER( ARRAY(I) ) IF (.NOT.( C .EQ. 110 ))GOTO 23083 ESC = 10 GOTO 23084 23083 CONTINUE IF (.NOT.( C .EQ. 116 ))GOTO 23085 ESC = 9 GOTO 23086 23085 CONTINUE IF (.NOT.( C .EQ. 114 ))GOTO 23087 ESC = 13 GOTO 23088 23087 CONTINUE IF (.NOT.( C .EQ. 98 ))GOTO 23089 ESC = 8 GOTO 23090 23089 CONTINUE IF (.NOT.( C .EQ. 101 ))GOTO 23091 ESC = 0 GOTO 23092 23091 CONTINUE IF (.NOT.( C .EQ. 102 ))GOTO 23093 ESC = 12 GOTO 23094 23093 CONTINUE IF (.NOT.( C .EQ. 108 ))GOTO 23095 ESC = 10 GOTO 23096 23095 CONTINUE IF (.NOT.( C .GE. 48 .AND. C .LE. 55 ))GOTO 23097 ESC = 0 J=I 23099 IF (.NOT.(J .LT. I+3 .AND. ( ARRAY(J) .GE. 48 .AND. ARRAY(J) .LE. *55 ) ))GOTO 23101 ESC = 8 * ESC + ( ARRAY(J) - 48 ) 23100 J=J+1 GOTO 23099 23101 CONTINUE I = J - 1 GOTO 23098 23097 CONTINUE ESC = C 23098 CONTINUE 23096 CONTINUE 23094 CONTINUE 23092 CONTINUE 23090 CONTINUE 23088 CONTINUE 23086 CONTINUE 23084 CONTINUE 23082 CONTINUE 23080 CONTINUE RETURN END #-t- lib2ch.f ascii 01/09/84 15:54 #-h- lib4ch.f ascii 01/09/84 15:54 SUBROUTINE ERROR(BUF) BYTE BUF(100) CALL REMARK(BUF) CALL ENDST(-3) END SUBROUTINE REMARK(BUF) BYTE BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END SUBROUTINE FOLD (TOKEN) BYTE TOKEN(100), CLOWER INTEGER I I=1 23007 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23009 TOKEN(I) = CLOWER(TOKEN(I)) 23008 I=I+1 GOTO 23007 23009 CONTINUE RETURN END INTEGER FUNCTION LENGTH(BUF) BYTE BUF(100) INTEGER N N = 1 23010 IF (.NOT.(BUF(N) .NE. 0))GOTO 23012 23011 N = N + 1 GOTO 23010 23012 CONTINUE LENGTH=(N - 1) RETURN END SUBROUTINE SCOPY(FROM, I, TO, J) BYTE FROM(100), TO(100) INTEGER I, J INTEGER K, L L = J K = I 23013 IF (.NOT.(FROM(K) .NE. 0))GOTO 23015 TO(L) = FROM(K) L = L + 1 23014 K = K + 1 GOTO 23013 23015 CONTINUE TO(L) = 0 RETURN END SUBROUTINE SKIPBL(BUF, I) BYTE BUF(100) INTEGER I 23016 IF (.NOT.(BUF(I) .EQ. 32 .OR. BUF(I) .EQ. 9))GOTO 23017 I = I + 1 GOTO 23016 23017 CONTINUE RETURN END INTEGER FUNCTION TYPE (C) BYTE C INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) BYTE DIGITS(11) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ 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)/0/ I = 1 23018 IF (.NOT.(DIGITS(I) .NE. 0))GOTO 23020 IF (.NOT.(DIGITS(I) .EQ. C))GOTO 23021 TYPE=(2) RETURN 23021 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE I = 1 23023 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23025 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23026 TYPE=(1) RETURN 23026 CONTINUE 23024 I = I + 1 GOTO 23023 23025 CONTINUE I = 1 23028 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23030 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23031 TYPE=(1) RETURN 23031 CONTINUE 23029 I = I + 1 GOTO 23028 23030 CONTINUE TYPE=(C) RETURN END BYTE FUNCTION CLOWER(C) BYTE C, RETCH INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23033 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23035 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23036 RETCH = LOCASE(I) GOTO 23035 23036 CONTINUE 23034 I = I + 1 GOTO 23033 23035 CONTINUE CLOWER=(RETCH) RETURN END BYTE FUNCTION CUPPER(C) BYTE C, RETCH INTEGER I BYTE UPCASE(27) BYTE LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23038 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23040 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23041 RETCH = UPCASE(I) GOTO 23040 23041 CONTINUE 23039 I = I + 1 GOTO 23038 23040 CONTINUE CUPPER=(RETCH) RETURN END SUBROUTINE UPPER (TOKEN) BYTE TOKEN(100), CUPPER INTEGER I I=1 23043 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23045 TOKEN(I) = CUPPER(TOKEN(I)) 23044 I=I+1 GOTO 23043 23045 CONTINUE RETURN END SUBROUTINE CONCAT(FIRST, SECOND, OUT) BYTE FIRST(100), SECOND(100), OUT(100) INTEGER I, J J = 1 I = 1 23046 IF (.NOT.(FIRST(I) .NE. 0))GOTO 23048 OUT(J) = FIRST(I) J = J + 1 23047 I = I + 1 GOTO 23046 23048 CONTINUE I = 1 23049 IF (.NOT.(SECOND(I) .NE. 0))GOTO 23051 OUT(J) = SECOND(I) J = J + 1 23050 I = I + 1 GOTO 23049 23051 CONTINUE OUT(J) = 0 RETURN END INTEGER FUNCTION CTOI( IN, I) BYTE IN(100) INTEGER INDEX INTEGER D, I, SIGN BYTE 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)/0/ 23052 IF (.NOT.( IN(I) .EQ. 32 .OR. IN(I) .EQ. 9 ))GOTO 23053 I = I + 1 GOTO 23052 23053 CONTINUE SIGN = 1 IF (.NOT.( IN(I) .EQ. 45 ))GOTO 23054 SIGN = -1 I = I + 1 23054 CONTINUE CTOI = 0 23056 IF (.NOT.(IN(I) .NE. 0 ))GOTO 23058 D = INDEX( DIGITS, IN(I) ) IF (.NOT.( D .EQ. 0 ))GOTO 23059 GOTO 23058 23059 CONTINUE CTOI = 10 * CTOI + D - 1 23057 I = I + 1 GOTO 23056 23058 CONTINUE CTOI=( SIGN * CTOI ) RETURN END INTEGER FUNCTION EQUAL (STR1, STR2) BYTE STR1(100), STR2(100) INTEGER I I=1 23061 IF (.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23063 IF (.NOT.(STR1(I) .EQ. 0))GOTO 23064 EQUAL = 1 RETURN 23064 CONTINUE 23062 I=I+1 GOTO 23061 23063 CONTINUE EQUAL = 0 RETURN END INTEGER FUNCTION INDEX(STR, C) BYTE C, STR(100) INDEX = 1 23066 IF (.NOT.(STR(INDEX) .NE. 0))GOTO 23068 IF (.NOT.(STR(INDEX) .EQ. C))GOTO 23069 RETURN 23069 CONTINUE 23067 INDEX = INDEX + 1 GOTO 23066 23068 CONTINUE INDEX = 0 RETURN END INTEGER FUNCTION ITOC( INT, STR, SIZE) INTEGER MOD INTEGER D, I, INT, INTVAL, J, K, SIZE BYTE STR(SIZE) BYTE 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)/0/ INTVAL = IABS(INT) STR(1) = 0 I = 1 23071 CONTINUE I = I + 1 D = MOD( INTVAL, 10) STR(I) = DIGITS( D + 1 ) INTVAL = INTVAL / 10 23072 IF (.NOT.( INTVAL .EQ. 0 .OR. I .GE. SIZE ))GOTO 23071 23073 CONTINUE IF (.NOT.( INT .LT. 0 .AND. I .LT. SIZE ))GOTO 23074 I = I + 1 STR(I) = 45 23074 CONTINUE ITOC = I - 1 J = 1 23076 IF (.NOT.(J .LT. I ))GOTO 23078 K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 23077 J = J + 1 GOTO 23076 23078 CONTINUE RETURN END BYTE FUNCTION ESC( ARRAY, I) BYTE ARRAY(100), C BYTE CLOWER INTEGER I, J IF (.NOT.( ARRAY(I) .NE. 64 ))GOTO 23079 ESC = ARRAY(I) GOTO 23080 23079 CONTINUE IF (.NOT.( ARRAY( I + 1 ) .EQ. 0 ))GOTO 23081 ESC = 64 GOTO 23082 23081 CONTINUE I = I + 1 C = CLOWER( ARRAY(I) ) IF (.NOT.( C .EQ. 110 ))GOTO 23083 ESC = 10 GOTO 23084 23083 CONTINUE IF (.NOT.( C .EQ. 116 ))GOTO 23085 ESC = 9 GOTO 23086 23085 CONTINUE IF (.NOT.( C .EQ. 114 ))GOTO 23087 ESC = 13 GOTO 23088 23087 CONTINUE IF (.NOT.( C .EQ. 98 ))GOTO 23089 ESC = 8 GOTO 23090 23089 CONTINUE IF (.NOT.( C .EQ. 101 ))GOTO 23091 ESC = 0 GOTO 23092 23091 CONTINUE IF (.NOT.( C .EQ. 102 ))GOTO 23093 ESC = 12 GOTO 23094 23093 CONTINUE IF (.NOT.( C .EQ. 108 ))GOTO 23095 ESC = 10 GOTO 23096 23095 CONTINUE IF (.NOT.( C .GE. 48 .AND. C .LE. 55 ))GOTO 23097 ESC = 0 J=I 23099 IF (.NOT.(J .LT. I+3 .AND. ( ARRAY(J) .GE. 48 .AND. ARRAY(J) .LE. *55 ) ))GOTO 23101 ESC = 8 * ESC + ( ARRAY(J) - 48 ) 23100 J=J+1 GOTO 23099 23101 CONTINUE I = J - 1 GOTO 23098 23097 CONTINUE ESC = C 23098 CONTINUE 23096 CONTINUE 23094 CONTINUE 23092 CONTINUE 23090 CONTINUE 23088 CONTINUE 23086 CONTINUE 23084 CONTINUE 23082 CONTINUE 23080 CONTINUE RETURN END #-t- lib4ch.f ascii 01/09/84 15:54 #-h- libint.f ascii 01/09/84 15:54 SUBROUTINE ERROR(BUF) INTEGER BUF(100) CALL REMARK(BUF) CALL ENDST(-3) END SUBROUTINE REMARK(BUF) INTEGER BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END SUBROUTINE FOLD (TOKEN) INTEGER TOKEN(100), CLOWER INTEGER I I=1 23007 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23009 TOKEN(I) = CLOWER(TOKEN(I)) 23008 I=I+1 GOTO 23007 23009 CONTINUE RETURN END INTEGER FUNCTION LENGTH(BUF) INTEGER BUF(100) INTEGER N N = 1 23010 IF (.NOT.(BUF(N) .NE. 0))GOTO 23012 23011 N = N + 1 GOTO 23010 23012 CONTINUE LENGTH=(N - 1) RETURN END SUBROUTINE SCOPY(FROM, I, TO, J) INTEGER FROM(100), TO(100) INTEGER I, J INTEGER K, L L = J K = I 23013 IF (.NOT.(FROM(K) .NE. 0))GOTO 23015 TO(L) = FROM(K) L = L + 1 23014 K = K + 1 GOTO 23013 23015 CONTINUE TO(L) = 0 RETURN END SUBROUTINE SKIPBL(BUF, I) INTEGER BUF(100) INTEGER I 23016 IF (.NOT.(BUF(I) .EQ. 32 .OR. BUF(I) .EQ. 9))GOTO 23017 I = I + 1 GOTO 23016 23017 CONTINUE RETURN END INTEGER FUNCTION TYPE (C) INTEGER C INTEGER I INTEGER UPCASE(27) INTEGER LOCASE(27) INTEGER DIGITS(11) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ 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)/0/ I = 1 23018 IF (.NOT.(DIGITS(I) .NE. 0))GOTO 23020 IF (.NOT.(DIGITS(I) .EQ. C))GOTO 23021 TYPE=(2) RETURN 23021 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE I = 1 23023 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23025 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23026 TYPE=(1) RETURN 23026 CONTINUE 23024 I = I + 1 GOTO 23023 23025 CONTINUE I = 1 23028 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23030 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23031 TYPE=(1) RETURN 23031 CONTINUE 23029 I = I + 1 GOTO 23028 23030 CONTINUE TYPE=(C) RETURN END INTEGER FUNCTION CLOWER(C) INTEGER C, RETCH INTEGER I INTEGER UPCASE(27) INTEGER LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23033 IF (.NOT.(UPCASE(I) .NE. 0))GOTO 23035 IF (.NOT.(UPCASE(I) .EQ. C))GOTO 23036 RETCH = LOCASE(I) GOTO 23035 23036 CONTINUE 23034 I = I + 1 GOTO 23033 23035 CONTINUE CLOWER=(RETCH) RETURN END INTEGER FUNCTION CUPPER(C) INTEGER C, RETCH INTEGER I INTEGER UPCASE(27) INTEGER LOCASE(27) DATA UPCASE(1)/65/,UPCASE(2)/66/,UPCASE(3)/67/,UPCASE(4)/68/, *UPCASE(5)/69/,UPCASE(6)/70/,UPCASE(7)/71/,UPCASE(8)/72/,UPCASE(9)/ *73/,UPCASE(10)/74/,UPCASE(11)/75/,UPCASE(12)/76/,UPCASE(13)/77/, *UPCASE(14)/78/,UPCASE(15)/79/,UPCASE(16)/80/,UPCASE(17)/81/,UPCASE *(18)/82/,UPCASE(19)/83/,UPCASE(20)/84/,UPCASE(21)/85/,UPCASE(22)/8 *6/,UPCASE(23)/87/,UPCASE(24)/88/,UPCASE(25)/89/,UPCASE(26)/90/, *UPCASE(27)/0/ DATA LOCASE(1)/97/,LOCASE(2)/98/,LOCASE(3)/99/,LOCASE(4)/100/, *LOCASE(5)/101/,LOCASE(6)/102/,LOCASE(7)/103/,LOCASE(8)/104/,LOCASE *(9)/105/,LOCASE(10)/106/,LOCASE(11)/107/,LOCASE(12)/108/,LOCASE(13 *)/109/,LOCASE(14)/110/,LOCASE(15)/111/,LOCASE(16)/112/,LOCASE(17)/ *113/,LOCASE(18)/114/,LOCASE(19)/115/,LOCASE(20)/116/,LOCASE(21)/11 *7/,LOCASE(22)/118/,LOCASE(23)/119/,LOCASE(24)/120/,LOCASE(25)/121/ *,LOCASE(26)/122/,LOCASE(27)/0/ RETCH = C I = 1 23038 IF (.NOT.(LOCASE(I) .NE. 0))GOTO 23040 IF (.NOT.(LOCASE(I) .EQ. C))GOTO 23041 RETCH = UPCASE(I) GOTO 23040 23041 CONTINUE 23039 I = I + 1 GOTO 23038 23040 CONTINUE CUPPER=(RETCH) RETURN END SUBROUTINE UPPER (TOKEN) INTEGER TOKEN(100), CUPPER INTEGER I I=1 23043 IF (.NOT.(TOKEN(I) .NE. 0))GOTO 23045 TOKEN(I) = CUPPER(TOKEN(I)) 23044 I=I+1 GOTO 23043 23045 CONTINUE RETURN END SUBROUTINE CONCAT(FIRST, SECOND, OUT) INTEGER FIRST(100), SECOND(100), OUT(100) INTEGER I, J J = 1 I = 1 23046 IF (.NOT.(FIRST(I) .NE. 0))GOTO 23048 OUT(J) = FIRST(I) J = J + 1 23047 I = I + 1 GOTO 23046 23048 CONTINUE I = 1 23049 IF (.NOT.(SECOND(I) .NE. 0))GOTO 23051 OUT(J) = SECOND(I) J = J + 1 23050 I = I + 1 GOTO 23049 23051 CONTINUE OUT(J) = 0 RETURN END INTEGER FUNCTION CTOI( IN, I) INTEGER IN(100) INTEGER INDEX INTEGER D, I, SIGN 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)/0/ 23052 IF (.NOT.( IN(I) .EQ. 32 .OR. IN(I) .EQ. 9 ))GOTO 23053 I = I + 1 GOTO 23052 23053 CONTINUE SIGN = 1 IF (.NOT.( IN(I) .EQ. 45 ))GOTO 23054 SIGN = -1 I = I + 1 23054 CONTINUE CTOI = 0 23056 IF (.NOT.(IN(I) .NE. 0 ))GOTO 23058 D = INDEX( DIGITS, IN(I) ) IF (.NOT.( D .EQ. 0 ))GOTO 23059 GOTO 23058 23059 CONTINUE CTOI = 10 * CTOI + D - 1 23057 I = I + 1 GOTO 23056 23058 CONTINUE CTOI=( SIGN * CTOI ) RETURN END INTEGER FUNCTION EQUAL (STR1, STR2) INTEGER STR1(100), STR2(100) INTEGER I I=1 23061 IF (.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23063 IF (.NOT.(STR1(I) .EQ. 0))GOTO 23064 EQUAL = 1 RETURN 23064 CONTINUE 23062 I=I+1 GOTO 23061 23063 CONTINUE EQUAL = 0 RETURN END INTEGER FUNCTION INDEX(STR, C) INTEGER C, STR(100) INDEX = 1 23066 IF (.NOT.(STR(INDEX) .NE. 0))GOTO 23068 IF (.NOT.(STR(INDEX) .EQ. C))GOTO 23069 RETURN 23069 CONTINUE 23067 INDEX = INDEX + 1 GOTO 23066 23068 CONTINUE INDEX = 0 RETURN END INTEGER FUNCTION ITOC( INT, STR, SIZE) INTEGER MOD INTEGER D, I, INT, INTVAL, J, K, SIZE INTEGER STR(SIZE) 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)/0/ INTVAL = IABS(INT) STR(1) = 0 I = 1 23071 CONTINUE I = I + 1 D = MOD( INTVAL, 10) STR(I) = DIGITS( D + 1 ) INTVAL = INTVAL / 10 23072 IF (.NOT.( INTVAL .EQ. 0 .OR. I .GE. SIZE ))GOTO 23071 23073 CONTINUE IF (.NOT.( INT .LT. 0 .AND. I .LT. SIZE ))GOTO 23074 I = I + 1 STR(I) = 45 23074 CONTINUE ITOC = I - 1 J = 1 23076 IF (.NOT.(J .LT. I ))GOTO 23078 K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 23077 J = J + 1 GOTO 23076 23078 CONTINUE RETURN END INTEGER FUNCTION ESC( ARRAY, I) INTEGER ARRAY(100), C INTEGER CLOWER INTEGER I, J IF (.NOT.( ARRAY(I) .NE. 64 ))GOTO 23079 ESC = ARRAY(I) GOTO 23080 23079 CONTINUE IF (.NOT.( ARRAY( I + 1 ) .EQ. 0 ))GOTO 23081 ESC = 64 GOTO 23082 23081 CONTINUE I = I + 1 C = CLOWER( ARRAY(I) ) IF (.NOT.( C .EQ. 110 ))GOTO 23083 ESC = 10 GOTO 23084 23083 CONTINUE IF (.NOT.( C .EQ. 116 ))GOTO 23085 ESC = 9 GOTO 23086 23085 CONTINUE IF (.NOT.( C .EQ. 114 ))GOTO 23087 ESC = 13 GOTO 23088 23087 CONTINUE IF (.NOT.( C .EQ. 98 ))GOTO 23089 ESC = 8 GOTO 23090 23089 CONTINUE IF (.NOT.( C .EQ. 101 ))GOTO 23091 ESC = 0 GOTO 23092 23091 CONTINUE IF (.NOT.( C .EQ. 102 ))GOTO 23093 ESC = 12 GOTO 23094 23093 CONTINUE IF (.NOT.( C .EQ. 108 ))GOTO 23095 ESC = 10 GOTO 23096 23095 CONTINUE IF (.NOT.( C .GE. 48 .AND. C .LE. 55 ))GOTO 23097 ESC = 0 J=I 23099 IF (.NOT.(J .LT. I+3 .AND. ( ARRAY(J) .GE. 48 .AND. ARRAY(J) .LE. *55 ) ))GOTO 23101 ESC = 8 * ESC + ( ARRAY(J) - 48 ) 23100 J=J+1 GOTO 23099 23101 CONTINUE I = J - 1 GOTO 23098 23097 CONTINUE ESC = C 23098 CONTINUE 23096 CONTINUE 23094 CONTINUE 23092 CONTINUE 23090 CONTINUE 23088 CONTINUE 23086 CONTINUE 23084 CONTINUE 23082 CONTINUE 23080 CONTINUE RETURN END #-t- libint.f ascii 01/09/84 15:54 #-h- libsym.rat ascii 01/09/84 15:54 #-h- error local 10-may-83 12:17:41 subroutine error(buf) character buf(ARB) call remark(buf) call endst(ERR) end #-t- error local 10-may-83 12:17:41 #-h- remark local 10-may-83 12:17:41 subroutine remark(buf) character buf(ARB) integer i for (i = 1; buf(i) != EOS; i = i + 1) ; i = i - 1 call putlin(buf, ERROUT) if (i > 0) if (buf(i) == NEWLINE) return call putch(NEWLINE, ERROUT) return end #-t- remark local 10-may-83 12:17:41 #-h- fold local 10-may-83 12:17:41 ## fold - fold all letters to lower case subroutine fold (token) character token(ARB), clower integer i for (i=1; token(i) != EOS; i=i+1) token(i) = clower(token(i)) return end #-t- fold local 10-may-83 12:17:41 #-h- length local 10-may-83 12:17:41 integer function length(buf) character buf(ARB) integer n for (n = 1; buf(n) != EOS; n = n + 1) ; return (n - 1) end #-t- length local 10-may-83 12:17:41 #-h- scopy local 10-may-83 12:17:42 subroutine scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j integer k, l l = j for (k = i; from(k) != EOS; k = k + 1) { to(l) = from(k) l = l + 1 } to(l) = EOS return end #-t- scopy local 10-may-83 12:17:42 #-h- skipbl local 10-may-83 12:17:42 subroutine skipbl(buf, i) character buf(ARB) integer i while (buf(i) == BLANK | buf(i) == TAB) i = i + 1 return end #-t- skipbl local 10-may-83 12:17:42 #-h- type local 10-may-83 12:17:42 ## type - determine type of character integer function type (c) character c integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" string digits "0123456789" # for (i = 1; digits(i) != EOS; i = i + 1) if (digits(i) == c) return(DIGIT) for (i = 1; locase(i) != EOS; i = i + 1) if (locase(i) == c) return(LETTER) for (i = 1; upcase(i) != EOS; i = i + 1) if (upcase(i) == c) return(LETTER) return(c) end #-t- type local 10-may-83 12:17:42 #-h- clower local 10-may-83 12:17:42 ## clower - change letter to lower case character function clower(c) character c, retch integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" retch = c # assume not upper case for (i = 1; upcase(i) != EOS; i = i + 1) if (upcase(i) == c) { retch = locase(i) break } return (retch) end #-t- clower local 10-may-83 12:17:42 #-h- cupper local 10-may-83 12:17:43 ## cupper - change letter to upper case character function cupper(c) character c, retch integer i string upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string locase "abcdefghijklmnopqrstuvwxyz" retch = c # assume not lower case for (i = 1; locase(i) != EOS; i = i + 1) if (locase(i) == c) { retch = upcase(i) break } return (retch) end #-t- cupper local 10-may-83 12:17:43 #-h- upper local 10-may-83 12:17:43 ## upper - force all letters to upper case subroutine upper (token) character token(ARB), cupper integer i for (i=1; token(i) != EOS; i=i+1) token(i) = cupper(token(i)) return end #-t- upper local 10-may-83 12:17:43 #-h- concat local 10-may-83 12:17:43 subroutine concat(first, second, out) character first(ARB), second(ARB), out(ARB) integer i, j j = 1 for (i = 1; first(i) != EOS; i = i + 1) { out(j) = first(i) j = j + 1 } for (i = 1; second(i) != EOS; i = i + 1) { out(j) = second(i) j = j + 1 } out(j) = EOS return end #-t- concat local 10-may-83 12:17:43 #-h- ctoi local 10-may-83 12:17:44 ## CToI -- Convert string at `in(i)' to integer; increment `i'. integer function ctoi( in, i) character in(ARB) integer index # function(s) integer d, i, sign string digits "0123456789" while( in(i) == BLANK | in(i) == TAB ) i = i + 1 sign = 1 if( in(i) == MINUS ) { sign = -1 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( sign * ctoi ) end #-t- ctoi local 10-may-83 12:17:44 #-h- equal local 10-may-83 12:17:44 ## 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) { equal = YES return } equal = NO return end #-t- equal local 10-may-83 12:17:44 #-h- index local 10-may-83 12:17:44 ## index - find character c in string str integer function index(str, c) character c, str(ARB) for (index = 1; str(index) != EOS; index = index + 1) if (str(index) == c) return index = 0 return end #-t- index local 10-may-83 12:17:44 #-h- itoc local 10-may-83 12:17:44 ## IToC -- Convert integer `int' to character string in `str'. integer function itoc( int, str, size) integer mod # function(s) integer d, i, int, intval, j, k, size character str(size) string digits "0123456789" intval = abs(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 #-t- itoc local 10-may-83 12:17:44 #-h- esc local 10-may-83 12:17:45 ## Esc -- Map `array(i)' into escaped character, if appropriate. character function esc( array, i) character array(ARB), c character clower # function(s) integer i, j if( array(i) != ESCAPE ) esc = array(i) else if( array( i + 1 ) == EOS ) # ESCAPE not special at end esc = ESCAPE else { i = i + 1 c = clower( array(i) ) if( c == LETN ) esc = NEWLINE else if( c == LETT ) esc = TAB else if( c == LETR ) esc = CR else if( c == LETB ) esc = BS else if( c == LETE ) esc = EOS else if( c == LETF ) esc = FF else if( c == LETL ) esc = LF else if( c >= DIG0 & c <= DIG7 ) { esc = 0 for( j=i ; j < i+3 & ( array(j) >= DIG0 & array(j) <= DIG7 ) ; j=j+1 ) esc = 8 * esc + ( array(j) - DIG0 ) i = j - 1 } else esc = c } return end #-t- esc local 10-may-83 12:17:45 #-t- libsym.rat ascii 01/09/84 15:54 #-h- ratdef2ch ascii 01/09/84 15:54 # # Extensions to dynamic storage scheme # # The previous storage scheme forced characters to be stored into # integer locations. Some systems can use smaller storage cells for # characters than integers. As a result, the following definitions # permit characters to be stored in character cells which are overlayed # over the previous integer declaration for the "dynamic storage" # region. # # In addition, the revised routines supplied in ds.rat do NOT invoke # dump routines in panic situations - instead, if an allocation fails, # the value LAMBDA is returned, permitting the calling program to # take the appropriate action. # # If DS_DECL(Mem,size) is invoked, array Mem accesses integers and # array cMem accesses characters # define(DS_DECL,integer $1($2);character c$1(arith($2,*,CHAR_PER_INT)); equivalence (c$1(1),$1(1));common /cdsmem/ $1) # # given a pointer to an integer cell in the dynamic storage region, # this macro generates an index to the equivalent character cell # define(cvt_to_cptr,(CHAR_PER_INT*($1-1)+1)) # convert pointer to char ptr # # This value permits the routines to be written portably. Define this # to be the number of "character"s per integer on your system. # define(CHAR_PER_INT,2) define(LAMBDA,0) # end of list marker # # The remainder of these definitions are those needed to bring up the # pre-processor in all of its various configurations. You should change # these values to reflect those that you are currently using. # Both ratp1 and ratp2 are conditionalized on the definition (or # lack thereof) of the macros IS_LETTER and IS_DIGIT. If they are # not found, the library routine `type' is invoked to determine # what kind of character is being scanned. # define(FILENAMESIZE,36) # max characters in file name define(YES,1) define(EOF,-1) define(EOS,0) define(STDIN,1) # standard input file define(STDOUT,2) # standard output file define(READ,1) define(OK,0) define(ERR,-3) define(ERROUT,3) # standard error file define(DRIVER,call initst; call $1; call endst(OK); end; subroutine $1) define(DRETURN,return) # (returning from subroutine defined in DRIVER) define(ARB,100) define(NO,0) define(ALPHA,-9) define(DIGIT,2) define(LETTER,1) define(AND,'&') define(OR,'|') define(NOT,'!') # used in pattern matching; choose ~, ^, or ! define(MAXNAME,FILENAMESIZE) # max size of file name define(MAXOFILES,7) # max nbr opened files allowed at a time define(MAXCHARS,20) # max nbr of chars when converting define(character,byte) define(pointer,integer) define(min,min0) define(andif,if) define(elif,else if) define(abs,iabs) define(MAXCARD,80) define(MAXLINE,82) define(filedes,integer) define(ESCAPE,'@@') #escape character for ch, find, tr, ed, and sh # # uncomment these lines if your internal character set is ASCII # #define(IS_DIGIT,('0'<=$1&$1<='9')) # valid only for ASCII! #define(IS_LETTER,(IS_UPPER($1)|IS_LOWER($1))) #define(IS_LOWER,('a'<=$1&$1<='z')) #define(IS_UPPER,('A'<=$1&$1<='Z')) #-t- ratdef2ch ascii 01/09/84 15:54 #-h- ratdef4ch ascii 01/09/84 15:54 # # Extensions to dynamic storage scheme # # The previous storage scheme forced characters to be stored into # integer locations. Some systems can use smaller storage cells for # characters than integers. As a result, the following definitions # permit characters to be stored in character cells which are overlayed # over the previous integer declaration for the "dynamic storage" # region. # # In addition, the revised routines supplied in ds.rat do NOT invoke # dump routines in panic situations - instead, if an allocation fails, # the value LAMBDA is returned, permitting the calling program to # take the appropriate action. # # If DS_DECL(Mem,size) is invoked, array Mem accesses integers and # array cMem accesses characters # define(DS_DECL,integer $1($2);character c$1(arith($2,*,CHAR_PER_INT)); equivalence (c$1(1),$1(1));common /cdsmem/ $1) # # given a pointer to an integer cell in the dynamic storage region, # this macro generates an index to the equivalent character cell # define(cvt_to_cptr,(CHAR_PER_INT*($1-1)+1)) # convert pointer to char ptr # # This value permits the routines to be written portably. Define this # to be the number of "character"s per integer on your system. # define(CHAR_PER_INT,4) define(LAMBDA,0) # end of list marker # # The remainder of these definitions are those needed to bring up the # pre-processor in all of its various configurations. You should change # these values to reflect those that you are currently using. # Both ratp1 and ratp2 are conditionalized on the definition (or # lack thereof) of the macros IS_LETTER and IS_DIGIT. If they are # not found, the library routine `type' is invoked to determine # what kind of character is being scanned. # define(FILENAMESIZE,36) # max characters in file name define(YES,1) define(EOF,-1) define(EOS,0) define(STDIN,1) # standard input file define(STDOUT,2) # standard output file define(READ,1) define(OK,0) define(ERR,-3) define(ERROUT,3) # standard error file define(DRIVER,call initst; call $1; call endst(OK); end; subroutine $1) define(DRETURN,return) # (returning from subroutine defined in DRIVER) define(ARB,100) define(NO,0) define(ALPHA,-9) define(DIGIT,2) define(LETTER,1) define(AND,'&') define(OR,'|') define(NOT,'!') # used in pattern matching; choose ~, ^, or ! define(MAXNAME,FILENAMESIZE) # max size of file name define(MAXOFILES,7) # max nbr opened files allowed at a time define(MAXCHARS,20) # max nbr of chars when converting define(character,byte) define(pointer,integer) define(min,min0) define(andif,if) define(elif,else if) define(abs,iabs) define(MAXCARD,80) define(MAXLINE,82) define(filedes,integer) define(ESCAPE,'@@') #escape character for ch, find, tr, ed, and sh # # uncomment these lines if your internal character set is ASCII # #define(IS_DIGIT,('0'<=$1&$1<='9')) # valid only for ASCII! #define(IS_LETTER,(IS_UPPER($1)|IS_LOWER($1))) #define(IS_LOWER,('a'<=$1&$1<='z')) #define(IS_UPPER,('A'<=$1&$1<='Z')) #-t- ratdef4ch ascii 01/09/84 15:54 #-h- ratdefint ascii 01/09/84 15:54 # # Extensions to dynamic storage scheme # # The previous storage scheme forced characters to be stored into # integer locations. Some systems can use smaller storage cells for # characters than integers. As a result, the following definitions # permit characters to be stored in character cells which are overlayed # over the previous integer declaration for the "dynamic storage" # region. # # In addition, the revised routines supplied in ds.rat do NOT invoke # dump routines in panic situations - instead, if an allocation fails, # the value LAMBDA is returned, permitting the calling program to # take the appropriate action. # # If DS_DECL(Mem,size) is invoked, array Mem accesses integers and # array cMem accesses characters # define(DS_DECL,integer $1($2);character c$1(arith($2,*,CHAR_PER_INT)); equivalence (c$1(1),$1(1));common /cdsmem/ $1) # # given a pointer to an integer cell in the dynamic storage region, # this macro generates an index to the equivalent character cell # define(cvt_to_cptr,(CHAR_PER_INT*($1-1)+1)) # convert pointer to char ptr # # This value permits the routines to be written portably. Define this # to be the number of "character"s per integer on your system. # define(CHAR_PER_INT,1) define(LAMBDA,0) # end of list marker # # The remainder of these definitions are those needed to bring up the # pre-processor in all of its various configurations. You should change # these values to reflect those that you are currently using. # Both ratp1 and ratp2 are conditionalized on the definition (or # lack thereof) of the macros IS_LETTER and IS_DIGIT. If they are # not found, the library routine `type' is invoked to determine # what kind of character is being scanned. # define(FILENAMESIZE,36) # max characters in file name define(YES,1) define(EOF,-1) define(EOS,0) define(STDIN,1) # standard input file define(STDOUT,2) # standard output file define(READ,1) define(OK,0) define(ERR,-3) define(ERROUT,3) # standard error file define(DRIVER,call initst; call $1; call endst(OK); end; subroutine $1) define(DRETURN,return) # (returning from subroutine defined in DRIVER) define(ARB,100) define(NO,0) define(ALPHA,-9) define(DIGIT,2) define(LETTER,1) define(AND,'&') define(OR,'|') define(NOT,'!') # used in pattern matching; choose ~, ^, or ! define(MAXNAME,FILENAMESIZE) # max size of file name define(MAXOFILES,7) # max nbr opened files allowed at a time define(MAXCHARS,20) # max nbr of chars when converting define(character,integer) define(pointer,integer) define(min,min0) define(andif,if) define(elif,else if) define(abs,iabs) define(MAXCARD,80) define(MAXLINE,82) define(filedes,integer) define(ESCAPE,'@@') #escape character for ch, find, tr, ed, and sh # # uncomment these lines if your internal character set is ASCII # #define(IS_DIGIT,('0'<=$1&$1<='9')) # valid only for ASCII! #define(IS_LETTER,(IS_UPPER($1)|IS_LOWER($1))) #define(IS_LOWER,('a'<=$1&$1<='z')) #define(IS_UPPER,('A'<=$1&$1<='Z')) #-t- ratdefint ascii 01/09/84 15:54 #-h- ratfix.z ascii 01/09/84 15:54 #-h- cunget local 11-may-83 14:37:42 common / cunget / lsttok, pbchar integer lsttok # last token type - init = '@n' character pbchar # pushed back character - init = EOS #-t- cunget local 11-may-83 14:37:42 #-h- ratfix local 11-may-83 14:37:42 #-h- defns local 11-may-83 14:37:11 # # if you wish to have ratfix eliminate the final periods found in quoted # strings, uncomment the statement below # define(INTELLIGENT_STRING_HANDLING,) #-t- defns local 11-may-83 14:37:11 #-h- main local 11-may-83 14:37:11 DRIVER(ratfix) character file(FILENAMESIZE) filedes fd integer i integer getarg, equal filedes open string minust "-" call query("usage: ratfix [file] ...") for (i = 1; getarg(i, file, FILENAMESIZE) != EOF; i = i + 1) { if (equal(file, minust) == YES) fd = STDIN else fd = open(file, READ) if (fd == ERR) call cant(fd) call fixit(fd) if (fd != STDIN) call close(fd) } if (i == 1) # used as a filter call fixit(STDIN) DRETURN end #-t- main local 11-may-83 14:37:11 #-h- fixit local 11-may-83 14:37:12 subroutine fixit(fd) filedes fd character buf(MAXLINE), result(1024) integer stat, n, i integer quowrd, equal include cunget string ifdefs "ifdef" string ifnots "ifnotdef" string enddfs " enddef " pbchar = EOS lsttok = '@n' repeat { stat = quowrd(buf, fd) if (stat == EOF) break call putlin(buf, STDOUT) # output token if (stat == LETTER) # see if ifdef or ifnotdef { call fold(buf) if (equal(buf, ifdefs) == YES | equal(buf, ifnots) == YES) # Convert { call ifetch(buf, result, fd) # get (buf,result) call putch('(', STDOUT) # output (buf) call putlin(buf, STDOUT) call putch(')', STDOUT) call putlin(result, STDOUT) # output result call putlin(enddfs, STDOUT) # output enddef } } } return end #-t- fixit local 11-may-83 14:37:12 #-h- gtch local 11-may-83 14:37:13 character function gtch(c, int) character c filedes int character getch include cunget if (pbchar != EOS) { c = pbchar pbchar = EOS } else c = getch(c, int) return(c) end #-t- gtch local 11-may-83 14:37:13 #-h- ifetch local 11-may-83 14:37:13 subroutine ifetch(sym, defn, fd) character sym(MAXLINE), defn(1024) filedes fd integer junk, nlpar, j, stat integer quowrd character temp(MAXLINE) while (quowrd(sym, fd) != '(') call putlin(sym, STDOUT) junk = quowrd(sym, fd) # have symbol name junk = quowrd(temp, fd) # have comma nlpar = 1 j = 1 call chcopy(' ', defn, j) # assure white space before body repeat { stat = quowrd(temp, fd) if (stat == '(') nlpar = nlpar + 1 else if (stat == ')') nlpar = nlpar - 1 if (nlpar <= 0) break call stcopy(temp, 1, defn, j) } return end #-t- ifetch local 11-may-83 14:37:13 #-h- quowrd local 11-may-83 14:37:13 # quowrd - fetch next ratfor token from fd, converting '...' to "..." # if INTELLIGENT_STRING_HANDLING is defined, then trailing isolated periods # found in quoted strings will also be eliminated, as it is no longer needed # to delimit the end of an hollerith string integer function quowrd(buf, fd) character buf(MAXLINE), temp(MAXLINE) integer stat, i, n, j integer ratwrd, length filedes fd stat = ratwrd(buf, fd) if (stat == '@'') # convert '...' ==> "..." { call scopy(buf, 1, temp, 1) j = 1 call chcopy('"', buf, j) n = length(temp) for (i = 2; i < n; i = i + 1) { if (temp(i) == '"') # must escape '"' call chcopy('@@', buf, j) call chcopy(temp(i), buf, j) } call chcopy('"', buf, j) stat = '"' } ifdef(INTELLIGENT_STRING_HANDLING) if (stat == '"') # check for isolated '.' at end of ".." { n = length(buf) - 1 if (buf(n) == '.') # found period; see if isolated if (buf(n-1) != '.') # YES, trim the period call chcopy('"', buf, n) } enddef return (stat) end #-t- quowrd local 11-may-83 14:37:13 #-h- ratwrd local 11-may-83 14:37:14 integer function ratwrd(buf, fd) character buf(MAXLINE), c, trmchr filedes fd integer i, t, stat character gtch integer type c = gtch(buf(1), fd) buf(2) = EOS if (c == EOF) return(EOF) stat = type(c) i = 2 if (stat == LETTER) { while (gtch(c, fd) != EOF) { t = type(c) if (t != LETTER & t != DIGIT & t != '_') break else call chcopy(c, buf, i) } call ungtch(c, fd) } else if (c == '"' | c == '@'') { trmchr = c while (gtch(c, fd) != EOF) { call chcopy(c, buf, i) if (c == trmchr & buf(i-2) != '@@') break } } else if (c == '#') while (gtch(c, fd) != EOF) { if (c == '@n') { call ungtch(c, fd) break } call chcopy(c, buf, i) } else if (c == '%' & lsttok == '@n') # literal line while (gtch(c, fd) != EOF) { if (c == '@n') { call ungtch(c, fd) break } call chcopy(c, buf, i) } lsttok = stat return(stat) end #-t- ratwrd local 11-may-83 14:37:14 #-h- ungtch local 11-may-83 14:37:15 subroutine ungtch(c, int) character c filedes int include cunget if (pbchar != EOS) call error("Attempt to push back more than one character.") pbchar = c return end #-t- ungtch local 11-may-83 14:37:15 #-t- ratfix local 11-may-83 14:37:42 #-h- ratfixdoc local 11-may-83 14:37:45 .de hd .pl 60 .bp .in 4 .rm 72 .he '$1 $2'$3 $4 $5 $6 $7 $8'$1 $2' .fo ''-#-'' .fi .in 8 .ti -4 NAME .br $1 - .en .de sy .sp 1 .ti -4 SYNOPSIS .br .nf .en .de ds .fi .sp .ti -4 DESCRIPTION .br .en .de fu .fi .sp 1 .ti -4 FUNCTION .br .en .de di .fi .sp .ti -4 DIAGNOSTICS .br .en .de re .fi .sp .ti -4 RETURNS .br .en .de fl .fi .sp .ti -4 FILES .br .en .de ex .fi .sp .ti -4 EXAMPLES .nf .br .en .de im .fi .sp .ti -4 IMPLEMENTATION .br .en .de sa .fi .sp .ti -4 SEE ALSO .br .en .de am .fi .sp .ti -4 ARGUMENTS MODIFIED .br .en .de ca .fi .sp .ti -4 CALLS .br .en .de bu .fi .sp .ti -4 BUGS/DEFICIENCIES .br .en .de au .fi .sp .ti -4 AUTHORS .br .en .hd Ratfix (1) 10-May-83 Convert old style ratfor to new style .sy ratfix [file] ... .ds `ratfix' converts ratfor which was valid for the last Software Tools distributed version of the ratfor pre-processor to a form which is valid for the newly released version of the processor. Two items are corrected: .sp .in +3 .ti -3 1. Quoted strings which are delimited by '...' are converted to "...". This is necessary, since apostrophe's are now used to delimit character constants ('a'). .sp .ti -3 2. The syntax of the conditional pre-processing statements has changed. The old functional form .sp ifdef(symbol,stuff to pre-process) .sp has now been superceded by a more general form .sp .nf ifdef(symbol) .in +4 * * * .ti -4 elsedef * * * .in -4 enddef .fi where the elsedef clause is optional. A similar form is provided for ifnotdef. `ratfix' will convert the functional form to the new form. .sp There is an additional feature which may be enabled by defining the symbol INTELLIGENT_STRING_HANDLING. If this is defined when `ratfix' is built, then all quoted strings which end in a bare period .sp "?*[!.]." .sp will have that final period removed. The period was the canonical character to place at the end of a quoted string to permit `remark' to find the end of the hollerith string. Since `ratp1' & `ratp2' now do away with the hollerith type for all non-system-specific applications, the landmark period is no longer necessary. .sa ratfor, the ratfor preprocessor, for descriptions of the language. .br ratp2 - the second pass of the pre-processor .au Joe Sventek wrote ratfix. .bu #-t- ratfixdoc local 11-may-83 14:37:45 #-t- ratfix.z ascii 01/09/84 15:54 #-h- ratfor.z ascii 01/09/84 15:54 #-h- common ascii 01/09/84 15:35 # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements ifdef (DO_SWITCH) common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information enddef common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words ifdef (DO_LONGNAME) common /clname/ fkwtbl, namtbl, gentbl 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 enddef common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES ifdef(DO_PASS1) common / cpass1 / strcnt ifdef(DO_CHAR_DECL) , chrcnt enddef integer strcnt # counter for generated string variables - init = 1 ifdef(DO_CHAR_DECL) integer chrcnt # counter for generated character variables - init=1 enddef enddef DS_DECL(mem, MEMSIZE) #-t- common ascii 01/09/84 15:35 #-h- ratfor ascii 01/09/84 15:35 #-h- defns ascii 01/09/84 15:33 # Ratfor preprocessor # include ratdef #--------------------------------------------------------------- # 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 STDEFNS to "". # The suggested name for this file is `ratdef'. # #--------------------------------------------------------------- # If you want the preprocessor to output upper case only, # set the following definition: # # define (UPPERC,) # # This is defined by default #--------------------------------------------------------------- # If you want the preprocessor to perform the long name conversion, # set the following definition # # define (DO_LONGNAME,) # #--------------------------------------------------------------- # If you want the preprocessor to process the switch statement, # set the following definition # # define (DO_SWITCH,) # # This is defined by default #--------------------------------------------------------------- # Quoted string handling # # One of the major changes to the pre-processor with this release # is to permit pre-processors to be built which handle # quoted strings differently. # # This action is determined by one of three defined symbols: # # DO_PASS1 - all quoted strings encountered will have a character # variable name generated for them, with the appropriate # data statements expanded inline with the declaration. # As a result, all quoted strings are legal character # variables, and may be used anywhere a character array # could be used before. For example # # call putlin("Hello world.@n", STDOUT) # # is now legal. This is at the expense of requiring that # the output of the pre-processor must be run through the # second pass of the processor, RATP2. In addition, the # variable generated by the switch statement is declared # to be of type INTEGER. # # DO_F77_STRINGS - all quoted strings are output as F77 style strings. # it is expected that sites who wish to use ratfor # to pre-process into F77 will define this symbol # instead of DO_PASS1 and probably will define # STDEFNS to be "". Such a version of the pre-processor # should probably be called RAT77 # # DO_HOLLERITH - this outputs hollerith strings as before. # # The default is DO_PASS1. #--------------------------------------------------------------- # If you want to generate the fortran bootstrap, # set the following definition # # define (DO_BOOTSTRAP,) # # In addition, it will be necessary to append the fortran of several # of the library routines to the generated fortran file. #--------------------------------------------------------------- # 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) # #----------------------------------------------------------------- ifnotdef (STDEFNS) define(STDEFNS,"ratdef") enddef define (ALPHA_CHARACTERS,"_") # the set of legal characters in alpha tokens # VMS users might like to set this to "_$" define (UPPERC,) # define if Fortran compiler wants upper case define (DO_SWITCH,) # process the switch statement # # Pick only ONE of the following pairs !!!!! # #define (DO_PASS1,) # output char decl and data statements for "...." #define (USE_STRING,"usage: ratp1 [-n] [file] ... >outfile") #define (DO_F77_STRINGS,) # output F77 strings for "...." #define (USE_STRING,"usage: rat77 [-n] [file] ... >outfile") #define (DO_HOLLERITH,) # output hollerith strings for "...." #define (USE_STRING,"usage: ratfor [-n] [file] ... >outfile") # # apply defaults # ifnotdef(USE_STRING) define(DO_PASS1,) define(USE_STRING,"usage: ratp1 [-n] [file] ... >outfile") enddef define (RADIX,'%') # % indicates alternate radix define (TOGGLE,'%') # toggle for literal lines define (ARGFLAG,'$') # parameter delimeter in macros 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,'0') # used in long-name uniquing define (MAXIDLENGTH,6) # for Fortran 66 and 77 # Lexical items: define (LEXBREAK,-8) define (LEXCASE,-25) define (LEXDEFAULT,-26) define (LEXDIGITS,-9) define (LEXDO,-10) define (LEXELSE,-11) define (LEXEND,-21) define (LEXFOR,-16) define (LEXIF,-19) define (LEXLITERAL,-27) define (LEXNEXT,-13) define (LEXOTHER,-14) define (LEXREPEAT,-17) define (LEXRETURN,-20) define (LEXSTOP,-22) define (LEXSTRING,-23) define (LEXSWITCH,-24) define (LEXUNTIL,-18) define (LEXWHILE,-15) define (LSTRIPC,-10) define (RSTRIPC,-11) define (LITQUOTEC,-12) # 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 (ELSEDEFTYPE,-17) define (ENDDEFTYPE,-18) define (NOTDEFTYPE,-19) define (UNDEFTYPE,-21) define (LINKTYPE,-22) define (LENTOKTYPE,-23) # Size-limiting definitions: ifdef(LARGE_ADDRESS_SPACE) define(A_S_X,5) elsedef define(A_S_X,1) enddef define(EVALSIZE,arith(A_S_X,*,500)) define(MEMSIZE,arith(A_S_X,*,4250)) # symbol tables and macro text define(MAXDEF,arith(A_S_X,*,250)) # max chars in a defn define(SBUFSIZE,arith(A_S_X,*,600)) # buffer for string statements define (BUFSIZE,arith(2,*,MAXDEF)) # pushback buffer size define (MAXFORSTK,300) # max space for for reinit clauses define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) define (MAXSTACK,100) # max stack depth for parser define (MAXSWITCH,300) # max stack for switch statement define (MAXTOK,120) # max chars in a token define (NFILES,arith(MAXOFILES,-,3)) # maximum number of include file nests define (MAXNBRSTR,20) # max nbr string decls per module define (CALLSIZE,50) define (ARGSIZE,100) define (COND_STACK_DEPTH,10) # size of conditional stack define (C_TRUE,1) # conditional value is true # Where to find the common blocks: define(COMMON_BLOCKS,"common") define(ext_subr,#) define(ext_func,) ifnotdef(DO_PASS1) undefine(DO_CHAR_DECL) enddef ifdef(DO_BOOTSTRAP) undefine(DO_SWITCH) # bootstrap does not need switch enddef #-t- defns ascii 01/09/84 15:33 #-h- main ascii 01/09/84 15:33 DRIVER(ratfor) include COMMON_BLOCKS integer i, n ext_func integer getarg, open ext_subr query, initkw, ratarg, lodsym, cant, parse, close, lndict character arg (FILENAMESIZE) ifnotdef (DO_BOOTSTRAP) call query (USE_STRING) enddef call initkw # initialize variables ifnotdef (DO_BOOTSTRAP) call ratarg # process command line flags if (dosym == YES) # load symbols call lodsym(arg) # Read standard definitions file n = 1 for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) { if (arg (1) == '-') if (arg(2) == EOS) infile (1) = STDIN else next # skip command flags else { infile (1) = open (arg, READ) if (infile (1) == ERR) call cant (arg) } n = n + 1 call parse if (infile (1) != STDIN) call close (infile (1)) } if (n == 1) { # no files given on command line, use STDIN enddef infile (1) = STDIN call parse ifnotdef (DO_BOOTSTRAP) } enddef ifdef (DO_LONGNAME) call lndict enddef DRETURN end #-t- main ascii 01/09/84 15:33 #-h- baderr ascii 01/09/84 15:33 # baderr --- report fatal error message, then die subroutine baderr (msg) character msg (ARB) ext_subr synerr, endst call synerr (msg) call endst(ERR) return end #-t- baderr ascii 01/09/84 15:33 #-h- balpar ascii 01/09/84 15:33 # balpar - copy balanced paren string subroutine balpar character t, token (MAXTOK) ext_func character gettok, gnbtok ext_subr synerr, outstr, pbstr, squash integer nlpar if (gnbtok (token, MAXTOK) != '(') { call synerr ("missing left paren") return } call outstr (token) nlpar = 1 repeat { t = gettok (token, MAXTOK) if (t == ';' | t == '{' | t == '}' | t == EOF) { call pbstr (token) break } if (t == '@n') # delete newlines token (1) = EOS else if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef # else nothing special call outstr (token) } until (nlpar <= 0) if (nlpar != 0) call synerr ("missing parenthesis in condition") return end #-t- balpar ascii 01/09/84 15:33 #-h- brknxt ascii 01/09/84 15:33 # brknxt - generate code for break n and next n; n = 1 is default subroutine brknxt (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token integer i, n character t ext_func integer alldig, ctoi ext_func character gnbtok ext_subr pbstr, outgo, synerr include COMMON_BLOCKS n = 0 t = gnbtok (scrtok, MAXTOK) if (alldig (scrtok) == YES) { # have break n or next n i = 1 n = ctoi (scrtok, i) - 1 } else if (t != ';') # default case call pbstr (scrtok) 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 #-t- brknxt ascii 01/09/84 15:33 #-h- cascod ascii 01/09/84 15:33 # cascod - generate code for case or default label ifdef (DO_SWITCH) subroutine cascod (lab, token) integer lab, token include COMMON_BLOCKS integer t, l, lb, ub, i, j, junk ext_func integer caslab, labgen ext_func character gnbtok ext_subr synerr, outgo, baderr, outcon if (swtop <= 0) { call synerr ("illegal case or default") return } 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 == '-') 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 == ':') break else if (t != ',') call synerr ("illegal case syntax") } } else { # default : ... t = gnbtok (scrtok, MAXTOK) if (swstak (swtop + 2) != 0) call baderr ("multiple defaults in switch statement") else swstak (swtop + 2) = l } if (t == EOF) call synerr ("unexpected EOF") else if (t != ':') call baderr ("missing colon in case or default label") xfer = NO call outcon (l) return end enddef #-t- cascod ascii 01/09/84 15:33 #-h- caslab ascii 01/09/84 15:33 # caslab - get one case label ifdef (DO_SWITCH) integer function caslab (n, t) integer n, t character tok (MAXTOK) integer i, s ext_func character gnbtok ext_func integer ctoi ext_subr synerr t = gnbtok (tok, MAXTOK) while (t == '@n') t = gnbtok (tok, MAXTOK) if (t == EOF) return (t) if (t == '-') s = -1 else s = +1 if (t == '-' | t == '+') t = gnbtok (tok, MAXTOK) if (t != DIGIT) { call synerr ("invalid case label") n = 0 } else { i = 1 n = s * ctoi (tok, i) } t = gnbtok (tok, MAXTOK) while (t == '@n') t = gnbtok (tok, MAXTOK) return end enddef #-t- caslab ascii 01/09/84 15:33 #-h- contln ascii 01/09/84 15:33 ### contln - start a continuation line subroutine contln include COMMON_BLOCKS string blstar " *" call outdon call scopy(blstar, 1, outbuf, 1) outp = 6 return end #-t- contln ascii 01/09/84 15:33 #-h- deftok ascii 01/09/84 15:33 # deftok - get token; process macro calls and invocations # 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) integer ap, argstk (ARGSIZE), callst (CALLSIZE), nlb, plev (CALLSIZE), ifl ext_func integer ludef, push, ifparm, enter ext_func character gctok ext_subr puttok, getdef, entdef, baderr, putchr, pbstr, putbak, evalr, fold string balp "()" cp = 0 ap = 1 ep = 1 repeat { t = gctok (token, toksiz) if (t == EOF) break 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) == UNDEFTYPE) { # undefine the token call getund (token) # get name to undefine call rmdef (token, deftbl) } ifdef(DO_LONGNAME) else if (defn (1) == LINKTYPE) { # process linkage statement call getdef (token, toksiz, defn, MAXDEF) call fold(token) call fold(defn) call entdef (token, defn, namtbl) if (enter(defn, 0, gentbl) == ERR) call synerr("No room for linkage external name") } enddef 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 = gctok (token, toksiz) if (t == ' ') { # allow blanks before arguments t = gctok (token, toksiz) call pbstr (token) if (t != '(') call putbak (' ') } else call pbstr (token) if (t != '(') call pbstr (balp) else if (ifparm (defn) == NO) call pbstr (balp) plev (cp) = 0 } else if (t == LSTRIPC) { nlb = 1 repeat { t = gctok (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 == '(') { if (plev (cp) > 0) call puttok (token) plev (cp) = plev (cp) + 1 } else if (t == ')') { 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 == ',' & 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 #-t- deftok ascii 01/09/84 15:33 #-h- dmpdcl ascii 01/09/84 15:33 ifdef(DO_PASS1) # dmpdcl - dump accumulated declarations subroutine dmpdcl(token) character token(ARB) integer i, j, n character c ext_func integer index ext_func character esc include COMMON_BLOCKS string char "character" string comstr "c " string dats "data " string eoss "EOS" if (sbp > 1) # something to do { for (i = 1; i < sbp; i = i + 1) { call outtab call outdef(char, token) call outch(' ') c = sbuf(i) j = 1 for (i = i + 1; sbuf(i) != EOS; i = i + 1) { token(j) = sbuf(i) j = j + 1 } token(j) = EOS i = i + 1 call outstr(token) call outdon # call outstr(comstr) # call outstr(token) # call outch(' ') # call outch(c) # for (j = i; sbuf(j) != EOS; j = j + 1) # call outch(sbuf(j)) # call outch(c) # call outdon j = index(token, '(') if (j > 0) token(j) = EOS j = 1 repeat { if (sbuf(i) == EOS & c == '@'') break if (j == 1) { call outtab call outstr(dats) } else call outch(',') call outstr(token) if (c == '"') { call outch('(') call outnum(j) call outch(')') } call outch('/') if (sbuf(i) == EOS) { call outdef(eoss, token) call outch('/') break } else { n = esc(sbuf, i) call outnum(n) call outch('/') } j = j + 1 i = i + 1 } call outdon } sbp = 1 } return end enddef #-t- dmpdcl ascii 01/09/84 15:33 #-h- doarth ascii 01/09/84 15:33 # doarth - do arithmetic operation subroutine doarth (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer k, l, ans, first, second character op ext_func integer ctoi ext_subr pbnum, synerr k = argstk (i + 2) first = ctoi(evalst, k) l = argstk (i + 4) second = ctoi(evalst, l) op = evalst (argstk (i + 3)) if (op == '+') call pbnum (first + second) else if (op == '-') call pbnum (first - second) else if (op == '*' ) { if (evalst(argstk(i+3) + 1) == '*') { ans = 1 for ( ; second > 0; second = second - 1) ans = ans * first call pbnum(ans) } else call pbnum (first * second) } else if (op == '/' ) call pbnum (first / second) else call synerr ("arith error") return end #-t- doarth ascii 01/09/84 15:33 #-h- docode ascii 01/09/84 15:33 # docode - generate code for beginning of do subroutine docode (lab) integer lab integer labgen include COMMON_BLOCKS ext_func character gnbtok ext_subr outtab, outstr, outch, pbstr, outnum, eatup, outdon string sdo "do" xfer = NO call outtab call outstr (sdo) call outch (' ') lab = labgen (2) if (gnbtok (scrtok, MAXTOK) == DIGIT) # check for fortran DO call outstr (scrtok) else { call pbstr (scrtok) call outnum (lab) } call outch (' ') call eatup call outdon return end #-t- docode ascii 01/09/84 15:33 #-h- doif ascii 01/09/84 15:33 # doif - select one of two (macro) arguments subroutine doif (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer a2, a3, a4, a5 ext_func integer equal ext_subr pbstr 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 #-t- doif ascii 01/09/84 15:33 #-h- doincr ascii 01/09/84 15:33 # doincr - increment macro argument by 1 subroutine doincr (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer k ext_func integer ctoi ext_subr pbnum k = argstk (i + 2) call pbnum (ctoi (evalst, k) + 1) return end #-t- doincr ascii 01/09/84 15:33 #-h- dolent ascii 01/09/84 15:33 # dolent - push back length of argument subroutine dolent(argstk, i, j) integer argstk(ARGSIZE), i, j include COMMON_BLOCKS integer k ext_func integer length ext_subr pbnum k = argstk(i + 2) call pbnum(length(evalst(k))) return end #-t- dolent ascii 01/09/84 15:33 #-h- domac ascii 01/09/84 15:33 # domac - install macro definition in table subroutine domac (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer a2, a3 ext_subr entdef ifnotdef(IS_LETTER) ext_func character type enddef if (j - i > 2) { a2 = argstk (i + 2) a3 = argstk (i + 3) ifnotdef (IS_LETTER) if (type(evalst(a2)) != LETTER) elsedef if (! IS_LETTER(evalst(a2))) enddef call synerr("Illegal first argument to mdefine") else call entdef (evalst (a2), evalst (a3), deftbl) # subarrays } return end #-t- domac ascii 01/09/84 15:33 #-h- dostat ascii 01/09/84 15:33 # dostat - generate code for end of do statement subroutine dostat (lab) integer lab ext_subr outcon call outcon (lab) call outcon (lab + 1) return end #-t- dostat ascii 01/09/84 15:33 #-h- dosub ascii 01/09/84 15:33 # dosub - select macro substring subroutine dosub (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer ap, fc, k, nc ext_func integer ctoi, length ext_subr putbak 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 #-t- dosub ascii 01/09/84 15:33 #-h- dother ascii 01/09/84 15:33 # process one other string in for clause character function dother(token) character token(MAXTOK), t integer nlpar ext_func character gettok ext_subr outtab, synerr, pbstr, squash, outstr, outdon call outtab nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == ';' | (t == ',' & nlpar == 0)) break if (t == EOF) { call synerr("unexpected EOF") call pbstr(token) break } ifdef (DO_LONGNAME) if (t == ALPHA) call squash(token) enddef if (t != '@n') call outstr(token) } call outdon return(t) end #-t- dother ascii 01/09/84 15:33 #-h- eatup ascii 01/09/84 15:33 # eatup - process rest of statement; interpret continuations subroutine eatup character ptoken (MAXTOK), t, token (MAXTOK) integer nlpar ext_func character gettok ext_subr pbstr, synerr, squash, outstr nlpar = 0 repeat { t = gettok (token, MAXTOK) if (t == ';' | t == '@n') break if (t == '}' | t == '{') { call pbstr (token) break } if (t == EOF) { call synerr ("unexpected EOF") call pbstr (token) break } if (t == ',' | t == '+' | t == '-' | t == '*' | t == '(' | t == AND | t == OR | t == NOT | t == '!' | t == '~' | t == '^' | t == '=') { while (gettok (ptoken, MAXTOK) == '@n') ; call pbstr (ptoken) } if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef call outstr (token) } until (nlpar < 0) if (nlpar != 0) call synerr ("unbalanced parentheses") return end #-t- eatup ascii 01/09/84 15:33 #-h- elenth ascii 01/09/84 15:33 # calculate length of buf, taking escaped characters into account integer function elenth(buf) character buf(ARB), c integer i, n ext_func character esc n = 0 for (i=1; buf(i) != EOS; i=i+1) { c = esc(buf, i) n = n + 1 } elenth = n return end #-t- elenth ascii 01/09/84 15:33 #-h- elseif ascii 01/09/84 15:33 # elseif - generate code for end of if before else subroutine elseif (lab) integer lab ext_subr outgo, outcon call outgo (lab+1) call outcon (lab) return end #-t- elseif ascii 01/09/84 15:33 #-h- entdkw ascii 01/09/84 15:33 # entdkw --- install macro processor keywords subroutine entdkw ext_subr ulstal string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" string undefn "undefine" string linknm "linkage" string lentnm "lentok" call ulstal (defnam, DEFTYPE) call ulstal (macnam, MACTYPE) call ulstal (incnam, INCTYPE) call ulstal (subnam, SUBTYPE) call ulstal (ifnam, IFTYPE) call ulstal (arnam, ARITHTYPE) call ulstal (undefn, UNDEFTYPE) ifdef (DO_LONGNAME) call ulstal(linknm, LINKTYPE) elsedef call ulstal(linknm, DEFTYPE) enddef call ulstal(lentnm, LENTOKTYPE) return end #-t- entdkw ascii 01/09/84 15:33 #-h- entfkw ascii 01/09/84 15:33 # entfkw - place Fortran keywords in symbol table ifdef (DO_LONGNAME) subroutine entfkw include COMMON_BLOCKS integer junk ext_func integer enter # Place in the following table any long (> 6 characters) # keyword that is used by your Fortran compiler: string sconti "continue" string scompl "complex" string slogic "logical" string simpli "implicit" string sparam "parameter" string sexter "external" string sdimen "dimension" string sinteg "integer" string sequiv "equivalence" string sfunct "function" string ssubro "subroutine" string spreci "precision" junk = enter (sconti, 0, fkwtbl) junk = enter (scompl, 0, fkwtbl) junk = enter (slogic, 0, fkwtbl) junk = enter (simpli, 0, fkwtbl) junk = enter (sparam, 0, fkwtbl) junk = enter (sexter, 0, fkwtbl) junk = enter (sdimen, 0, fkwtbl) junk = enter (sinteg, 0, fkwtbl) junk = enter (sequiv, 0, fkwtbl) junk = enter (sfunct, 0, fkwtbl) junk = enter (ssubro, 0, fkwtbl) junk = enter (spreci, 0, fkwtbl) return end enddef #-t- entfkw ascii 01/09/84 15:33 #-h- entrkw ascii 01/09/84 15:33 # entrkw --- install Ratfor keywords in symbol table subroutine entrkw include COMMON_BLOCKS integer junk ext_func integer enter 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" ifdef (DO_SWITCH) string sswtch "switch" string scase "case" string sdeflt "default" enddef junk = enter (sif, LEXIF, rkwtbl) junk = enter (selse, LEXELSE, rkwtbl) junk = enter (swhile, LEXWHILE, rkwtbl) junk = enter (sdo, LEXDO, rkwtbl) junk = enter (sbreak, LEXBREAK, rkwtbl) junk = enter (snext, LEXNEXT, rkwtbl) junk = enter (sfor, LEXFOR, rkwtbl) junk = enter (srept, LEXREPEAT, rkwtbl) junk = enter (suntil, LEXUNTIL, rkwtbl) junk = enter (sret, LEXRETURN, rkwtbl) junk = enter (sstr, LEXSTRING, rkwtbl) ifdef (DO_SWITCH) junk = enter (sswtch, LEXSWITCH, rkwtbl) junk = enter (scase, LEXCASE, rkwtbl) junk = enter (sdeflt, LEXDEFAULT, rkwtbl) enddef return end #-t- entrkw ascii 01/09/84 15:33 #-h- evalr ascii 01/09/84 15:33 # evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer argno, k, m, n, t, td ext_func integer index, length ext_subr domac, doincr, dosub, doif, doarth, putbak, pbstr 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 if (td == LENTOKTYPE) call dolent (argstk, i, j) else { for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) if (evalst (k - 1) != ARGFLAG) call putbak (evalst (k)) else { argno = index (digits, evalst (k)) - 1 if (argno >= 0) # was a digit { if (argno < j - i) # user provided argument { n = i + argno + 1 m = argstk (n) call pbstr (evalst (m)) } k = k - 1 # skip over $ } else call putbak (evalst (k)) } if (k == t) # do last character call putbak (evalst (k)) } return end #-t- evalr ascii 01/09/84 15:33 #-h- fclaus ascii 01/09/84 15:33 # process for init or re-init clause subroutine fclaus character token(MAXTOK), t ext_func character gnbtok, dother ext_subr pbstr, synerr repeat { t = gnbtok(token, MAXTOK) # get rid of leading blanks call pbstr(token) # ... t = dother(token) # process single other } until (t == ';' | t == EOF) return end #-t- fclaus ascii 01/09/84 15:33 #-h- finit ascii 01/09/84 15:33 # finit - initialize for each input file subroutine finit include COMMON_BLOCKS outp = 0 # output character pointer level = 1 # file control linect (1) = 1 sbp = 1 fnamp = 2 fnames (1) = EOS bp = 0 # nothing in push back buffer fordep = 0 # for stack fcname (1) = EOS # current function name ifdef (DO_SWITCH) swtop = 0 # switch stack swlast = 1 enddef csp = 0 curcnd = C_TRUE return end #-t- finit ascii 01/09/84 15:33 #-h- forcod ascii 01/09/84 15:33 # forcod - beginning of for statement subroutine forcod (lab) integer lab include COMMON_BLOCKS character t integer i, j, nlpar, len ext_func character gettok, gnbtok ext_func integer length, labgen ext_subr outcon, synerr, pbstr, fclaus, outnum, outtab, outstr, outch ext_subr squash, outgo, baderr, scopy string ifnot "if (.not." string semi ";" lab = labgen (3) call outcon (0) if (gnbtok (scrtok, MAXTOK) != '(') { call synerr ("missing left paren") return } if (gnbtok (scrtok, MAXTOK) != ';') { # real init clause call pbstr (scrtok) call fclaus # output init clause } if (gnbtok (scrtok, MAXTOK) == ';') # empty condition call outcon (lab) else { # non-empty condition call pbstr (scrtok) call outnum (lab) call outtab call outstr (ifnot) call outch ('(') nlpar = 0 while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == ';') break if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) return } ifdef (DO_LONGNAME) if (t == ALPHA) call squash (scrtok) enddef if (t != '@n') call outstr (scrtok) } call outch (')') call outch (')') call outgo (lab+2) if (nlpar < 0) call synerr ("invalid for clause") } fordep = fordep + 1 # stack reinit clause len = 0 # total length of re-init 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 (scrtok, MAXTOK) call pbstr (scrtok) while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) break } if (nlpar >= 0 & t != '@n') { ifdef (DO_LONGNAME) if (t == ALPHA) call squash (scrtok) enddef if (j + length (scrtok) >= MAXFORSTK) call baderr ("for clause too long") call scopy (scrtok, 1, forstk, j) j = j + length (scrtok) len = len + length (scrtok) } } lab = lab + 1 # label for next's return end #-t- forcod ascii 01/09/84 15:33 #-h- fors ascii 01/09/84 15:33 # fors - process end of for statement subroutine fors (lab) integer lab include COMMON_BLOCKS integer i, j ext_func integer length ext_subr outnum, pbstr, fclaus, outgo, outcon 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 putbak (';') # push back trailing colon call pbstr (forstk (j)) # push back re-init clause call fclaus # output clause } call outgo (lab - 1) call outcon (lab + 1) fordep = fordep - 1 return end #-t- fors ascii 01/09/84 15:33 #-h- gctok ascii 01/09/84 15:33 # gctok - get next token, subject to conditionals character function gctok(token, toksiz) character token(MAXTOK) integer toksiz include COMMON_BLOCKS character temp(9) integer ctype, i, n, j, cndval(4), newcnd, value ext_func character gtok ext_func integer equal, lookup ext_subr upper, baderr, skpblk string letts "eEiI" string cndtbl "ifdef/ifnotdef/elsedef/enddef/" data cndval(1)/IFDEFTYPE/, cndval(2)/IFNOTDEFTYPE/, cndval(3)/ELSEDEFTYPE/, cndval(4)/ENDDEFTYPE/ repeat { gctok = gtok (token, toksiz) if (gctok == EOF) break ctype = NOTDEFTYPE # assume not conditional for (i = 1; letts(i) != EOS; i = i + 1) # see if correct first char if (letts(i) == token(1)) break if (letts(i) != EOS) { # YES, check further n = 1 # index into cndval for (i = 1; cndtbl(i) != EOS; i = i + 1) { for (j = 1; cndtbl(i) != '/'; j = j + 1) { temp(j) = cndtbl(i) i = i + 1 } temp(j) = EOS j = equal(token, temp) if (j == NO) { call upper(temp) j = equal(token, temp) } if (j == YES) { ctype = cndval(n) break } n = n + 1 } } if (ctype == NOTDEFTYPE) { if (curcnd == C_TRUE) break } else if (ctype == ENDDEFTYPE) { if (csp <= 0) call baderr("Illegal enddef encountered") curcnd = cndstk(csp) csp = csp - 1 } else { if (ctype == ELSEDEFTYPE) newcnd = - curcnd else { if (csp >= COND_STACK_DEPTH) call baderr("Conditionals nested too deeply") csp = csp + 1 cndstk(csp) = curcnd call skpblk if (gtok(temp, 9) != '(') call baderr("missing `(' in conditional") call skpblk if (gtok(token, toksiz) != ALPHA) call baderr("invalid conditional token") call skpblk if (gtok(temp, 9) != ')') call baderr("missing `)' in conditional") if (lookup(token, value, deftbl) == YES) newcnd = C_TRUE else newcnd = - C_TRUE if (ctype == IFNOTDEFTYPE) newcnd = - newcnd } curcnd = min (newcnd, cndstk (csp) ) } } return end #-t- gctok ascii 01/09/84 15:33 #-h- gennam ascii 01/09/84 15:33 ifdef(DO_PASS1) # gennam - generate name for string and character variables integer function gennam(root, countr, buf) character root(ARB), buf(incr(MAXIDLENGTH)), temp(4) integer countr, x, i, d, j string digits "0123456789abcdefghijklmnopqrst" x = countr countr = countr + 1 if (countr > arith(30,**,3)) countr = 1 for (i = 1; x > 0; i = i + 1) { d = mod(x, 30) + 1 temp(i) = digits(d) x = x / 30 } temp(i) = EOS j = 1 call insstr(root, buf, j, MAXIDLENGTH) for (x = 4 - i; x > 0; x = x - 1) call inschr('0', buf, j, MAXIDLENGTH) for (i = i - 1; i > 0; i = i - 1) call inschr(temp(i), buf, j, MAXIDLENGTH) call inschr('z', buf, j, MAXIDLENGTH) buf(j) = EOS return (j-1) end enddef #-t- gennam ascii 01/09/84 15:33 #-h- getdef ascii 01/09/84 15:33 # getdef (for no arguments) - get name and definition subroutine getdef (token, toksiz, defn, defsiz) character token (MAXTOK), defn (MAXDEF) integer toksiz, defsiz include COMMON_BLOCKS character c, t, ptoken (MAXTOK) integer i, nlpar ext_func character gctok, ngetch ext_subr skpblk, pbstr, baderr, putbak call skpblk c = gctok (ptoken, MAXTOK) if (c == '(') t = '(' # define (name, defn) else { t = ' ' # define name defn call pbstr (ptoken) } call skpblk if (gctok (token, toksiz) != ALPHA) call baderr ("non-alphanumeric name") call skpblk c = gctok (ptoken, MAXTOK) if (t == ' ') { # 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 == '#' | c == '@n' | c == EOF) if (c == '#') call putbak (c) } else if (t == '(') { # define (name, defn) if (c != ',') 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) == '(') nlpar = nlpar + 1 else if (defn (i) == ')') nlpar = nlpar - 1 # else normal character in defn (i) } else call baderr ("getdef is confused") defn (i - 1) = EOS return end #-t- getdef ascii 01/09/84 15:33 #-h- gettok ascii 01/09/84 15:33 # gettok - get token. handles file inclusion and line numbers character function gettok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS integer i, len character name (MAXNAME), t, tbuf(9) ext_func integer equal, open, length ext_func character deftok ext_subr skpblk, pbstr, synerr, putbak, scopy, close string fncn "function" string incl "include" ifnotdef (DO_BOOTSTRAP) for ( ; level > 0; level = level - 1) { enddef repeat { gettok = deftok(token, toksiz) if (gettok == EOF) break else if (gettok != ALPHA) return for (i = 1; i <= 9; i = i + 1) { t = token(i) tbuf(i) = t if (t == EOS) break } if (i < 8 | t != EOS) return call fold(tbuf) if (equal (tbuf, fncn) == YES) { call skpblk t = deftok (fcname, MAXNAME) call pbstr (fcname) if (t != ALPHA) call synerr ("missing function name") call putbak (' ') return } else if (equal (tbuf, incl) == NO) return # process 'include' statements: call skpblk t = deftok (name, MAXNAME) if (t == '"') { len = length (name) - 1 for (i = 1; i < len; i = i + 1) name (i) = name (i + 1) name (i) = EOS } i = length (name) + 1 ifnotdef (DO_BOOTSTRAP) if (level >= NFILES) call synerr ("includes nested too deeply") else { infile (level + 1) = open (name, READ) linect (level + 1) = 1 if (infile (level + 1) == ERR) enddef call synerr ("can't open include") ifnotdef (DO_BOOTSTRAP) else { level = level + 1 if (fnamp + i <= MAXFNAMES) { call scopy (name, 1, fnames, fnamp) fnamp = fnamp + i # push file name stack } } } enddef } ifnotdef (DO_BOOTSTRAP) 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 } } enddef token (1) = EOF # in case called more than once token (2) = EOS gettok = EOF return end #-t- gettok ascii 01/09/84 15:33 #-h- getund ascii 01/09/84 15:33 # getund - get name for undefine statement subroutine getund(token) character token(MAXTOK), temp(4) ext_func character gctok call skpblk if (gctok(token, MAXTOK) != '(') call baderr("missing `(' in undefine") call skpblk if (gctok(token, MAXTOK) != ALPHA) call baderr("non-alphanumeric name") call skpblk if (gctok(temp, 4) != ')') call baderr("missing `)' in undefine") return end #-t- getund ascii 01/09/84 15:33 #-h- gnbtok ascii 01/09/84 15:33 # gnbtok - get nonblank token character function gnbtok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS ext_func character gettok ext_subr skpblk repeat { call skpblk gnbtok = gettok (token, toksiz) } until (gnbtok != ' ') return end #-t- gnbtok ascii 01/09/84 15:33 #-h- gtok ascii 01/09/84 15:33 # gtok - get token for Ratfor character function gtok (lexstr, toksiz) character lexstr (MAXTOK) integer toksiz include COMMON_BLOCKS character c ifdef(DO_CHAR_DECL) character temp(10) enddef integer i, b, n, d ext_func character ngetch, clower, esc ext_func integer itoc, index, ctoi ifdef(DO_CHAR_DECL) ext_func integer gennam enddef ext_subr putbak, synerr, relate ifnotdef(IS_LETTER) character ctype ext_func character type enddef string digits "0123456789abcdefghijklmnopqrstuvwxyz" string alfchr ALPHA_CHARACTERS ifdef(DO_CHAR_DECL) string chroot "ch" enddef repeat # get next character, gobbling "_@n" { c = ngetch (lexstr (1)) if (c == '_') if (ngetch(c) != '@n') { call putbak(c) c = '_' break } } until (lexstr(1) != '_') if (c == ' ' | c == '@t') { lexstr (1) = ' ' while (c == ' ' | c == '@t') # compress many blanks to one c = ngetch (c) if (c == '#') while (ngetch (c) != '@n') # strip comments ; if (c != '@n') call putbak (c) else lexstr (1) = '@n' lexstr (2) = EOS gtok = lexstr (1) return } i = 1 ifdef(IS_LETTER) if (IS_LETTER(c)) { # alpha elsedef if (type(c) == LETTER) { # alpha enddef for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) ifdef(IS_LETTER) if (!IS_LETTER(c) & !IS_DIGIT(c) & index(alfchr, c) == 0) elsedef ctype = type(c) if (ctype != LETTER & ctype != DIGIT & index(alfchr, c) == 0) enddef break } call putbak (c) gtok = ALPHA } ifdef(IS_DIGIT) else if (IS_DIGIT(c)) { # digits elsedef else if (type(c) == DIGIT) { # digits enddef for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) ifdef(IS_DIGIT) if (!IS_DIGIT(c)) elsedef if (type(c) != DIGIT) enddef break } if (c == RADIX) { # n%ddd lexstr(i + 1) = EOS # terminate numeric string n = 1 b = ctoi(lexstr, n) # have base of number } 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 == '[') { # allow [ for { lexstr (1) = '{' gtok = '{' } else if (c == ']') { # allow ] for } lexstr (1) = '}' gtok = '}' } else if (c == '$') { # $( and $) now used by macro processor if (ngetch (lexstr (2)) == '(') { i = 2 gtok = LSTRIPC } else if (lexstr (2) == ')') { i = 2 gtok = RSTRIPC } else { call putbak (lexstr (2)) gtok = '$' } } else if (c == '"' | c == '@'') { # string or character constant gtok = c for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (lexstr(i) == '_') { # see if continuation if (ngetch(c) == '@n') { while (c == '@n' | c == ' ' | c == '@t') c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == '@@') { # keep @ intact if (ngetch(c) == EOF) call putbak(c) else { i = i + 1 if (i >= toksiz - 1) i = toksiz - 1 lexstr(i) = c } c = '@@' } if (c == lexstr(1)) # found terminator break if (lexstr(i) == '@n' | i >= toksiz - 1) { call synerr ("missing quote") lexstr(i) = lexstr(1) call putbak('@n') break } } if (lexstr(1) == '@'') { # character constant n = 2 c = esc(lexstr, n) if (lexstr(n + 1) != '@'') # flag old style string literal call synerr("missing apostrophe in character literal") ifdef(DO_CHAR_DECL) lexstr(n+2) = EOS call scopy(lexstr, 1, temp, 1) i = gennam(chroot, chrcnt, lexstr) call insdcl(lexstr, temp, '@'') gtok = ALPHA elsedef n = c i = itoc(n, lexstr, toksiz) # convert to characters gtok = DIGIT enddef } } else if (c == '%') { # possible literal quote if (ngetch(lexstr(2)) != '(') { # not literal quote call putbak(lexstr(2)) gtok = '%' } else { gtok = '"' lexstr(1) = LITQUOTEC for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (c == '_') { # possible continuation if (ngetch(c) == '@n') { # YES it is while (c == '@n' | c == ' ' | c == '@t') c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == '%') # are we done? if (ngetch(c) == ')') { # YES lexstr(i) = LITQUOTEC break } else call putbak(c) if (lexstr(i) == '@n' | i >= toksiz - 1) { call synerr("missing literal quote") lexstr(i) = LITQUOTEC call putbak('@n') break } } } } else if (c == LITQUOTEC) { # pushed back literal quote gtok = '"' for (i = 2; ngetch(lexstr(i)) != LITQUOTEC; i = i + 1) ; } else if (c == '#') { # strip comments while (ngetch (lexstr (1)) != '@n') ; gtok = '@n' } else if (c == '>' | c == '<' | c == NOT | c == AND | c == OR | c == '=' | c == '!' | c == '~' | c == '^') { 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 #-t- gtok ascii 01/09/84 15:33 #-h- ifcode ascii 01/09/84 15:33 # ifcode - generate initial code for if subroutine ifcode (lab) integer lab include COMMON_BLOCKS ext_func integer labgen ext_subr ifgo xfer = NO lab = labgen (2) call ifgo (lab) return end #-t- ifcode ascii 01/09/84 15:33 #-h- ifgo ascii 01/09/84 15:33 # ifgo - generate "if (.not.(...))goto lab" subroutine ifgo (lab) integer lab ext_subr outtab, outstr, balpar, outch, outgo string ifnot "if (.not." call outtab # get to column 7 call outstr (ifnot) # " if (.not. " call balpar # collect and output condition call outch (')') # " ) " call outgo (lab) # " goto lab " return end #-t- ifgo ascii 01/09/84 15:33 #-h- ifparm ascii 01/09/84 15:33 # ifparm - determines if the defined symbol has arguments in its # definition. This effects how the macro is expanded. integer function ifparm (strng) character strng (ARB) character c integer i ext_func integer index ext_func character type c = strng (1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == MACTYPE | c == LENTOKTYPE) 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 #-t- ifparm ascii 01/09/84 15:33 #-h- initkw ascii 01/09/84 15:33 # initkw - initialize tables and important global variables # this routine assumes that there is no error return from mktabl # entfkw and entrkw assume successful entry of elements in those tables, also subroutine initkw include COMMON_BLOCKS ext_func pointer mktabl ext_subr dsinit, entdkw, entrkw, entfkw call dsinit (MEMSIZE) deftbl = mktabl (1) # symbol table for definitions call entdkw rkwtbl = mktabl (1) # symbol table for Ratfor key words call entrkw ifdef (DO_LONGNAME) fkwtbl = mktabl (0) # symbol table for Fortran key words call entfkw namtbl = mktabl (1) # symbol table for long identifiers gentbl = mktabl (0) # symbol table for generated identifiers enddef label = 23000 ifdef(DO_PASS1) strcnt = 1 ifdef(DO_CHAR_DECL) chrcnt = 1 enddef enddef return end #-t- initkw ascii 01/09/84 15:33 #-h- inschr ascii 01/09/84 15:33 # inschr - put c in buf(bp) if it fits, increment bp subroutine inschr(c, buf, bp, maxsiz) integer bp, maxsiz character c, buf(ARB) ext_subr baderr if (bp > maxsiz) call baderr("buffer overflow") buf(bp) = c bp = bp + 1 return end #-t- inschr ascii 01/09/84 15:33 #-h- insdcl ascii 01/09/84 15:33 ifdef(DO_PASS1) # insdcl - insert declaration information - will be dumped by dmpdcl subroutine insdcl(name, value, c) character name(ARB), value(ARB), c character temp(10) integer strip, dosize, len, junk, first, last, i ext_func integer index, elenth, itoc, length include COMMON_BLOCKS if (value(1) == c) strip = YES else strip = NO dosize = YES # must calculate size if (index(name, '(') > 0 | c == '@'') # size specified by user or char litral dosize = NO call inschr(c, sbuf, sbp, SBUFSIZE) # store type of declaration call insstr(name, sbuf, sbp, SBUFSIZE) # variable name if (dosize == YES) # insert (len) { len = elenth(value) if (strip == YES) len = len - 2 # do not count delimiter if (c == '"') # need location for EOS len = len + 1 call inschr('(', sbuf, sbp, SBUFSIZE) junk = itoc(len, temp, 10) call insstr(temp, sbuf, sbp, SBUFSIZE) call inschr(')', sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) first = 1 last = length(value) if (strip == YES) { first = first + 1 last = last -1 } for (i = first; i <= last; i = i + 1) { call inschr(value(i), sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) return end enddef #-t- insdcl ascii 01/09/84 15:33 #-h- insstr ascii 01/09/84 15:33 # insstr - put s in buf(bp) by repeated calls to inschr subroutine insstr(s, buf, bp, maxsiz) character s(ARB), buf(ARB) integer bp, maxsiz integer i ext_subr inschr for (i = 1; s(i) != EOS; i=i+1) call inschr(s(i), buf, bp, maxsiz) return end #-t- insstr ascii 01/09/84 15:33 #-h- labelc ascii 01/09/84 15:33 # labelc - output statement number subroutine labelc (lexstr) character lexstr (ARB) include COMMON_BLOCKS ext_func integer length ext_subr synerr, outstr, outtab xfer = NO # can't suppress goto's now if (length (lexstr) == 5) # warn about 23xxx labels if (lexstr (1) == '2' & lexstr (2) == '3') call synerr ("warning: possible label conflict") call outstr (lexstr) call outtab return end #-t- labelc ascii 01/09/84 15:33 #-h- labgen ascii 01/09/84 15:33 # labgen - generate n consecutive labels, return first one integer function labgen (n) integer n include COMMON_BLOCKS labgen = label label = label + n return end #-t- labgen ascii 01/09/84 15:33 #-h- lex ascii 01/09/84 15:33 # lex - return lexical type of token integer function lex (lexstr) character lexstr (MAXTOK) include COMMON_BLOCKS ext_func character gnbtok ext_func integer lookup repeat { lex = gnbtok (lexstr, MAXTOK) if (lex != '@n') break } if (lex == EOF | lex == ';' | lex == '{' | lex == '}') return if (lex == DIGIT) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else { call scopy(lexstr, 1, scrtok, 1) call fold(scrtok) if (lookup (scrtok, lex, rkwtbl) == NO) lex = LEXOTHER } return end #-t- lex ascii 01/09/84 15:33 #-h- litral ascii 01/09/84 15:33 # litral - process literal Fortran line subroutine litral include COMMON_BLOCKS ext_func character ngetch ext_subr outdon # Finish off any left-over characters if (outp > 0) call outdon for (outp = 1; ngetch (outbuf (outp)) != '@n'; outp = outp + 1) ; outp = outp - 1 call outdon return end #-t- litral ascii 01/09/84 15:33 #-h- lndict ascii 01/09/84 15:33 # lndict - output long-name dictionary as a debugging aid ifdef (DO_LONGNAME) subroutine lndict include COMMON_BLOCKS character sym (MAXTOK) integer i pointer posn, locn ext_func character cupper ext_func integer sctabl ext_subr outch, outtab, outstr, outdon posn = 0 while (sctabl (namtbl, sym, locn, posn) != EOF) { ifdef (UPPERC) call outch('C') elsedef call outch('c') enddef call outtab for (i = cvt_to_cptr(locn); cmem (i) != EOS; i = i + 1) { ifdef (UPPERC) call outch(cupper(cmem(i))) elsedef call outch(cmem(i)) enddef } call outch (' ') call outch (' ') call outstr (sym) call outdon } return end enddef #-t- lndict ascii 01/09/84 15:33 #-h- locsym ascii 01/09/84 15:33 # locsym - locate standard definitions file ifnotdef(DO_BOOTSTRAP) subroutine locsym(file) character file(FILENAMESIZE) ifdef(NO_SUFFIX) integer loccom string path STD_PATH string suffix NO_SUFFIX enddef # NO_SUFFIX string defns STDEFNS call scopy(defns, 1, file, 1) ifdef(NO_SUFFIX) if (defns(1) != EOS) if (loccom(defns, path, suffix, file) != ASCII) { file(1) = EOS call synerr("Cannot locate standard definitions file") } enddef # NO_SUFFIX return end enddef # DO_BOOTSTRAP #-t- locsym ascii 01/09/84 15:33 #-h- lodsym ascii 01/09/84 15:33 # lodsym - load standard definitions file ifnotdef (DO_BOOTSTRAP) subroutine lodsym(fbuf) include COMMON_BLOCKS character fbuf(FILENAMESIZE) ext_func integer open ext_subr remark, parse, close call locsym(fbuf) # locate file with standard definitions if (fbuf(1) != EOS) { infile(1) = open(fbuf, READ) if (infile(1) == ERR) call remark("cannot open standard definitions file") else { call parse call close(infile(1)) } } return end enddef #-t- lodsym ascii 01/09/84 15:33 #-h- ngetch ascii 01/09/84 15:33 # ngetch - get a (possibly pushed back) character character function ngetch (c) character c include COMMON_BLOCKS ext_func character getch if (bp > 0) { c = buf(bp) bp = bp - 1 } else { c = getch(c, infile (level) ) if (c == '@n') linect (level) = linect (level) + 1 } return (c) end #-t- ngetch ascii 01/09/84 15:33 #-h- otherc ascii 01/09/84 15:33 # otherc - output ordinary Fortran statement subroutine otherc (lexstr) character lexstr (ARB) include COMMON_BLOCKS ext_subr outtab, squash, outstr, eatup, outdon ifnotdef(IS_LETTER) ext_func character type enddef xfer = NO call outtab ifdef (DO_LONGNAME) ifdef (IS_LETTER) if (IS_LETTER(lexstr (1))) elsedef if (type (lexstr(1)) == LETTER) enddef # IS_LETTER call squash (lexstr) enddef # DO_LONGNAME call outstr (lexstr) call eatup call outdon return end #-t- otherc ascii 01/09/84 15:33 #-h- outch ascii 01/09/84 15:33 # outch - put one character into output buffer subroutine outch (c) character c include COMMON_BLOCKS ext_subr outdon if (outp >= 72) # continuation needed call contln outp = outp + 1 outbuf (outp) = c return end #-t- outch ascii 01/09/84 15:33 #-h- outcon ascii 01/09/84 15:33 # outcon - output "n continue" subroutine outcon (n) integer n include COMMON_BLOCKS ext_subr outnum, outtab, outstr, outdon 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 #-t- outcon ascii 01/09/84 15:33 #-h- outdef ascii 01/09/84 15:33 # output defined value of string `str' subroutine outdef(str, tok) character str(ARB), tok(MAXTOK), t ext_func character gnbtok call putbak('/') # push back delimiter call pbstr(str) # push back string repeat { t = gnbtok(tok, MAXTOK) if (t == '/') break call outstr(tok) } return end #-t- outdef ascii 01/09/84 15:33 #-h- outdon ascii 01/09/84 15:33 # outdon - finish off an output line subroutine outdon include COMMON_BLOCKS ext_subr putlin outbuf (outp + 1) = '@n' outbuf (outp + 2) = EOS call putlin (outbuf, STDOUT) outp = 0 return end #-t- outdon ascii 01/09/84 15:33 #-h- outgo ascii 01/09/84 15:33 # outgo - output "goto n" subroutine outgo (n) integer n include COMMON_BLOCKS ext_subr outtab, outstr, outnum, outdon string sgoto "goto " if (xfer == YES) return call outtab call outstr (sgoto) call outnum (n) call outdon return end #-t- outgo ascii 01/09/84 15:33 #-h- outnum ascii 01/09/84 15:33 # outnum - output decimal number subroutine outnum (n) integer n character chars (MAXCHARS) integer i, m ext_subr outch m = iabs (n) i = 0 repeat { i = i + 1 chars (i) = mod (m, 10) + '0' m = m / 10 } until (m == 0 | i >= MAXCHARS) if (n < 0) call outch ('-') for ( ; i > 0; i = i - 1) call outch (chars (i)) return end #-t- outnum ascii 01/09/84 15:33 #-h- outstr ascii 01/09/84 15:33 # outstr - output string; handles quoted literals subroutine outstr (str) character str (ARB) ifdef(DO_PASS1) character varbuf(incr(MAXIDLENGTH)) enddef integer i, n include COMMON_BLOCKS ext_func integer qstfix ifdef(DO_PASS1) ext_func integer gennam enddef ext_subr outch, outnum, strout ifdef(DO_PASS1) string stroot "st" enddef if (str(1) == LITQUOTEC) # literal quoted string for (i = 2; str(i) != LITQUOTEC; i = i + 1) call outch(str(i)) else if (str(1) != '"') # not a quoted string call strout(str, YES) # output string, uppercase if defined else { n = qstfix(str) ifdef (DO_PASS1) # output declaration and data stmts i = gennam(stroot, strcnt, varbuf) call insdcl(varbuf, str, '"') call strout(varbuf, YES) enddef ifdef (DO_F77_STRINGS) # output F77 string call outch('@'') call strout(str, NO) call outch('@'') enddef ifdef (DO_HOLLERITH) # output Hollerith string call outnum(n) call outch('H') call strout(str, NO) enddef } return end #-t- outstr ascii 01/09/84 15:33 #-h- outtab ascii 01/09/84 15:33 # outtab - get past column 6 subroutine outtab include COMMON_BLOCKS ext_subr outch while (outp < 6) call outch (' ') return end #-t- outtab ascii 01/09/84 15:33 #-h- parse ascii 01/09/84 15:33 # parse - parse Ratfor source program subroutine parse include COMMON_BLOCKS character lexstr (MAXTOK) integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i ext_func integer lex ext_subr finit, ifcode, docode, whilec, forcod, repcod, swcode, synerr ext_subr cascod, labelc, elseif, litral, baderr, swend , otherc, brknxt ext_subr retcod, strdcl, pbstr, unstak call finit sp = 1 lextyp (1) = EOF repeat { ifdef(DO_PASS1) if (sbp > 1) # accumulated declarations? call dmpdcl(lexstr) # output them enddef token = lex (lexstr) if (token == EOF) break if (token == LEXIF) call ifcode (lab) else if (token == LEXDO) call docode (lab) else if (token == LEXWHILE) call whilec (lab) else if (token == LEXFOR) call forcod (lab) else if (token == LEXREPEAT) call repcod (lab) ifdef (DO_SWITCH) else if (token == LEXSWITCH) call swcode (lab) else if (token == LEXCASE | token == 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) } enddef else if (token == LEXDIGITS) call labelc (lexstr) else if (token == LEXELSE) { if (lextyp (sp) == LEXIF) call elseif (labval (sp)) else call synerr ("illegal else") } else if (token == LEXLITERAL) call litral if (token == LEXIF | token == LEXELSE | token == LEXWHILE | token == LEXFOR | token == LEXREPEAT ifdef (DO_SWITCH) | token == LEXSWITCH enddef | token == LEXDO | token == LEXDIGITS | token == '{') { 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 == '}') { if (lextyp (sp) == '{') sp = sp - 1 ifdef (DO_SWITCH) else if (lextyp (sp) == LEXSWITCH) { call swend (labval (sp)) sp = sp - 1 } enddef else call synerr ("illegal right brace") } else if (token == LEXOTHER) call otherc (lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt (sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod else if (token == LEXSTRING) call strdcl token = lex (lexstr) # peek at next token call pbstr (lexstr) call unstak (sp, lextyp, labval, token) if (token == EOF) break } } if (sp != 1) call synerr ("unexpected EOF") if (csp > 0) call synerr("conditional processing still active at EOF") ifdef(DO_PASS1) if (sbp > 1) # accumulated declarations? call synerr("Accumulated declarations at EOF") enddef return end #-t- parse ascii 01/09/84 15:33 #-h- pbnum ascii 01/09/84 15:33 # pbnum - convert number to string, push back on input subroutine pbnum (n) integer n integer m, num ext_subr putbak string digits "0123456789" num = abs(n) repeat { m = mod (num, 10) call putbak (digits (m + 1)) num = num / 10 } until (num == 0) if (n < 0) call putbak('-') return end #-t- pbnum ascii 01/09/84 15:33 #-h- pbstr ascii 01/09/84 15:33 # pbstr - push string back onto input subroutine pbstr (in) character in (ARB) integer i ext_func integer length ext_subr putbak for (i = length (in); i > 0; i = i - 1) call putbak (in (i)) return end #-t- pbstr ascii 01/09/84 15:33 #-h- push ascii 01/09/84 15:33 # push - push ep onto argstk, return new pointer ap integer function push (ep, argstk, ap) integer ap, argstk (ARGSIZE), ep ext_subr baderr if (ap > ARGSIZE) call baderr ("arg stack overflow") argstk (ap) = ep push = ap + 1 return end #-t- push ascii 01/09/84 15:33 #-h- putbak ascii 01/09/84 15:33 # putbak - push character back onto input subroutine putbak (c) character c include COMMON_BLOCKS ext_subr baderr if (bp >= BUFSIZE) call baderr ("too many characters pushed back") else { bp = bp + 1 buf (bp) = c } return end #-t- putbak ascii 01/09/84 15:33 #-h- putchr ascii 01/09/84 15:33 # putchr - put single char into eval stack subroutine putchr (c) character c include COMMON_BLOCKS ext_subr baderr if (ep > EVALSIZE) call baderr ("evaluation stack overflow") evalst (ep) = c ep = ep + 1 return end #-t- putchr ascii 01/09/84 15:33 #-h- puttok ascii 01/09/84 15:33 # puttok-put token into eval stack subroutine puttok (str) character str (MAXTOK) integer i ext_subr putchr for (i = 1; str (i) != EOS; i = i + 1) call putchr (str (i)) return end #-t- puttok ascii 01/09/84 15:33 #-h- qstfix ascii 01/09/84 15:33 # qstfix - fix quoted string # collapses quoted string in the same array, removing first and last quotes # and converting intermediate @" ==> " # returns the length of the string as its value integer function qstfix(str) character str(ARB) integer last, n, i integer length last = length(str) n = 1 for (i = 2; i < last; i = i + 1) { ifnotdef(DO_PASS1) # convert @" -> " and @@ -> @ if (str(i) == '@@') { i = i + 1 if (str(i) != '"' & str(i) != '@@') { str(n) = '@@' n = n + 1 } } enddef str(n) = str(i) # copy character n = n + 1 } str(n) = EOS return(n-1) end #-t- qstfix ascii 01/09/84 15:33 #-h- ratarg ascii 01/09/84 15:33 # ratarg - routine to crack command line flags to ratfor ifnotdef(DO_BOOTSTRAP) subroutine ratarg integer i ext_func integer getarg include COMMON_BLOCKS dosym = YES # load "symbols" by default for (i = 1; getarg(i, scrtok, MAXTOK) != EOF; i = i + 1) if (scrtok(1) == '-' & scrtok(2) != EOS) # found a flag if (scrtok(2) == 'n' | scrtok(2) == 'N') # user does not want ratdef dosym = NO return end enddef #-t- ratarg ascii 01/09/84 15:33 #-h- relate ascii 01/09/84 15:33 # relate - convert relational shorthands into long form subroutine relate (token, last) character token (ARB) integer last ext_func character ngetch ext_func integer length ext_subr putbak if (ngetch (token (2)) != '=') { call putbak (token (2)) token (3) = 't' } else token (3) = 'e' token (4) = '.' token (5) = EOS token (6) = EOS # for .not. and .and. if (token (1) == '>') token (2) = 'g' else if (token (1) == '<') token (2) = 'l' else if (token (1) == NOT | token(1) == '!' | token(1) == '~' | token(1) == '^') { if (token (2) != '=') { token (3) = 'o' token (4) = 't' token (5) = '.' } token (2) = 'n' } else if (token (1) == '=') { if (token (2) != '=') { token (2) = EOS last = 1 return } token (2) = 'e' token (3) = 'q' } else if (token (1) == AND) { token (2) = 'a' token (3) = 'n' token (4) = 'd' token (5) = '.' } else if (token (1) == OR) { token (2) = 'o' token (3) = 'r' } else # can't happen token (2) = EOS token (1) = '.' last = length (token) return end #-t- relate ascii 01/09/84 15:33 #-h- repcod ascii 01/09/84 15:33 # repcod - generate code for beginning of repeat subroutine repcod (lab) integer lab ext_func integer labgen ext_subr outcon call outcon (0) # in case there was a label lab = labgen (3) call outcon (lab) lab = lab + 1 # label to go on next's return end #-t- repcod ascii 01/09/84 15:33 #-h- retcod ascii 01/09/84 15:33 # retcod - generate code for return subroutine retcod include COMMON_BLOCKS character t ext_func character gnbtok ext_subr pbstr, outtab, scopy, squash, outstr, outch, eatup, outdon string sret "return" t = gnbtok (scrtok, MAXTOK) if (t != '@n' & t != ';' & t != '}') { call pbstr (scrtok) if ( fcname(1) == EOS ) { # we are in a subroutine call synerr("can't give 'return' an argument from a subroutine") call eatup return } call outtab call scopy (fcname, 1, scrtok, 1) ifdef (DO_LONGNAME) call squash (scrtok) enddef call outstr (scrtok) call outch ('=') call eatup call outdon } else if (t == '}') call pbstr (scrtok) call outtab call outstr (sret) call outdon xfer = YES return end #-t- retcod ascii 01/09/84 15:33 #-h- skpblk ascii 01/09/84 15:33 # skpblk - skip blanks and tabs in current input file subroutine skpblk include COMMON_BLOCKS character c ext_func character ngetch ext_subr putbak repeat c = ngetch (c) until (c != ' ' & c != '@t') call putbak (c) return end #-t- skpblk ascii 01/09/84 15:33 #-h- squash ascii 01/09/84 15:33 # squash - convert a long or special identifier into a Fortran variable ifdef (DO_LONGNAME) subroutine squash (id) character id (MAXTOK) include COMMON_BLOCKS integer junk, i, j character newid (MAXTOK), lowcid (MAXTOK), recdid(incr(MAXIDLENGTH)) ext_func integer lookup ext_subr scopy, uniqid, entdef ifnotdef(IS_LETTER) character ctype ext_func character type enddef j = 1 for (i = 1; id (i) != EOS; i = i + 1) { lowcid(i) = id(i) ifdef(IS_LETTER) if (IS_LETTER(id (i)) | IS_DIGIT(id (i))) { elsedef ctype = type(id(i)) if (ctype == LETTER | ctype == DIGIT) { enddef newid (j) = id (i) j = j + 1 } } lowcid(i) = EOS newid (j) = EOS if (i < incr(MAXIDLENGTH) & i == j) return # an ordinary (short) Fortran variable if (i == incr(MAXIDLENGTH) & i == j) if (id (MAXIDLENGTH) != FILLCHAR) return # a 6-character variable, but no possible conflict # Otherwise, the identifier (1) is longer than Fortran allows, # (2) contains special characters (_ or .), or (3) is exactly # MAXIDLENGTH characters long and ends with the "fill character." # The first two cases obviously call for name conversion; the last # case requires conversion to avoid accidental conflicts with # automatically generated names. call fold(lowcid) # convert to lower case if (lookup (lowcid, junk, fkwtbl) == YES) # Fortran key word? return # (must be treated as reserved) if (ludef (lowcid, recdid, namtbl) == YES) { # have we seen this before? call scopy(recdid, 1, id, 1) return } call fold (newid) # all lower case call uniqid (newid) # get an identifier never before seen call entdef (lowcid, newid, namtbl) # record it for posterity call scopy(newid, 1, id, 1) # and substitute it for the old one return end enddef #-t- squash ascii 01/09/84 15:33 #-h- strdcl ascii 01/09/84 15:33 # strdcl - generate code for string declaration subroutine strdcl include COMMON_BLOCKS character t, dchar (MAXTOK) integer i, j, k, n, len ext_func character gnbtok, esc ext_func integer length, ctoi, lex, elenth ext_subr synerr, squash, outtab, pbstr, outstr, outch, insstr, inschr ext_subr outnum, outdon string char "character" string dat "data " string eoss "EOS" t = gnbtok (scrtok, MAXTOK) if (t != ALPHA) call synerr ("missing string token") ifdef (DO_LONGNAME) call squash (scrtok) enddef ifdef(DO_PASS1) if (gnbtok(dchar, MAXTOK) == '(') # user-specified size { call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != DIGIT) call synerr("invalid string size") call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != ')') call synerr("missing right paren") call concat(scrtok, dchar, scrtok) t = gnbtok(dchar, MAXTOK) } call insdcl(scrtok, dchar, '"') elsedef call outtab call outdef(char, dchar) # output defined meaning of "character" call outch (' ') # separator in declaration call outstr (scrtok) call insstr (scrtok, sbuf, sbp, SBUFSIZE) # save for later call inschr (EOS, sbuf, sbp, SBUFSIZE) if (gnbtok (scrtok, MAXTOK) != '(') { # make size same as initial value len = elenth (scrtok) + 1 if (scrtok (1) == '"') len = len - 2 } else { # form is string name (size) init t = gnbtok (scrtok, MAXTOK) i = 1 len = ctoi (scrtok, i) if (scrtok (i) != EOS) call synerr ("invalid string size") if (gnbtok (scrtok, MAXTOK) != ')') call synerr ("missing right paren") else t = gnbtok (scrtok, MAXTOK) } call outch ('(') call outnum (len) call outch (')') call outdon if (scrtok (1) == '"') { len = length (scrtok) scrtok (len) = EOS call insstr (scrtok (2), sbuf, sbp, SBUFSIZE) } else call insstr (scrtok, sbuf, sbp, SBUFSIZE) call inschr (EOS, sbuf, sbp, SBUFSIZE) t = lex (scrtok) # peek at next scrtok call pbstr (scrtok) 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 (',') call outstr (sbuf (i)) call outch ('(') call outnum (k) call outch (')') call outch ('/') if (sbuf (j) == EOS) break n = esc (sbuf, j) call outnum (n) call outch ('/') k = k + 1 } call outdef(eoss, scrtok) # use defined meaning of "EOS" call outch('/') call outdon } sbp = 1 } enddef return end #-t- strdcl ascii 01/09/84 15:33 #-h- strout ascii 01/09/84 15:33 # strout - output character array, upper-casing if desired subroutine strout(str, ifup) character str(ARB), c integer ifup, i ext_func character cupper ext_func integer length include COMMON_BLOCKS if ( (length(str) + outp) > 72 ) # don't split keywords call contln for (i = 1; str(i) != EOS; i = i + 1) { c = str(i) ifdef (UPPERC) if (ifup == YES) c = cupper(c) enddef # UPPERC call outch(c) } return end #-t- strout ascii 01/09/84 15:33 #-h- swcode ascii 01/09/84 15:33 # swcode - generate code for beginning of switch statement ifdef (DO_SWITCH) subroutine swcode (lab) integer lab include COMMON_BLOCKS ext_func integer labgen, gnbtok ext_subr baderr, outtab, swvar , outch, balpar, outdon, outgo, synerr, pbstr ifdef (DO_PASS1) string intstr "integer" enddef lab = labgen (2) 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 (lab) call outch ('=') call balpar call outdon ifdef (DO_PASS1) call outtab # Integer Innn call outstr (intstr) call outch (' ') call swvar (lab) call outdon enddef call outgo (lab) # goto L xfer = YES while (gnbtok (scrtok, MAXTOK) == '@n') ; if (scrtok (1) != '{') { call synerr ("missing left brace in switch statement") call pbstr (scrtok) } return end enddef #-t- swcode ascii 01/09/84 15:33 #-h- swend ascii 01/09/84 15:33 # swend - finish off switch statement; generate dispatch code ifdef (DO_SWITCH) subroutine swend (lab) integer lab include COMMON_BLOCKS integer lb, ub, n, i, j ext_subr outgo, outcon, outtab, swvar , outch, outnum, outdon 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." 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 outcon (lab) # L continue if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table if (lb != 1) { # L Innn=Innn-lb+1 call outtab call swvar (lab) call outch ('=') call swvar (lab) if (lb < 1) call outch ('+') call outnum (-lb + 1) call outdon } call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr (sif) call swvar (lab) call outstr (slt) call swvar (lab) call outstr (sgt) call outnum (ub - lb + 1) call outch (')') 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 (',') } 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 (',') } call outch (')') call outch (',') call swvar (lab) 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 (lab) 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 (lab) call outstr (sle) call outnum (swstak (i + 1)) } call outch (')') # ) goto ... call outgo (swstak (i + 2)) } if (lab + 1 != swstak (swtop + 2)) call outgo (swstak (swtop + 2)) } call outcon (lab + 1) # L+1 continue swlast = swtop # pop switch stack swtop = swstak (swtop) return end enddef #-t- swend ascii 01/09/84 15:33 #-h- swvar ascii 01/09/84 15:33 # swvar - output switch variable Innn, where nnn = lab ifdef (DO_SWITCH) subroutine swvar (lab) integer lab ext_subr outch, outnum call outch ('I') call outnum (lab) return end enddef #-t- swvar ascii 01/09/84 15:33 #-h- synerr ascii 01/09/84 15:33 # synerr --- report non-fatal error subroutine synerr (msg) character msg (ARB) include COMMON_BLOCKS character lc (MAXCHARS) integer i, junk ext_func integer itoc ext_subr putlin, putch, remark string in " in " string errmsg "error at line " if (curcnd != C_TRUE) # avoid error messages in non-preprocessed code return 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) { # print file name call putlin (in, ERROUT) call putlin (fnames (i), ERROUT) break } call putch (':', ERROUT) call putch (' ', ERROUT) call remark (msg) return end #-t- synerr ascii 01/09/84 15:33 #-h- ulstal ascii 01/09/84 15:33 # ulstal - install lower and upper case versions of symbol subroutine ulstal (name, val) character name (ARB), defn (2), val include COMMON_BLOCKS ext_subr entdef, upper defn (1) = val defn (2) = EOS call entdef (name, defn, deftbl) call upper (name) call entdef (name, defn, deftbl) return end #-t- ulstal ascii 01/09/84 15:33 #-h- uniqid ascii 01/09/84 15:33 # uniqid - convert an identifier to one never before seen ifdef (DO_LONGNAME) subroutine uniqid (id) character id (MAXTOK) include COMMON_BLOCKS integer i, j, junk, idchl, carry character start (MAXIDLENGTH) ext_func integer lookup, index, length, enter ext_subr baderr, synerr 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 = arith(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) } # At this point, 'id' contains a unique identifier, not previously # seen in this compilation. Save it for future reference. if (enter (id, 0, gentbl) == ERR) call synerr("No room for generated variable name") return end enddef #-t- uniqid ascii 01/09/84 15:33 #-h- unstak ascii 01/09/84 15:33 # unstak - unstack at end of statement subroutine unstak (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token ext_subr outcon, dostat, whiles, fors, untils for ( ; sp > 1; sp = sp - 1) { if (lextyp (sp) == '{') break ifdef (DO_SWITCH) if (lextyp (sp) == LEXSWITCH) break enddef if (lextyp (sp) == LEXIF & token == LEXELSE) break if (lextyp (sp) == LEXIF) call outcon (labval (sp)) else if (lextyp (sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon (labval (sp) + 1) } else if (lextyp (sp) == LEXDO) call dostat (labval (sp)) else if (lextyp (sp) == LEXWHILE) call whiles (labval (sp)) else if (lextyp (sp) == LEXFOR) call fors (labval (sp)) else if (lextyp (sp) == LEXREPEAT) call untils (labval (sp), token) } return end #-t- unstak ascii 01/09/84 15:33 #-h- untils ascii 01/09/84 15:33 # untils - generate code for until or end of repeat subroutine untils (lab, token) integer lab, token include COMMON_BLOCKS character ptoken (MAXTOK) integer junk ext_func integer lex ext_subr outnum, ifgo, outgo, outcon xfer = NO call outnum (lab) if (token == LEXUNTIL) { junk = lex (ptoken) call ifgo (lab - 1) } else call outgo (lab - 1) call outcon (lab + 1) return end #-t- untils ascii 01/09/84 15:33 #-h- whilec ascii 01/09/84 15:33 # whilec - generate code for beginning of while subroutine whilec (lab) integer lab ext_func integer labgen ext_subr outcon, outnum, ifgo call outcon (0) # unlabeled continue, in case there was a label lab = labgen (2) call outnum (lab) call ifgo (lab + 1) return end #-t- whilec ascii 01/09/84 15:33 #-h- whiles ascii 01/09/84 15:33 # whiles - generate code for end of while subroutine whiles (lab) integer lab ext_subr outgo, outcon call outgo (lab) call outcon (lab + 1) return end #-t- whiles ascii 01/09/84 15:33 #-t- ratfor ascii 01/09/84 15:35 #-h- ratfordoc ascii 01/09/84 15:35 .de hd .pl 60 .bp .in 4 .rm 72 .he '$1 $2'$3 $4 $5 $6 $7 $8'$1 $2' .fo ''-#-'' .fi .in 8 .ti -4 NAME .br $1 - .en .de sy .sp 1 .ti -4 SYNOPSIS .br .nf .en .de ds .fi .sp .ti -4 DESCRIPTION .br .en .de fu .fi .sp 1 .ti -4 FUNCTION .br .en .de di .fi .sp .ti -4 DIAGNOSTICS .br .en .de re .fi .sp .ti -4 RETURNS .br .en .de fl .fi .sp .ti -4 FILES .br .en .de ex .fi .sp .ti -4 EXAMPLES .nf .br .en .de im .fi .sp .ti -4 IMPLEMENTATION .br .en .de sa .fi .sp .ti -4 SEE ALSO .br .en .de am .fi .sp .ti -4 ARGUMENTS MODIFIED .br .en .de ca .fi .sp .ti -4 CALLS .br .en .de bu .fi .sp .ti -4 BUGS/DEFICIENCIES .br .en .de au .fi .sp .ti -4 AUTHORS .br .en .hd Ratfor (1) 21-Dec-81 RatFor preprocessor .sy ratp1 [-n] [file] ... | ratp2 >outfile .sp ratfor [-n] [file] ... >outfile .sp rat77 [-n] [file] ... >outfile .ds Ratfor translates the ratfor programs in the named files into Fortran. If no input files are given, or the filename '-' appears, the standard input will be read. Unless the '-n' flag has been specified, a file containing general purpose software tools definitions (e.g. EOF, EOS, etc.) will be automatically opened and processed before any of the files specified are read. .sp 2 Syntax: Ratfor has the following syntax: .nf prog: stmt prog stmt stmt: if (expr) stmt if (expr) stmt else stmt while (expr) stmt repeat stmt repeat stmt until (expr) for (init clause; test expr; incr clause) stmt do expr stmt do n expr stmt break break n next next n return (expr) switch (expr) { case expr: stmt ... default: stmt } digits stmt { prog } or [ prog ] other other: anything unrecognizable (i.e. fortran) clause: other clause, other .fi where 'stmt' is any Fortran or Ratfor statement. A statement is terminated by an end-of-line or a semicolon. .sp .ne 13 Character Translation: .sp The following character translations are performed: .in +5 .nf < .lt. <= .le. == .eq. != .ne. ^= .ne. ~= .ne. >= .ge. > .gt. | .or. & .and. ! .not. ^ .not. ~ .not. .in -5 .fi .sp 2 Included files: .fi The statement .in +15 .nf include file or include "file" .in -15 .fi will insert the contents of the specified file into the ratfor input in place of the 'include' statement. Quotes must surround the file name if it contains characters other than alphanumerics or underscores. .sp 2 Macro Definitions: The statement .ti +15 define(name,replacement text) defines 'name' as a macro which will be replaced with the indicated text when encountered in the source files. Any occurrences of the strings '$n' in the replacement text, where 1 <= n <= 9, will be replaced with the nth argument when the macro is actually invoked. For example: .ti +15 define(bump, $1 = $1 + 1) will cause the source line .ti +15 bump(i) to be expanded into .ti +15 i = i + 1 The names of macros may contain letters, digits and underline characters, but must start with a letter. Upper case is not equivalent to lower case in macro names. The replacement text is copied directly into the lookup table with no intepretation of the arguments, which differs from the procedure used in the macro utility. This "deferred evaluation" has the effect of eliminating the need for bracketing strings to get them through the macro processor unchanged. A side effect of the deferred evaluation is that defined names cannot be forced through the processor - i.e. the string "define" will never be output from the preprocessor. The inequivalence of upper and lower case in macro names may be used in this case to force the name of a user defined macro onto the output - i.e. if the user has defined a macro named mymac, the replacement text may contain the string MYMAC, which is not defined, and will pass through the processor. (For compatibility, an "mdefine" macro call has been included which interprets definitions before stacking them, as does the macro tool. When using this version, use "$(" and "$)" to indicate deferred evaluation, rather than the "[" and "]" used by the macro tool.) In addition to define, several other built-in macros are provided: .in +17 .ti -16 arith(x,op,y) performs the "integer" arithmetic specified by op (+,-,*,/,**) on the two numeric operands and returns the result as its replacement. .ti -16 incr(x) converts the string x to a number, adds one to it, and returns the value as its replacement (as a character string). .ti -16 ifelse(a,b,c,d) compares a and b as character strings; if they are the same, c is pushed back onto the input, else d is pushed back. .ti -16 substr(s,m,n) produces the substring of s which starts at position m (with origin one), of length n. If n is omitted or too big, the rest of the string is used, while if m is out of range the result is a null string. .ti -16 lentok(str) pushes the length of the argument (# of characters) onto the input as a character string. .ti -16 undefine(sym) removes the definition for the symbol `sym', if it is defined. .in -17 Note: the statement .ti +15 define name text may also be used, but will not always perform correctly for macros with parameters or multi-line replacement text. The functional form is preferred. .ne 9 Conditional Preprocessing: The statements .in +10 .nf ifdef(macro) ifnotdef(macro) .in +6 .cc * . . . . . . *ti -6 elsedef elsedef . . . . . . *cc . .in -6 enddef enddef .in -10 .fi conditionalize the preprocessing upon whether the macro has been previously defined or not. The `elsedef' portions of the conditionals may be omitted, if desired. The conditional bodies may be nested, up to 10 levels deep. .br String Declarations: The statements .in +10 string name "character string" or .br string name(size) "character string" .in -10 declare 'name' to be a character array long enough to accomodate the ascii codes for the given character string, one per array element. The array is then filled by data statements. The last word of 'name' is initialized to the symbolic parameter EOS, and indicates the end of a string. EOS must be defined either in the standard definitions file or by the user. If a size is given, name is declared to be a character array of 'size' elements. The normal escape sequences are supported in strings; in addition, to embed a quote (") in the string, one must type @". .ne 5 .sp 2 String Literals: The processing of in-line quoted strings ("..." appearing outside of the scope of a `string' declaration) is dependent upon which version of the processor you are using: .sp .in +7 .ti -7 ratfor "str" is converted to 3Hstr. This action is identical to previous versions of the pre-processor. .sp .ti -6 ratp1 "str" is converted to an appropriate declaration for a `character' array, and the appropriate data statements are output. The variable name will be of the form STNNNZ, where NNN is replaced by a rotating sequence number. The array will be declared long enough to place the value of EOS in the last element, just as for the `string' declaration. Since these declarations are output immediately, the resulting FORTRAN code must be run through the program `ratp2', which will reorder the code to be ANSI-66 compliant. .sp .ti -6 rat77 "str" is converted to the FORTRAN-77 constant 'str'. It is expected that this version of the preprocessor will NOT automatically load the standard symbols file, thus permitting the use of `rat77' to preprocess F77 code. .sp .in -7 Regardless of the version used, string literals can be continued across line boundaries by ending the line to be continued with an underline. The underline is not included as part of the literal. Leading blanks and tabs on the next line are ignored. If a quote (") is to be embedded in the string, it must be escaped, as in .sp .ce "a quote (@") in a string" .sp In addition, the normal escape sequences are supported in the `ratp1' version. .sp 2 Character Literals: Character constants of the form 'c' are converted to the decimal integer representation of that character in the ASCII character set. For example: .in +5 .nf call putc('!') .ti -5 would become call putc(33) .in -5 .fi .sp The normal escape characters are supported as character constants. For example .sp .ti +5 '@n' .sp is a NEWLINE (10). .sp Note that this capability pre-empts the use of apostrophes for delimiting string literals. Attempts to pre-process programs utilitizing apostrophes for string literals will generate syntax errors of the form: .sp .ce missing apostrophe in character literal .sp An utility `ratfix' is available for quickly correcting such code. .sp 2 Integer Constants: Integer constants in bases other than decimal may be specified as n%dddd... where 'n' is a decimal number indicating the base and 'dddd...' are digits in that base. For bases > 10, letters are used for digits above 9. Examples include: 8%77 (=63), 16%2ff (=767), 2%0010011 (=19). The number is converted to the equivalent decimal value using multiplication; this may cause sign problems if the number has too many digits. .sp 2 Lines and Continuation: .fi Input is free-format; that is, statements may appear anywhere on a line, and the end of the line is generally considered the end of the statement. However, lines ending in special characters such as comma, +, -, and * are assumed to be continued on the next line. An exception to this rule is within a condition; the line is assumed to be continued if the condition does not fit on one line. Explicit continuation is indicated by ending a line with an underline character (_). The underline character is not copied to the output file. .sp 2 Comments: Comments are preceded by '#' signs and may appear anywhere in the code. .sp 2 Literal (unprocessed) Lines: Lines can be passed through ratfor without being processed by putting a percent "%" as the first character on the line. The percent will be removed and the line shifted one position to the left, but otherwise will be output without change. Macro invocations, long names, etc., appearing in the line will not be processed. .sp 2 Literal (unprocessed) Character Sequences: Sequences of characters can be passed through the processor, thus avoiding processing, by surrounding then with the tokens %(...%). The surrounding %[()] tokens will be removed and the character sequence will be output without change. Macro invocations, long names, etc. appearing in the character sequence will NOT be processed. .sp 2 Long Variable Name Processing: .sp An optional capability available in the pre-processor, which may be enabled by your local tools support individual, is the capability of converting long variable names (those consisting of more than 6 alpha-numerics, embedded underscores, or both) to 6 character ANSI-66 compliant variable names. If this option is available, and has been used in a pre-processing run, a sequence of FORTRAN comment statements are output at the end of the generated FORTRAN code, with the mapping of long names to generated names. .sp It should be noted that this mapping is not deterministic across separate compilations; as such, if `get_next_input' is compiled and placed in a library, source invocations of `get_next_input' would not map into the identical 6-character name. To permit users to preload the long name table with the names of external routines, the `linkage' statement may be used: .sp .ce linkage long_name external_name .sp The pair of names is entered into the table of known long variable names, preventing any generated names for local long variables from colliding with the external name. The programmer must provide accurate information via this statement to permit access to routines with "long variable names" across compilations. .sp If long variable name processing has not been enabled for your site, linkage is synonymous with define. .sp NOTE: since long variable name processing is optional, its use will generate code that is inherently non-portable to sites not desiring this capability. Users wishing to write portable code should avoid long variable names. .sp 4 .ne 4 .ti -4 CHANGES .br This ratfor preprocessor differs from the original (as released by Kernighan and Plauger) in the following ways: The code has been rewritten and reorganized. Hash tables have been added for increased efficiency in searching for macro definitions and Ratfor keywords. The 'string' declaration has been included. The define processor has been augmented to support macros with arguments. Conditional preprocessing upon the definition (or lack therof) of a symbol has been included. Many extraneous gotos have been avoided. Blanks have been included in the output for increased readability. Multi-level 'break' and 'next' statements have been included. The Fortran 'DO' is allowed, as well as the ratfor one. The capability of specifying integer constants in bases other than decimal has been added. Underscores have been allowed in names. The 'define' syntax has been expanded to include the form: define name value The 'return(value)' feature has been added. Quoted file names following 'include' statements have been added to allow for special characters in file names. A method for allowing lines to pass through un-processed has been added. The 'switch' control statement has been included. Continuation lines have been implemented. Brackets have been allowed to replace braces (but NOT '$(' and '$)' ) Character constants are now supported. Groups of FORTRAN statements are permitted in the init and re-init clauses of the for statement. A method for allowing character sequences to pass through un-processed has been added. An `undefine' command has been added to permit removal of symbol definitions. Three types of literal character string processing are now possible. The default action permanently eliminates the usage of Hollerith constants in portable tools. Long variable names processing can now be enabled as a site-dependent option. .fl A generalized definition file (e.g. 'ratdef') is automatically opened and read. .sa .nf Kernighan and Plauger's "Software Tools" Kernighan's "RATFOR - A Preprocessor for a Rational Fortran" The Unix command rc in the Unix Manual The tools 'incl' and 'macro' .fi .di (The errors marked with asterisk '*' are fatal; all others are simply warning messages.) .sp 1 .in +5 .ti -5 * arg stack overflow .br The argument stack for the macro processor has been exceeded. The size of the stack is determined by the symbol ARGSIZE in the source definitions file. .br .ti -5 o arith error .br An error occurred while evaluating the built-in macro, `arith'. .br .ti -5 * buffer overflow .br One of the preprocessor's internal buffers overflowed, possibly, but not necessarily, because the string buffers were exceeded. The definition SBUFSIZE in the preprocessor symbols file determines the size of the string buffers. .br .ti -5 * call stack overflow .br The call stack (used to store call frames) in the macro processor has been exceeded. The definition CALLSIZE in the source definition file determines the size of this stack. .br .ti -5 * cannot make identifier unique .br All attempts to generate an unique short variable name for the long variable name being processed failed. This message will only be seen if the long variable name processing has been enabled. .br .ti -5 o cannot open standard definitions file .br The special file containing general purpose ratfor definitions could not be opened, possibly because it did not exist or the user did not have access to the directory on which it resides. .br .ti -5 o can't open include .br File to be included could not be located, the user did not have privilege to access it, or the file could not be opened due to some problem in the local primitives. .br .ti -5 o conditional processing still active at EOF .br A sufficient number of "enddef" directives have not been encountered before detecting EOF on the input file. .br .ti -5 * Conditionals nested too deeply .br The stack for nested conditionals has overflowed. The size of the stack is specified by the value of COND_STACK_DEPTH defined in the preprocessor symbols file. .br .ti -5 * definition too long .br The number of characters in the name to be defined exceeded Ratfor's internal array size. The size is defined by the MAXTOK definition in the preprocessor symbols file. .br .ti -5 o duplicate case label .br Two case labels with identical values were detected. .br .ti -5 * EOF in string .br The macro processor detected an EOF in the current input file while evaluating a macro. .ti -5 * evaluation stack overflow .br The evaluation stack for the macro processor has been exceeded. This stack's size is determined by the symbol EVALSIZE in the source definition file. .br .ti -5 * for clause too long .br The internal buffer used to hold the clauses for the 'for' statement was exceeded. Size of this buffer is determined by the MAXFORSTK definition in the preprocessor symbols file. .br .ti -5 * getdef is confused .br There were horrendous problems when attempting to access the definition table .br .ti -5 o illegal break .br Break did not occur inside a valid "while", "for", or "repeat" loop .br .ti -5 o illegal case or default .br A "case" or "default" statement was detected which was not in the scope of a "switch" statement. .br .ti -5 o illegal case syntax .br The case label was not of the correct form. It may consist of comma-separated constants or ranges of constants. .br .ti -5 o illegal else .br Else clause probably did not follow an "if" clause .br .ti -5 * Illegal enddef encountered .br An "enddef" directive was encountered while conditional preprocessing was inactive. .br .ti -5 o illegal next .br "Next" did not occur inside a valid "for", "while", or "repeat" loop .br .ti -5 o illegal range in case label .br A case label specifying a range of values (of the form m-n) was detected in which m > n. .br .ti -5 o illegal right brace .br A right brace was found without a matching left brace .br .ti -5 o in entdef: no room for new definition .br There is insufficient memory for macro definitions, etc. Increase the MEMSIZE definition in the preprocessor. .br .ti -5 o includes nested too deeply .br There is a limit to the level of nesting of included files. It is dependent upon the maximum number of opened files allowed at a time, and is set by the NFILES definition in the preprocessor symbols file. .br .ti -5 o invalid case label .br The upper limit of a case label specifying a range was non-numeric. .br .ti -5 * invalid conditional token .br The token given as the argument to an "ifdef" or "ifnotdef" directive was not alpha-numeric. .br .ti -5 o invalid for clause .br The "for" clause did not contain a valid init, condition, and/or increment section .ti -5 o invalid string size .br The string format 'string name(size) "..."' was used, but the size was given improperly. .br .ti -5 * missing `(' in conditional .br The first non-blank token following an "ifdef" or "ifnotdef" directive was NOT a left parenthesis. .br .ti -5 * missing `)' in conditional .br An "ifdef" of "ifnotdef" directive was not properly terminated with a right parenthesis. .br .ti -5 * missing `)' in define .br A define(...) was not properly terminated with a right parenthesis. .br .ti -5 * missing `(' in undefine .br The first non-blank token following an "undefine" was NOT a left parenthesis. .br .ti -5 * missing `)' in undefine .br An "undefine" directive was not properly terminated with a right parenthesis. .br .ti -5 o missing apostrophe in character literal .br An apostrophe-delimited string NOT of the form 'c' or '@c' was encountered. .br .ti -5 * missing colon in case or default label .br The list of case labels, or the default label were not followed by a colon. .br .ti -5 * missing comma in define .br Definitions of the form 'define(name,defn)' must include the comma as a separator. .br .br .ti -5 o missing function name .br There was an error in declaring a function .br .ti -5 o missing left brace in switch statement .br The left brace indicating the start of the block of case labels for the "switch" statement was not encountered. .br .ti -5 o missing left paren .br A parenthesis was expected, probably in an "if" statement, but not found .br .ti -5 o missing literal quote .br The terminating "%)" to a literally quoted string was not found. .br .ti -5 o missing parenthesis in condition .br A right parenthesis was expected, probably in an "if" statement, but not found .br .ti -5 o missing quote .br A quoted string was not terminated by a quote .br .ti -5 o missing right paren .br A right parenthesis was expected in a Fortran (as opposed to Ratfor) statement but not found .br .ti -5 o missing string token .br No array name was given when declaring a string variable .br .ti -5 * multiple defaults in switch statement .br More than one "default" statements were detected in the scope of a single "switch" statement. .br .ti -5 o No room for generated variable name .br The table space used for generated long variable names has been exhausted. Increase the MEMSIZE definition in the preprocessor. This message cannot appear unless the long variable name processing has been enabled. .br .ti -5 o No room for linkage external name .br The table space used for generated external names has been exhausted. Increase the MEMSIZE definition in the preprocessor. This message cannot appear unless the long variable name processing has been enabled. .br .ti -5 * non-alphanumeric name .br Definitions may contain only alphanumeric characters and underscores. .br .ti -5 * stack overflow in parser .br Statements were nested at too deep a level. The stack depth is set by the MAXSTACK definition in the preprocessor symbols file. .br .ti -5 * switch table overflow .br More case labels were specified than the internal storage can handle. The size of the internal storage is determined by the value of MAXSWITCH defined in the preprocessor symbols file. .br .ti -5 o token too long .br A token (word) in the source code was too long to fit into one of Ratfor's internal arrays. The maximum size is set by the MAXTOK definition in the preprocessor symbols file. .br .ti -5 * too many characters pushed back .br The source code has illegally specified a Ratfor command, or has used a Ratfor keyword in an illegal manner, and the parser has attempted but failed to make sense out of it. The size of the push-back buffer is set by BUFSIZE in the preprocessor symbols file. .br .ti -5 o unbalanced parentheses .br Unbalanced parentheses detected in a Fortran (as opposed to Ratfor) statement .br .ti -5 o unexpected EOF .br An end-of-file was reached before all braces had been accounted for. This is usually caused by unmatched braces somewhere deep in the source code. .br .ti -5 o warning: possible label conflict .br This message is printed when the user has labeled a statement with a label in the 23000-23999 range. Ratfor statements are assigned in this range and a user-defined one may conflict with a Ratfor-generated one. .br .ne 3 .ti -5 * "file": cannot open .br Ratfor could not open an input file specified by the user on the command line. .br .in -5 .au Original by B. Kernighan and P. J. Plauger, with rewrites and enhancements by David Hanson and friends (U. of Arizona), Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory), and Allen Akin (Georgia Institute of Technology). .bu Missing parentheses or braces may cause erratic behavior. Eventually Ratfor should be taught to terminate parenthesis/brace checking at the end of each subroutine. .sp Although one bug was fixed which caused line numbers in error messages to be incorrect, they still aren't quite right. (newlines in macro text are difficult to handle properly). Use them only as a general area in which to look for errors. .sp Extraneous 'continue' statements are generated within Fortran 'do' statements. The 'next' statement does not work properly when used within Fortran 'do' statements. .sp There is no way to explicitly cause a statement to begin in column 6 (i.e. a Fortran continued statement), although implicit continuation is performed. .sp Ratfor is very slow, principally in the lexical analysis, character input, and macro processing routines (in that order). Attempts to speed it up should concentrate on the routines 'gtok', 'ngetch', and 'deftok'. An even better approach would be to re-work the lexical analyzer and parser completely. #-t- ratfordoc ascii 01/09/84 15:35 #-h- ratp1d ascii 01/09/84 15:35 define (DO_PASS1,) define (USE_STRING,"usage: ratp1 [-n] [file] ... >outfile") #-t- ratp1d ascii 01/09/84 15:35 #-h- rat77d ascii 01/09/84 15:35 define (DO_F77_STRINGS,) define (USE_STRING,"usage: rat77 [-n] [file] ... >outfile") define (STDEFNS,"") #-t- rat77d ascii 01/09/84 15:35 #-h- ratford ascii 01/09/84 15:35 define (DO_HOLLERITH,) define (USE_STRING,"usage: ratfor [-n] [file] ... >outfile") #-t- ratford ascii 01/09/84 15:35 #-t- ratfor.z ascii 01/09/84 15:54 #-h- ratlib.rat ascii 01/09/84 15:54 #-h- endst local 10-may-83 12:20:17 subroutine endst(status) integer status common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (ptr(2) > 1) # flush STDOUT call putch('@n', STDOUT) if (ptr(3) > 1) # flush ERROUT call putch('@n', ERROUT) if (status == ERR) # notify user of ERR condition call putlin("Endst called with ERROR status@n", ERROUT) # # Place whatever statements needed here to close down the files # or whatever you bound to units 5,6,7 in initst # stop end #-t- endst local 10-may-83 12:20:17 #-h- getch local 10-may-83 12:20:18 character function getch(c, fd) character c filedes fd integer i # # you will want to comment out the next line if no input character mapping is # required # character inmap common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (fd != STDIN) return(EOF) if (ptr(1) > last(1)) # must read again { read (5, 100, end=1) (inbuf(i), i=1,MAXCARD) 100 format(MAXCARD a1) # # you will want to comment out the next 2 lines if no input character mapping is # required # for (i = 1; i <= MAXCARD; i = i + 1) inbuf(i) = inmap(inbuf(i)) for (i = MAXCARD; i > 0; i = i - 1) if (inbuf(i) != ' ') break i = i + 1 inbuf(i) = '@n' ptr(1) = 1 last(1) = i } i = ptr(1) c = inbuf(i) ptr(1) = i + 1 return(c) 1 return(EOF) end #-t- getch local 10-may-83 12:20:18 #-h- getlin local 10-may-83 12:20:18 integer function getlin(buf, fd) character buf(MAXLINE) filedes fd character c integer i character getch for (i = 1; i <= MAXCARD; i = i + 1) { c = getch(buf(i), fd) if (c == EOF) return(EOF) else if (c == '@n') { i = i + 1 break } } buf(i) = EOS return (i-1) end #-t- getlin local 10-may-83 12:20:18 #-h- initst local 10-may-83 12:20:18 subroutine initst integer i common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output for (i = 1; i <= 3; i = i + 1) { ptr(i) = 1 last(i) = 0 } # # Place here the appropriate statements to bind units 5,6,7 # to devices/files/ports/fribbits on your system for # STDIN,STDOUT,ERROUT respectively # return end #-t- initst local 10-may-83 12:20:18 #-h- putch local 10-may-83 12:20:18 subroutine putch(c, fd) character c filedes fd integer n, i # # you will want to comment out the next line if output mapping is not required # character outmap common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (fd != STDOUT & fd != ERROUT) return if (c == '@n' | ptr(fd) >= MAXLINE) # flush appropriate buffer { n = last(fd) if (fd == STDOUT) { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (6, 100) (outbuf(i), i=1,n) } else { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (7, 100) (errbuf(i), i=1,n) } 100 format(MAXCARD a1) ptr(fd) = 1 last(fd) = 0 } if (c != '@n') { n = ptr(fd) ptr(fd) = n + 1 last(fd) = n if (fd == STDOUT) outbuf(n) = c else errbuf(n) = c } return end #-t- putch local 10-may-83 12:20:18 #-h- putlin local 10-may-83 12:20:19 subroutine putlin(buf, fd) character buf(MAXLINE) filedes fd integer i for (i = 1; buf(i) != EOS; i = i + 1) call putch(buf(i), fd) return end #-t- putlin local 10-may-83 12:20:19 #-h- inmap local 10-may-83 12:20:19 character function inmap(c) character c integer i common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK if (c == extblk) return(intblk) for (i = 1; i <= 10; i = i + 1) if (c == extdig(i)) return(intdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == extlet(i)) return(intlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == extbig(i)) return(intbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == extchr(i)) return(intchr(i)) return(c) end #-t- inmap local 10-may-83 12:20:19 #-h- outmap local 10-may-83 12:20:20 character function outmap(c) character c integer i common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK if (c == intblk) return(extblk) for (i = 1; i <= 10; i = i + 1) if (c == intdig(i)) return(extdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == intlet(i)) return(extlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == intbig(i)) return(extbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == intchr(i)) return(extchr(i)) return(c) end #-t- outmap local 10-may-83 12:20:20 #-h- block1 local 10-may-83 12:20:20 block data common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK data extblk /%(1H %)/, intblk /' '/ data extdig(1) /%(1H0%)/, intdig(1) /'0'/ data extdig(2) /%(1H1%)/, intdig(2) /'1'/ data extdig(3) /%(1H2%)/, intdig(3) /'2'/ data extdig(4) /%(1H3%)/, intdig(4) /'3'/ data extdig(5) /%(1H4%)/, intdig(5) /'4'/ data extdig(6) /%(1H5%)/, intdig(6) /'5'/ data extdig(7) /%(1H6%)/, intdig(7) /'6'/ data extdig(8) /%(1H7%)/, intdig(8) /'7'/ data extdig(9) /%(1H8%)/, intdig(9) /'8'/ data extdig(10) /%(1H9%)/, intdig(10) /'9'/ data extlet(1) /%(1Ha%)/, intlet(1) /'a'/ data extlet(2) /%(1Hb%)/, intlet(2) /'b'/ data extlet(3) /%(1Hc%)/, intlet(3) /'c'/ data extlet(4) /%(1Hd%)/, intlet(4) /'d'/ data extlet(5) /%(1He%)/, intlet(5) /'e'/ data extlet(6) /%(1Hf%)/, intlet(6) /'f'/ data extlet(7) /%(1Hg%)/, intlet(7) /'g'/ data extlet(8) /%(1Hh%)/, intlet(8) /'h'/ data extlet(9) /%(1Hi%)/, intlet(9) /'i'/ data extlet(10) /%(1Hj%)/, intlet(10) /'j'/ data extlet(11) /%(1Hk%)/, intlet(11) /'k'/ data extlet(12) /%(1Hl%)/, intlet(12) /'l'/ data extlet(13) /%(1Hm%)/, intlet(13) /'m'/ data extlet(14) /%(1Hn%)/, intlet(14) /'n'/ data extlet(15) /%(1Ho%)/, intlet(15) /'o'/ data extlet(16) /%(1Hp%)/, intlet(16) /'p'/ data extlet(17) /%(1Hq%)/, intlet(17) /'q'/ data extlet(18) /%(1Hr%)/, intlet(18) /'r'/ data extlet(19) /%(1Hs%)/, intlet(19) /'s'/ data extlet(20) /%(1Ht%)/, intlet(20) /'t'/ data extlet(21) /%(1Hu%)/, intlet(21) /'u'/ data extlet(22) /%(1Hv%)/, intlet(22) /'v'/ data extlet(23) /%(1Hw%)/, intlet(23) /'w'/ data extlet(24) /%(1Hx%)/, intlet(24) /'x'/ data extlet(25) /%(1Hy%)/, intlet(25) /'y'/ data extlet(26) /%(1Hz%)/, intlet(26) /'z'/ data extbig(1) /%(1HA%)/, intbig(1) /'A'/ data extbig(2) /%(1HB%)/, intbig(2) /'B'/ data extbig(3) /%(1HC%)/, intbig(3) /'C'/ data extbig(4) /%(1HD%)/, intbig(4) /'D'/ data extbig(5) /%(1HE%)/, intbig(5) /'E'/ data extbig(6) /%(1HF%)/, intbig(6) /'F'/ data extbig(7) /%(1HG%)/, intbig(7) /'G'/ data extbig(8) /%(1HH%)/, intbig(8) /'H'/ data extbig(9) /%(1HI%)/, intbig(9) /'I'/ data extbig(10) /%(1HJ%)/, intbig(10) /'J'/ data extbig(11) /%(1HK%)/, intbig(11) /'K'/ data extbig(12) /%(1HL%)/, intbig(12) /'L'/ data extbig(13) /%(1HM%)/, intbig(13) /'M'/ data extbig(14) /%(1HN%)/, intbig(14) /'N'/ data extbig(15) /%(1HO%)/, intbig(15) /'O'/ data extbig(16) /%(1HP%)/, intbig(16) /'P'/ data extbig(17) /%(1HQ%)/, intbig(17) /'Q'/ data extbig(18) /%(1HR%)/, intbig(18) /'R'/ data extbig(19) /%(1HS%)/, intbig(19) /'S'/ data extbig(20) /%(1HT%)/, intbig(20) /'T'/ data extbig(21) /%(1HU%)/, intbig(21) /'U'/ data extbig(22) /%(1HV%)/, intbig(22) /'V'/ data extbig(23) /%(1HW%)/, intbig(23) /'W'/ data extbig(24) /%(1HX%)/, intbig(24) /'X'/ data extbig(25) /%(1HY%)/, intbig(25) /'Y'/ data extbig(26) /%(1HZ%)/, intbig(26) /'Z'/ %c %c %c special characters -- you might have to change some of these %c data extchr(1) /%(1H!%)/, intchr(1) /'!'/ %c exclamation point data extchr(2) /%(1H"%)/, intchr(2) /'"'/ %c double quote data extchr(3) /%(1H#%)/, intchr(3) /'#'/ %c pound (number) sign data extchr(4) /%(1H$%)/, intchr(4) /'$'/ %c dollar sign data extchr(5) /%(1H%%)/, intchr(5) /'%'/ %c percent data extchr(6) /%(1H&%)/, intchr(6) /'&'/ %c ampersand data extchr(7) /%(1H'%)/, intchr(7) /'@''/ %c single quote data extchr(8) /%(1H(%)/, intchr(8) /'('/ %c left paren data extchr(9) /%(1H)%)/, intchr(9) /')'/ %c right paren data extchr(10) /%(1H*%)/, intchr(10) /'*'/ %c asterisk data extchr(11) /%(1H+%)/, intchr(11) /'+'/ %c plus data extchr(12) /%(1H,%)/, intchr(12) /','/ %c comma data extchr(13) /%(1H-%)/, intchr(13) /'-'/ %c dash (minus) data extchr(14) /%(1H.%)/, intchr(14) /'.'/ %c period data extchr(15) /%(1H/%)/, intchr(15) /'/'/ %c slash data extchr(16) /%(1H:%)/, intchr(16) /':'/ %c colon data extchr(17) /%(1H;%)/, intchr(17) /';'/ %c semicolon data extchr(18) /%(1H<%)/, intchr(18) /'<'/ %c less than (left angle bracket) data extchr(19) /%(1H=%)/, intchr(19) /'='/ %c equals data extchr(20) /%(1H>%)/, intchr(20) /'>'/ %c greater than (right angle bracket) data extchr(21) /%(1H?%)/, intchr(21) /'?'/ %c question mark data extchr(22) /%(1H@%)/, intchr(22) /'@@'/ %c atsign data extchr(23) /%(1H[%)/, intchr(23) /'['/ %c left bracket data extchr(24) /%(1H\%)/, intchr(24) /'\'/ %c backslash data extchr(25) /%(1H]%)/, intchr(25) /']'/ %c right bracket data extchr(26) /%(1H_%)/, intchr(26) /'_'/ %c underscore data extchr(27) /%(1H{%)/, intchr(27) /'{'/ %c left brace data extchr(28) /%(1H|%)/, intchr(28) /'|'/ %c vertical bar data extchr(29) /%(1H}%)/, intchr(29) /'}'/ %c right brace data extchr(30) /%(1H%)/, intchr(30) /'@b'/ %c backspace (control-h) data extchr(31) /%(1H %)/, intchr(31) /'@t'/ %c tab (control-i) data extchr(32) /%(1H^%)/, intchr(32) /'^'/ %c caret (up-arrow) data extchr(33) /%(1H~%)/, intchr(33) /'~'/ %c tilde end #-t- block1 local 10-may-83 12:20:20 #-t- ratlib.rat ascii 01/09/84 15:54 #-h- ratlib.z ascii 01/09/84 15:54 #-h- cratio local 11-may-83 08:50:18 common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output #-t- cratio local 11-may-83 08:50:18 #-h- cmapch local 11-may-83 08:50:18 common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK #-t- cmapch local 11-may-83 08:50:18 #-h- ratlib local 11-may-83 08:50:19 #-h- endst local 11-may-83 08:49:35 subroutine endst(status) integer status include cratio if (ptr(2) > 1) # flush STDOUT call putch('@n', STDOUT) if (ptr(3) > 1) # flush ERROUT call putch('@n', ERROUT) if (status == ERR) # notify user of ERR condition call putlin("Endst called with ERROR status@n", ERROUT) # # Place whatever statements needed here to close down the files # or whatever you bound to units 5,6,7 in initst # stop end #-t- endst local 11-may-83 08:49:35 #-h- getch local 11-may-83 08:49:35 character function getch(c, fd) character c filedes fd integer i # # you will want to comment out the next line if no input character mapping is # required # character inmap include cratio if (fd != STDIN) return(EOF) if (ptr(1) > last(1)) # must read again { read (5, 100, end=1) (inbuf(i), i=1,MAXCARD) 100 format(MAXCARD a1) # # you will want to comment out the next 2 lines if no input character mapping is # required # for (i = 1; i <= MAXCARD; i = i + 1) inbuf(i) = inmap(inbuf(i)) for (i = MAXCARD; i > 0; i = i - 1) if (inbuf(i) != ' ') break i = i + 1 inbuf(i) = '@n' ptr(1) = 1 last(1) = i } i = ptr(1) c = inbuf(i) ptr(1) = i + 1 return(c) 1 return(EOF) end #-t- getch local 11-may-83 08:49:35 #-h- getlin local 11-may-83 08:49:36 integer function getlin(buf, fd) character buf(MAXLINE) filedes fd character c integer i character getch for (i = 1; i <= MAXCARD; i = i + 1) { c = getch(buf(i), fd) if (c == EOF) return(EOF) else if (c == '@n') { i = i + 1 break } } buf(i) = EOS return (i-1) end #-t- getlin local 11-may-83 08:49:36 #-h- initst local 11-may-83 08:49:36 subroutine initst integer i include cratio for (i = 1; i <= 3; i = i + 1) { ptr(i) = 1 last(i) = 0 } # # Place here the appropriate statements to bind units 5,6,7 # to devices/files/ports/fribbits on your system for # STDIN,STDOUT,ERROUT respectively # return end #-t- initst local 11-may-83 08:49:36 #-h- putch local 11-may-83 08:49:36 subroutine putch(c, fd) character c filedes fd integer n, i # # you will want to comment out the next line if output mapping is not required # character outmap include cratio if (fd != STDOUT & fd != ERROUT) return if (c == '@n' | ptr(fd) >= MAXLINE) # flush appropriate buffer { n = last(fd) if (fd == STDOUT) { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (6, 100) (outbuf(i), i=1,n) } else { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (7, 100) (errbuf(i), i=1,n) } 100 format(MAXCARD a1) ptr(fd) = 1 last(fd) = 0 } if (c != '@n') { n = ptr(fd) ptr(fd) = n + 1 last(fd) = n if (fd == STDOUT) outbuf(n) = c else errbuf(n) = c } return end #-t- putch local 11-may-83 08:49:36 #-h- putlin local 11-may-83 08:49:37 subroutine putlin(buf, fd) character buf(MAXLINE) filedes fd integer i for (i = 1; buf(i) != EOS; i = i + 1) call putch(buf(i), fd) return end #-t- putlin local 11-may-83 08:49:37 #-h- inmap local 11-may-83 08:49:38 character function inmap(c) character c integer i include cmapch if (c == extblk) return(intblk) for (i = 1; i <= 10; i = i + 1) if (c == extdig(i)) return(intdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == extlet(i)) return(intlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == extbig(i)) return(intbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == extchr(i)) return(intchr(i)) return(c) end #-t- inmap local 11-may-83 08:49:38 #-h- outmap local 11-may-83 08:49:38 character function outmap(c) character c integer i include cmapch if (c == intblk) return(extblk) for (i = 1; i <= 10; i = i + 1) if (c == intdig(i)) return(extdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == intlet(i)) return(extlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == intbig(i)) return(extbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == intchr(i)) return(extchr(i)) return(c) end #-t- outmap local 11-may-83 08:49:38 #-h- block1 local 11-may-83 08:49:38 block data include cmapch data extblk /%(1H %)/, intblk /' '/ data extdig(1) /%(1H0%)/, intdig(1) /'0'/ data extdig(2) /%(1H1%)/, intdig(2) /'1'/ data extdig(3) /%(1H2%)/, intdig(3) /'2'/ data extdig(4) /%(1H3%)/, intdig(4) /'3'/ data extdig(5) /%(1H4%)/, intdig(5) /'4'/ data extdig(6) /%(1H5%)/, intdig(6) /'5'/ data extdig(7) /%(1H6%)/, intdig(7) /'6'/ data extdig(8) /%(1H7%)/, intdig(8) /'7'/ data extdig(9) /%(1H8%)/, intdig(9) /'8'/ data extdig(10) /%(1H9%)/, intdig(10) /'9'/ data extlet(1) /%(1Ha%)/, intlet(1) /'a'/ data extlet(2) /%(1Hb%)/, intlet(2) /'b'/ data extlet(3) /%(1Hc%)/, intlet(3) /'c'/ data extlet(4) /%(1Hd%)/, intlet(4) /'d'/ data extlet(5) /%(1He%)/, intlet(5) /'e'/ data extlet(6) /%(1Hf%)/, intlet(6) /'f'/ data extlet(7) /%(1Hg%)/, intlet(7) /'g'/ data extlet(8) /%(1Hh%)/, intlet(8) /'h'/ data extlet(9) /%(1Hi%)/, intlet(9) /'i'/ data extlet(10) /%(1Hj%)/, intlet(10) /'j'/ data extlet(11) /%(1Hk%)/, intlet(11) /'k'/ data extlet(12) /%(1Hl%)/, intlet(12) /'l'/ data extlet(13) /%(1Hm%)/, intlet(13) /'m'/ data extlet(14) /%(1Hn%)/, intlet(14) /'n'/ data extlet(15) /%(1Ho%)/, intlet(15) /'o'/ data extlet(16) /%(1Hp%)/, intlet(16) /'p'/ data extlet(17) /%(1Hq%)/, intlet(17) /'q'/ data extlet(18) /%(1Hr%)/, intlet(18) /'r'/ data extlet(19) /%(1Hs%)/, intlet(19) /'s'/ data extlet(20) /%(1Ht%)/, intlet(20) /'t'/ data extlet(21) /%(1Hu%)/, intlet(21) /'u'/ data extlet(22) /%(1Hv%)/, intlet(22) /'v'/ data extlet(23) /%(1Hw%)/, intlet(23) /'w'/ data extlet(24) /%(1Hx%)/, intlet(24) /'x'/ data extlet(25) /%(1Hy%)/, intlet(25) /'y'/ data extlet(26) /%(1Hz%)/, intlet(26) /'z'/ data extbig(1) /%(1HA%)/, intbig(1) /'A'/ data extbig(2) /%(1HB%)/, intbig(2) /'B'/ data extbig(3) /%(1HC%)/, intbig(3) /'C'/ data extbig(4) /%(1HD%)/, intbig(4) /'D'/ data extbig(5) /%(1HE%)/, intbig(5) /'E'/ data extbig(6) /%(1HF%)/, intbig(6) /'F'/ data extbig(7) /%(1HG%)/, intbig(7) /'G'/ data extbig(8) /%(1HH%)/, intbig(8) /'H'/ data extbig(9) /%(1HI%)/, intbig(9) /'I'/ data extbig(10) /%(1HJ%)/, intbig(10) /'J'/ data extbig(11) /%(1HK%)/, intbig(11) /'K'/ data extbig(12) /%(1HL%)/, intbig(12) /'L'/ data extbig(13) /%(1HM%)/, intbig(13) /'M'/ data extbig(14) /%(1HN%)/, intbig(14) /'N'/ data extbig(15) /%(1HO%)/, intbig(15) /'O'/ data extbig(16) /%(1HP%)/, intbig(16) /'P'/ data extbig(17) /%(1HQ%)/, intbig(17) /'Q'/ data extbig(18) /%(1HR%)/, intbig(18) /'R'/ data extbig(19) /%(1HS%)/, intbig(19) /'S'/ data extbig(20) /%(1HT%)/, intbig(20) /'T'/ data extbig(21) /%(1HU%)/, intbig(21) /'U'/ data extbig(22) /%(1HV%)/, intbig(22) /'V'/ data extbig(23) /%(1HW%)/, intbig(23) /'W'/ data extbig(24) /%(1HX%)/, intbig(24) /'X'/ data extbig(25) /%(1HY%)/, intbig(25) /'Y'/ data extbig(26) /%(1HZ%)/, intbig(26) /'Z'/ %c %c %c special characters -- you might have to change some of these %c data extchr(1) /%(1H!%)/, intchr(1) /'!'/ %c exclamation point data extchr(2) /%(1H"%)/, intchr(2) /'"'/ %c double quote data extchr(3) /%(1H#%)/, intchr(3) /'#'/ %c pound (number) sign data extchr(4) /%(1H$%)/, intchr(4) /'$'/ %c dollar sign data extchr(5) /%(1H%%)/, intchr(5) /'%'/ %c percent data extchr(6) /%(1H&%)/, intchr(6) /'&'/ %c ampersand data extchr(7) /%(1H'%)/, intchr(7) /'@''/ %c single quote data extchr(8) /%(1H(%)/, intchr(8) /'('/ %c left paren data extchr(9) /%(1H)%)/, intchr(9) /')'/ %c right paren data extchr(10) /%(1H*%)/, intchr(10) /'*'/ %c asterisk data extchr(11) /%(1H+%)/, intchr(11) /'+'/ %c plus data extchr(12) /%(1H,%)/, intchr(12) /','/ %c comma data extchr(13) /%(1H-%)/, intchr(13) /'-'/ %c dash (minus) data extchr(14) /%(1H.%)/, intchr(14) /'.'/ %c period data extchr(15) /%(1H/%)/, intchr(15) /'/'/ %c slash data extchr(16) /%(1H:%)/, intchr(16) /':'/ %c colon data extchr(17) /%(1H;%)/, intchr(17) /';'/ %c semicolon data extchr(18) /%(1H<%)/, intchr(18) /'<'/ %c less than (left angle bracket) data extchr(19) /%(1H=%)/, intchr(19) /'='/ %c equals data extchr(20) /%(1H>%)/, intchr(20) /'>'/ %c greater than (right angle bracket) data extchr(21) /%(1H?%)/, intchr(21) /'?'/ %c question mark data extchr(22) /%(1H@%)/, intchr(22) /'@@'/ %c atsign data extchr(23) /%(1H[%)/, intchr(23) /'['/ %c left bracket data extchr(24) /%(1H\%)/, intchr(24) /'\'/ %c backslash data extchr(25) /%(1H]%)/, intchr(25) /']'/ %c right bracket data extchr(26) /%(1H_%)/, intchr(26) /'_'/ %c underscore data extchr(27) /%(1H{%)/, intchr(27) /'{'/ %c left brace data extchr(28) /%(1H|%)/, intchr(28) /'|'/ %c vertical bar data extchr(29) /%(1H}%)/, intchr(29) /'}'/ %c right brace data extchr(30) /%(1H%)/, intchr(30) /'@b'/ %c backspace (control-h) data extchr(31) /%(1H %)/, intchr(31) /'@t'/ %c tab (control-i) data extchr(32) /%(1H^%)/, intchr(32) /'^'/ %c caret (up-arrow) data extchr(33) /%(1H~%)/, intchr(33) /'~'/ %c tilde end #-t- block1 local 11-may-83 08:49:38 #-t- ratlib local 11-may-83 08:50:19 #-t- ratlib.z ascii 01/09/84 15:54 #-h- ratlib2ch.f ascii 01/09/84 15:54 SUBROUTINE ENDST(STATUS) INTEGER STATUS INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF BYTE ST001Z(32) COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) DATA ST001Z(1)/69/,ST001Z(2)/110/,ST001Z(3)/100/,ST001Z(4)/115/, *ST001Z(5)/116/,ST001Z(6)/32/,ST001Z(7)/99/,ST001Z(8)/97/,ST001Z(9) */108/,ST001Z(10)/108/,ST001Z(11)/101/,ST001Z(12)/100/,ST001Z(13)/3 *2/,ST001Z(14)/119/,ST001Z(15)/105/,ST001Z(16)/116/,ST001Z(17)/104/ *,ST001Z(18)/32/,ST001Z(19)/69/,ST001Z(20)/82/,ST001Z(21)/82/, *ST001Z(22)/79/,ST001Z(23)/82/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/116/,ST001Z(27)/97/,ST001Z(28)/116/,ST001Z(29)/117/, *ST001Z(30)/115/,ST001Z(31)/10/,ST001Z(32)/0/ IF (.NOT.(PTR(2) .GT. 1))GOTO 23000 CALL PUTCH(10, 2) 23000 CONTINUE IF (.NOT.(PTR(3) .GT. 1))GOTO 23002 CALL PUTCH(10, 3) 23002 CONTINUE IF (.NOT.(STATUS .EQ. -3))GOTO 23004 CALL PUTLIN(ST001Z, 3) 23004 CONTINUE STOP END BYTE FUNCTION GETCH(C, FD) BYTE C INTEGER FD INTEGER I BYTE INMAP INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 1))GOTO 23006 GETCH=(-1) RETURN 23006 CONTINUE IF (.NOT.(PTR(1) .GT. LAST(1)))GOTO 23008 READ (5, 100, END=1) (INBUF(I), I=1,80) 100 FORMAT(80 A1) I = 1 23010 IF (.NOT.(I .LE. 80))GOTO 23012 INBUF(I) = INMAP(INBUF(I)) 23011 I = I + 1 GOTO 23010 23012 CONTINUE I = 80 23013 IF (.NOT.(I .GT. 0))GOTO 23015 IF (.NOT.(INBUF(I) .NE. 32))GOTO 23016 GOTO 23015 23016 CONTINUE 23014 I = I - 1 GOTO 23013 23015 CONTINUE I = I + 1 INBUF(I) = 10 PTR(1) = 1 LAST(1) = I 23008 CONTINUE I = PTR(1) C = INBUF(I) PTR(1) = I + 1 GETCH=(C) RETURN 1 GETCH=(-1) RETURN END INTEGER FUNCTION GETLIN(BUF, FD) BYTE BUF(82) INTEGER FD BYTE C INTEGER I BYTE GETCH I = 1 23018 IF (.NOT.(I .LE. 80))GOTO 23020 C = GETCH(BUF(I), FD) IF (.NOT.(C .EQ. -1))GOTO 23021 GETLIN=(-1) RETURN 23021 CONTINUE IF (.NOT.(C .EQ. 10))GOTO 23023 I = I + 1 GOTO 23020 23023 CONTINUE 23022 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE BUF(I) = 0 GETLIN=(I-1) RETURN END SUBROUTINE INITST INTEGER I INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) I = 1 23025 IF (.NOT.(I .LE. 3))GOTO 23027 PTR(I) = 1 LAST(I) = 0 23026 I = I + 1 GOTO 23025 23027 CONTINUE RETURN END SUBROUTINE PUTCH(C, FD) BYTE C INTEGER FD INTEGER N, I BYTE OUTMAP INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 2 .AND. FD .NE. 3))GOTO 23028 RETURN 23028 CONTINUE IF (.NOT.(C .EQ. 10 .OR. PTR(FD) .GE. 82))GOTO 23030 N = LAST(FD) IF (.NOT.(FD .EQ. 2))GOTO 23032 I = 1 23034 IF (.NOT.(I .LE. N))GOTO 23036 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23035 I = I + 1 GOTO 23034 23036 CONTINUE WRITE (6, 100) (OUTBUF(I), I=1,N) GOTO 23033 23032 CONTINUE I = 1 23037 IF (.NOT.(I .LE. N))GOTO 23039 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23038 I = I + 1 GOTO 23037 23039 CONTINUE WRITE (7, 100) (ERRBUF(I), I=1,N) 23033 CONTINUE 100 FORMAT(80 A1) PTR(FD) = 1 LAST(FD) = 0 23030 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23040 N = PTR(FD) PTR(FD) = N + 1 LAST(FD) = N IF (.NOT.(FD .EQ. 2))GOTO 23042 OUTBUF(N) = C GOTO 23043 23042 CONTINUE ERRBUF(N) = C 23043 CONTINUE 23040 CONTINUE RETURN END SUBROUTINE PUTLIN(BUF, FD) BYTE BUF(82) INTEGER FD INTEGER I I = 1 23044 IF (.NOT.(BUF(I) .NE. 0))GOTO 23046 CALL PUTCH(BUF(I), FD) 23045 I = I + 1 GOTO 23044 23046 CONTINUE RETURN END BYTE FUNCTION INMAP(C) BYTE C INTEGER I BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. EXTBLK))GOTO 23047 INMAP=(INTBLK) RETURN 23047 CONTINUE I = 1 23049 IF (.NOT.(I .LE. 10))GOTO 23051 IF (.NOT.(C .EQ. EXTDIG(I)))GOTO 23052 INMAP=(INTDIG(I)) RETURN 23052 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE I = 1 23054 IF (.NOT.(I .LE. 26))GOTO 23056 IF (.NOT.(C .EQ. EXTLET(I)))GOTO 23057 INMAP=(INTLET(I)) RETURN 23057 CONTINUE 23055 I = I + 1 GOTO 23054 23056 CONTINUE I = 1 23059 IF (.NOT.(I .LE. 26))GOTO 23061 IF (.NOT.(C .EQ. EXTBIG(I)))GOTO 23062 INMAP=(INTBIG(I)) RETURN 23062 CONTINUE 23060 I = I + 1 GOTO 23059 23061 CONTINUE I = 1 23064 IF (.NOT.(I .LE. 33))GOTO 23066 IF (.NOT.(C .EQ. EXTCHR(I)))GOTO 23067 INMAP=(INTCHR(I)) RETURN 23067 CONTINUE 23065 I = I + 1 GOTO 23064 23066 CONTINUE INMAP=(C) RETURN END BYTE FUNCTION OUTMAP(C) BYTE C INTEGER I BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. INTBLK))GOTO 23069 OUTMAP=(EXTBLK) RETURN 23069 CONTINUE I = 1 23071 IF (.NOT.(I .LE. 10))GOTO 23073 IF (.NOT.(C .EQ. INTDIG(I)))GOTO 23074 OUTMAP=(EXTDIG(I)) RETURN 23074 CONTINUE 23072 I = I + 1 GOTO 23071 23073 CONTINUE I = 1 23076 IF (.NOT.(I .LE. 26))GOTO 23078 IF (.NOT.(C .EQ. INTLET(I)))GOTO 23079 OUTMAP=(EXTLET(I)) RETURN 23079 CONTINUE 23077 I = I + 1 GOTO 23076 23078 CONTINUE I = 1 23081 IF (.NOT.(I .LE. 26))GOTO 23083 IF (.NOT.(C .EQ. INTBIG(I)))GOTO 23084 OUTMAP=(EXTBIG(I)) RETURN 23084 CONTINUE 23082 I = I + 1 GOTO 23081 23083 CONTINUE I = 1 23086 IF (.NOT.(I .LE. 33))GOTO 23088 IF (.NOT.(C .EQ. INTCHR(I)))GOTO 23089 OUTMAP=(EXTCHR(I)) RETURN 23089 CONTINUE 23087 I = I + 1 GOTO 23086 23088 CONTINUE OUTMAP=(C) RETURN END BLOCK DATA BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK DATA EXTBLK /1H /, INTBLK /32/ DATA EXTDIG(1) /1H0/, INTDIG(1) /48/ DATA EXTDIG(2) /1H1/, INTDIG(2) /49/ DATA EXTDIG(3) /1H2/, INTDIG(3) /50/ DATA EXTDIG(4) /1H3/, INTDIG(4) /51/ DATA EXTDIG(5) /1H4/, INTDIG(5) /52/ DATA EXTDIG(6) /1H5/, INTDIG(6) /53/ DATA EXTDIG(7) /1H6/, INTDIG(7) /54/ DATA EXTDIG(8) /1H7/, INTDIG(8) /55/ DATA EXTDIG(9) /1H8/, INTDIG(9) /56/ DATA EXTDIG(10) /1H9/, INTDIG(10) /57/ DATA EXTLET(1) /1Ha/, INTLET(1) /97/ DATA EXTLET(2) /1Hb/, INTLET(2) /98/ DATA EXTLET(3) /1Hc/, INTLET(3) /99/ DATA EXTLET(4) /1Hd/, INTLET(4) /100/ DATA EXTLET(5) /1He/, INTLET(5) /101/ DATA EXTLET(6) /1Hf/, INTLET(6) /102/ DATA EXTLET(7) /1Hg/, INTLET(7) /103/ DATA EXTLET(8) /1Hh/, INTLET(8) /104/ DATA EXTLET(9) /1Hi/, INTLET(9) /105/ DATA EXTLET(10) /1Hj/, INTLET(10) /106/ DATA EXTLET(11) /1Hk/, INTLET(11) /107/ DATA EXTLET(12) /1Hl/, INTLET(12) /108/ DATA EXTLET(13) /1Hm/, INTLET(13) /109/ DATA EXTLET(14) /1Hn/, INTLET(14) /110/ DATA EXTLET(15) /1Ho/, INTLET(15) /111/ DATA EXTLET(16) /1Hp/, INTLET(16) /112/ DATA EXTLET(17) /1Hq/, INTLET(17) /113/ DATA EXTLET(18) /1Hr/, INTLET(18) /114/ DATA EXTLET(19) /1Hs/, INTLET(19) /115/ DATA EXTLET(20) /1Ht/, INTLET(20) /116/ DATA EXTLET(21) /1Hu/, INTLET(21) /117/ DATA EXTLET(22) /1Hv/, INTLET(22) /118/ DATA EXTLET(23) /1Hw/, INTLET(23) /119/ DATA EXTLET(24) /1Hx/, INTLET(24) /120/ DATA EXTLET(25) /1Hy/, INTLET(25) /121/ DATA EXTLET(26) /1Hz/, INTLET(26) /122/ DATA EXTBIG(1) /1HA/, INTBIG(1) /65/ DATA EXTBIG(2) /1HB/, INTBIG(2) /66/ DATA EXTBIG(3) /1HC/, INTBIG(3) /67/ DATA EXTBIG(4) /1HD/, INTBIG(4) /68/ DATA EXTBIG(5) /1HE/, INTBIG(5) /69/ DATA EXTBIG(6) /1HF/, INTBIG(6) /70/ DATA EXTBIG(7) /1HG/, INTBIG(7) /71/ DATA EXTBIG(8) /1HH/, INTBIG(8) /72/ DATA EXTBIG(9) /1HI/, INTBIG(9) /73/ DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/ DATA EXTBIG(11) /1HK/, INTBIG(11) /75/ DATA EXTBIG(12) /1HL/, INTBIG(12) /76/ DATA EXTBIG(13) /1HM/, INTBIG(13) /77/ DATA EXTBIG(14) /1HN/, INTBIG(14) /78/ DATA EXTBIG(15) /1HO/, INTBIG(15) /79/ DATA EXTBIG(16) /1HP/, INTBIG(16) /80/ DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/ DATA EXTBIG(18) /1HR/, INTBIG(18) /82/ DATA EXTBIG(19) /1HS/, INTBIG(19) /83/ DATA EXTBIG(20) /1HT/, INTBIG(20) /84/ DATA EXTBIG(21) /1HU/, INTBIG(21) /85/ DATA EXTBIG(22) /1HV/, INTBIG(22) /86/ DATA EXTBIG(23) /1HW/, INTBIG(23) /87/ DATA EXTBIG(24) /1HX/, INTBIG(24) /88/ DATA EXTBIG(25) /1HY/, INTBIG(25) /89/ DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/ DATA EXTCHR(1) /1H!/, INTCHR(1) /33/ DATA EXTCHR(2) /1H"/, INTCHR(2) /34/ DATA EXTCHR(3) /1H#/, INTCHR(3) /35/ DATA EXTCHR(4) /1H$/, INTCHR(4) /36/ DATA EXTCHR(5) /1H%/, INTCHR(5) /37/ DATA EXTCHR(6) /1H&/, INTCHR(6) /38/ DATA EXTCHR(7) /1H'/, INTCHR(7) /39/ DATA EXTCHR(8) /1H(/, INTCHR(8) /40/ DATA EXTCHR(9) /1H)/, INTCHR(9) /41/ DATA EXTCHR(10) /1H*/, INTCHR(10) /42/ DATA EXTCHR(11) /1H+/, INTCHR(11) /43/ DATA EXTCHR(12) /1H,/, INTCHR(12) /44/ DATA EXTCHR(13) /1H-/, INTCHR(13) /45/ DATA EXTCHR(14) /1H./, INTCHR(14) /46/ DATA EXTCHR(15) /1H//, INTCHR(15) /47/ DATA EXTCHR(16) /1H:/, INTCHR(16) /58/ DATA EXTCHR(17) /1H;/, INTCHR(17) /59/ DATA EXTCHR(18) /1H/, INTCHR(20) /62/ DATA EXTCHR(21) /1H?/, INTCHR(21) /63/ DATA EXTCHR(22) /1H@/, INTCHR(22) /64/ DATA EXTCHR(23) /1H[/, INTCHR(23) /91/ DATA EXTCHR(24) /1H\/, INTCHR(24) /92/ DATA EXTCHR(25) /1H]/, INTCHR(25) /93/ DATA EXTCHR(26) /1H_/, INTCHR(26) /95/ DATA EXTCHR(27) /1H{/, INTCHR(27) /123/ DATA EXTCHR(28) /1H|/, INTCHR(28) /124/ DATA EXTCHR(29) /1H}/, INTCHR(29) /125/ DATA EXTCHR(30) /1H/, INTCHR(30) /8/ DATA EXTCHR(31) /1H /, INTCHR(31) /9/ DATA EXTCHR(32) /1H^/, INTCHR(32) /94/ DATA EXTCHR(33) /1H~/, INTCHR(33) /126/ c c c special characters -- you might have to change some of these c c exclamation point c double quote c pound (number) sign c dollar sign c percent c ampersand c single quote c left paren c right paren c asterisk c plus c comma c dash (minus) c period c slash c colon c semicolon c less than (left angle bracket) c equals c greater than (right angle bracket) c question mark c atsign c left bracket c backslash c right bracket c underscore c left brace c vertical bar c right brace c backspace (control-h) c tab (control-i) c caret (up-arrow) c tilde END #-t- ratlib2ch.f ascii 01/09/84 15:54 #-h- ratlib4ch.f ascii 01/09/84 15:54 SUBROUTINE ENDST(STATUS) INTEGER STATUS INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF BYTE ST001Z(32) COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) DATA ST001Z(1)/69/,ST001Z(2)/110/,ST001Z(3)/100/,ST001Z(4)/115/, *ST001Z(5)/116/,ST001Z(6)/32/,ST001Z(7)/99/,ST001Z(8)/97/,ST001Z(9) */108/,ST001Z(10)/108/,ST001Z(11)/101/,ST001Z(12)/100/,ST001Z(13)/3 *2/,ST001Z(14)/119/,ST001Z(15)/105/,ST001Z(16)/116/,ST001Z(17)/104/ *,ST001Z(18)/32/,ST001Z(19)/69/,ST001Z(20)/82/,ST001Z(21)/82/, *ST001Z(22)/79/,ST001Z(23)/82/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/116/,ST001Z(27)/97/,ST001Z(28)/116/,ST001Z(29)/117/, *ST001Z(30)/115/,ST001Z(31)/10/,ST001Z(32)/0/ IF (.NOT.(PTR(2) .GT. 1))GOTO 23000 CALL PUTCH(10, 2) 23000 CONTINUE IF (.NOT.(PTR(3) .GT. 1))GOTO 23002 CALL PUTCH(10, 3) 23002 CONTINUE IF (.NOT.(STATUS .EQ. -3))GOTO 23004 CALL PUTLIN(ST001Z, 3) 23004 CONTINUE STOP END BYTE FUNCTION GETCH(C, FD) BYTE C INTEGER FD INTEGER I BYTE INMAP INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 1))GOTO 23006 GETCH=(-1) RETURN 23006 CONTINUE IF (.NOT.(PTR(1) .GT. LAST(1)))GOTO 23008 READ (5, 100, END=1) (INBUF(I), I=1,80) 100 FORMAT(80 A1) I = 1 23010 IF (.NOT.(I .LE. 80))GOTO 23012 INBUF(I) = INMAP(INBUF(I)) 23011 I = I + 1 GOTO 23010 23012 CONTINUE I = 80 23013 IF (.NOT.(I .GT. 0))GOTO 23015 IF (.NOT.(INBUF(I) .NE. 32))GOTO 23016 GOTO 23015 23016 CONTINUE 23014 I = I - 1 GOTO 23013 23015 CONTINUE I = I + 1 INBUF(I) = 10 PTR(1) = 1 LAST(1) = I 23008 CONTINUE I = PTR(1) C = INBUF(I) PTR(1) = I + 1 GETCH=(C) RETURN 1 GETCH=(-1) RETURN END INTEGER FUNCTION GETLIN(BUF, FD) BYTE BUF(82) INTEGER FD BYTE C INTEGER I BYTE GETCH I = 1 23018 IF (.NOT.(I .LE. 80))GOTO 23020 C = GETCH(BUF(I), FD) IF (.NOT.(C .EQ. -1))GOTO 23021 GETLIN=(-1) RETURN 23021 CONTINUE IF (.NOT.(C .EQ. 10))GOTO 23023 I = I + 1 GOTO 23020 23023 CONTINUE 23022 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE BUF(I) = 0 GETLIN=(I-1) RETURN END SUBROUTINE INITST INTEGER I INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) I = 1 23025 IF (.NOT.(I .LE. 3))GOTO 23027 PTR(I) = 1 LAST(I) = 0 23026 I = I + 1 GOTO 23025 23027 CONTINUE RETURN END SUBROUTINE PUTCH(C, FD) BYTE C INTEGER FD INTEGER N, I BYTE OUTMAP INTEGER PTR INTEGER LAST BYTE INBUF BYTE OUTBUF BYTE ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 2 .AND. FD .NE. 3))GOTO 23028 RETURN 23028 CONTINUE IF (.NOT.(C .EQ. 10 .OR. PTR(FD) .GE. 82))GOTO 23030 N = LAST(FD) IF (.NOT.(FD .EQ. 2))GOTO 23032 I = 1 23034 IF (.NOT.(I .LE. N))GOTO 23036 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23035 I = I + 1 GOTO 23034 23036 CONTINUE WRITE (6, 100) (OUTBUF(I), I=1,N) GOTO 23033 23032 CONTINUE I = 1 23037 IF (.NOT.(I .LE. N))GOTO 23039 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23038 I = I + 1 GOTO 23037 23039 CONTINUE WRITE (7, 100) (ERRBUF(I), I=1,N) 23033 CONTINUE 100 FORMAT(80 A1) PTR(FD) = 1 LAST(FD) = 0 23030 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23040 N = PTR(FD) PTR(FD) = N + 1 LAST(FD) = N IF (.NOT.(FD .EQ. 2))GOTO 23042 OUTBUF(N) = C GOTO 23043 23042 CONTINUE ERRBUF(N) = C 23043 CONTINUE 23040 CONTINUE RETURN END SUBROUTINE PUTLIN(BUF, FD) BYTE BUF(82) INTEGER FD INTEGER I I = 1 23044 IF (.NOT.(BUF(I) .NE. 0))GOTO 23046 CALL PUTCH(BUF(I), FD) 23045 I = I + 1 GOTO 23044 23046 CONTINUE RETURN END BYTE FUNCTION INMAP(C) BYTE C INTEGER I BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. EXTBLK))GOTO 23047 INMAP=(INTBLK) RETURN 23047 CONTINUE I = 1 23049 IF (.NOT.(I .LE. 10))GOTO 23051 IF (.NOT.(C .EQ. EXTDIG(I)))GOTO 23052 INMAP=(INTDIG(I)) RETURN 23052 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE I = 1 23054 IF (.NOT.(I .LE. 26))GOTO 23056 IF (.NOT.(C .EQ. EXTLET(I)))GOTO 23057 INMAP=(INTLET(I)) RETURN 23057 CONTINUE 23055 I = I + 1 GOTO 23054 23056 CONTINUE I = 1 23059 IF (.NOT.(I .LE. 26))GOTO 23061 IF (.NOT.(C .EQ. EXTBIG(I)))GOTO 23062 INMAP=(INTBIG(I)) RETURN 23062 CONTINUE 23060 I = I + 1 GOTO 23059 23061 CONTINUE I = 1 23064 IF (.NOT.(I .LE. 33))GOTO 23066 IF (.NOT.(C .EQ. EXTCHR(I)))GOTO 23067 INMAP=(INTCHR(I)) RETURN 23067 CONTINUE 23065 I = I + 1 GOTO 23064 23066 CONTINUE INMAP=(C) RETURN END BYTE FUNCTION OUTMAP(C) BYTE C INTEGER I BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. INTBLK))GOTO 23069 OUTMAP=(EXTBLK) RETURN 23069 CONTINUE I = 1 23071 IF (.NOT.(I .LE. 10))GOTO 23073 IF (.NOT.(C .EQ. INTDIG(I)))GOTO 23074 OUTMAP=(EXTDIG(I)) RETURN 23074 CONTINUE 23072 I = I + 1 GOTO 23071 23073 CONTINUE I = 1 23076 IF (.NOT.(I .LE. 26))GOTO 23078 IF (.NOT.(C .EQ. INTLET(I)))GOTO 23079 OUTMAP=(EXTLET(I)) RETURN 23079 CONTINUE 23077 I = I + 1 GOTO 23076 23078 CONTINUE I = 1 23081 IF (.NOT.(I .LE. 26))GOTO 23083 IF (.NOT.(C .EQ. INTBIG(I)))GOTO 23084 OUTMAP=(EXTBIG(I)) RETURN 23084 CONTINUE 23082 I = I + 1 GOTO 23081 23083 CONTINUE I = 1 23086 IF (.NOT.(I .LE. 33))GOTO 23088 IF (.NOT.(C .EQ. INTCHR(I)))GOTO 23089 OUTMAP=(EXTCHR(I)) RETURN 23089 CONTINUE 23087 I = I + 1 GOTO 23086 23088 CONTINUE OUTMAP=(C) RETURN END BLOCK DATA BYTE EXTDIG BYTE INTDIG BYTE EXTLET BYTE INTLET BYTE EXTBIG BYTE INTBIG BYTE EXTCHR BYTE INTCHR BYTE EXTBLK BYTE INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK DATA EXTBLK /1H /, INTBLK /32/ DATA EXTDIG(1) /1H0/, INTDIG(1) /48/ DATA EXTDIG(2) /1H1/, INTDIG(2) /49/ DATA EXTDIG(3) /1H2/, INTDIG(3) /50/ DATA EXTDIG(4) /1H3/, INTDIG(4) /51/ DATA EXTDIG(5) /1H4/, INTDIG(5) /52/ DATA EXTDIG(6) /1H5/, INTDIG(6) /53/ DATA EXTDIG(7) /1H6/, INTDIG(7) /54/ DATA EXTDIG(8) /1H7/, INTDIG(8) /55/ DATA EXTDIG(9) /1H8/, INTDIG(9) /56/ DATA EXTDIG(10) /1H9/, INTDIG(10) /57/ DATA EXTLET(1) /1Ha/, INTLET(1) /97/ DATA EXTLET(2) /1Hb/, INTLET(2) /98/ DATA EXTLET(3) /1Hc/, INTLET(3) /99/ DATA EXTLET(4) /1Hd/, INTLET(4) /100/ DATA EXTLET(5) /1He/, INTLET(5) /101/ DATA EXTLET(6) /1Hf/, INTLET(6) /102/ DATA EXTLET(7) /1Hg/, INTLET(7) /103/ DATA EXTLET(8) /1Hh/, INTLET(8) /104/ DATA EXTLET(9) /1Hi/, INTLET(9) /105/ DATA EXTLET(10) /1Hj/, INTLET(10) /106/ DATA EXTLET(11) /1Hk/, INTLET(11) /107/ DATA EXTLET(12) /1Hl/, INTLET(12) /108/ DATA EXTLET(13) /1Hm/, INTLET(13) /109/ DATA EXTLET(14) /1Hn/, INTLET(14) /110/ DATA EXTLET(15) /1Ho/, INTLET(15) /111/ DATA EXTLET(16) /1Hp/, INTLET(16) /112/ DATA EXTLET(17) /1Hq/, INTLET(17) /113/ DATA EXTLET(18) /1Hr/, INTLET(18) /114/ DATA EXTLET(19) /1Hs/, INTLET(19) /115/ DATA EXTLET(20) /1Ht/, INTLET(20) /116/ DATA EXTLET(21) /1Hu/, INTLET(21) /117/ DATA EXTLET(22) /1Hv/, INTLET(22) /118/ DATA EXTLET(23) /1Hw/, INTLET(23) /119/ DATA EXTLET(24) /1Hx/, INTLET(24) /120/ DATA EXTLET(25) /1Hy/, INTLET(25) /121/ DATA EXTLET(26) /1Hz/, INTLET(26) /122/ DATA EXTBIG(1) /1HA/, INTBIG(1) /65/ DATA EXTBIG(2) /1HB/, INTBIG(2) /66/ DATA EXTBIG(3) /1HC/, INTBIG(3) /67/ DATA EXTBIG(4) /1HD/, INTBIG(4) /68/ DATA EXTBIG(5) /1HE/, INTBIG(5) /69/ DATA EXTBIG(6) /1HF/, INTBIG(6) /70/ DATA EXTBIG(7) /1HG/, INTBIG(7) /71/ DATA EXTBIG(8) /1HH/, INTBIG(8) /72/ DATA EXTBIG(9) /1HI/, INTBIG(9) /73/ DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/ DATA EXTBIG(11) /1HK/, INTBIG(11) /75/ DATA EXTBIG(12) /1HL/, INTBIG(12) /76/ DATA EXTBIG(13) /1HM/, INTBIG(13) /77/ DATA EXTBIG(14) /1HN/, INTBIG(14) /78/ DATA EXTBIG(15) /1HO/, INTBIG(15) /79/ DATA EXTBIG(16) /1HP/, INTBIG(16) /80/ DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/ DATA EXTBIG(18) /1HR/, INTBIG(18) /82/ DATA EXTBIG(19) /1HS/, INTBIG(19) /83/ DATA EXTBIG(20) /1HT/, INTBIG(20) /84/ DATA EXTBIG(21) /1HU/, INTBIG(21) /85/ DATA EXTBIG(22) /1HV/, INTBIG(22) /86/ DATA EXTBIG(23) /1HW/, INTBIG(23) /87/ DATA EXTBIG(24) /1HX/, INTBIG(24) /88/ DATA EXTBIG(25) /1HY/, INTBIG(25) /89/ DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/ DATA EXTCHR(1) /1H!/, INTCHR(1) /33/ DATA EXTCHR(2) /1H"/, INTCHR(2) /34/ DATA EXTCHR(3) /1H#/, INTCHR(3) /35/ DATA EXTCHR(4) /1H$/, INTCHR(4) /36/ DATA EXTCHR(5) /1H%/, INTCHR(5) /37/ DATA EXTCHR(6) /1H&/, INTCHR(6) /38/ DATA EXTCHR(7) /1H'/, INTCHR(7) /39/ DATA EXTCHR(8) /1H(/, INTCHR(8) /40/ DATA EXTCHR(9) /1H)/, INTCHR(9) /41/ DATA EXTCHR(10) /1H*/, INTCHR(10) /42/ DATA EXTCHR(11) /1H+/, INTCHR(11) /43/ DATA EXTCHR(12) /1H,/, INTCHR(12) /44/ DATA EXTCHR(13) /1H-/, INTCHR(13) /45/ DATA EXTCHR(14) /1H./, INTCHR(14) /46/ DATA EXTCHR(15) /1H//, INTCHR(15) /47/ DATA EXTCHR(16) /1H:/, INTCHR(16) /58/ DATA EXTCHR(17) /1H;/, INTCHR(17) /59/ DATA EXTCHR(18) /1H/, INTCHR(20) /62/ DATA EXTCHR(21) /1H?/, INTCHR(21) /63/ DATA EXTCHR(22) /1H@/, INTCHR(22) /64/ DATA EXTCHR(23) /1H[/, INTCHR(23) /91/ DATA EXTCHR(24) /1H\/, INTCHR(24) /92/ DATA EXTCHR(25) /1H]/, INTCHR(25) /93/ DATA EXTCHR(26) /1H_/, INTCHR(26) /95/ DATA EXTCHR(27) /1H{/, INTCHR(27) /123/ DATA EXTCHR(28) /1H|/, INTCHR(28) /124/ DATA EXTCHR(29) /1H}/, INTCHR(29) /125/ DATA EXTCHR(30) /1H/, INTCHR(30) /8/ DATA EXTCHR(31) /1H /, INTCHR(31) /9/ DATA EXTCHR(32) /1H^/, INTCHR(32) /94/ DATA EXTCHR(33) /1H~/, INTCHR(33) /126/ c c c special characters -- you might have to change some of these c c exclamation point c double quote c pound (number) sign c dollar sign c percent c ampersand c single quote c left paren c right paren c asterisk c plus c comma c dash (minus) c period c slash c colon c semicolon c less than (left angle bracket) c equals c greater than (right angle bracket) c question mark c atsign c left bracket c backslash c right bracket c underscore c left brace c vertical bar c right brace c backspace (control-h) c tab (control-i) c caret (up-arrow) c tilde END #-t- ratlib4ch.f ascii 01/09/84 15:54 #-h- ratlibint.f ascii 01/09/84 15:54 SUBROUTINE ENDST(STATUS) INTEGER STATUS INTEGER PTR INTEGER LAST INTEGER INBUF INTEGER OUTBUF INTEGER ERRBUF INTEGER ST001Z(32) COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) DATA ST001Z(1)/69/,ST001Z(2)/110/,ST001Z(3)/100/,ST001Z(4)/115/, *ST001Z(5)/116/,ST001Z(6)/32/,ST001Z(7)/99/,ST001Z(8)/97/,ST001Z(9) */108/,ST001Z(10)/108/,ST001Z(11)/101/,ST001Z(12)/100/,ST001Z(13)/3 *2/,ST001Z(14)/119/,ST001Z(15)/105/,ST001Z(16)/116/,ST001Z(17)/104/ *,ST001Z(18)/32/,ST001Z(19)/69/,ST001Z(20)/82/,ST001Z(21)/82/, *ST001Z(22)/79/,ST001Z(23)/82/,ST001Z(24)/32/,ST001Z(25)/115/, *ST001Z(26)/116/,ST001Z(27)/97/,ST001Z(28)/116/,ST001Z(29)/117/, *ST001Z(30)/115/,ST001Z(31)/10/,ST001Z(32)/0/ IF (.NOT.(PTR(2) .GT. 1))GOTO 23000 CALL PUTCH(10, 2) 23000 CONTINUE IF (.NOT.(PTR(3) .GT. 1))GOTO 23002 CALL PUTCH(10, 3) 23002 CONTINUE IF (.NOT.(STATUS .EQ. -3))GOTO 23004 CALL PUTLIN(ST001Z, 3) 23004 CONTINUE STOP END INTEGER FUNCTION GETCH(C, FD) INTEGER C INTEGER FD INTEGER I INTEGER INMAP INTEGER PTR INTEGER LAST INTEGER INBUF INTEGER OUTBUF INTEGER ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 1))GOTO 23006 GETCH=(-1) RETURN 23006 CONTINUE IF (.NOT.(PTR(1) .GT. LAST(1)))GOTO 23008 READ (5, 100, END=1) (INBUF(I), I=1,80) 100 FORMAT(80 A1) I = 1 23010 IF (.NOT.(I .LE. 80))GOTO 23012 INBUF(I) = INMAP(INBUF(I)) 23011 I = I + 1 GOTO 23010 23012 CONTINUE I = 80 23013 IF (.NOT.(I .GT. 0))GOTO 23015 IF (.NOT.(INBUF(I) .NE. 32))GOTO 23016 GOTO 23015 23016 CONTINUE 23014 I = I - 1 GOTO 23013 23015 CONTINUE I = I + 1 INBUF(I) = 10 PTR(1) = 1 LAST(1) = I 23008 CONTINUE I = PTR(1) C = INBUF(I) PTR(1) = I + 1 GETCH=(C) RETURN 1 GETCH=(-1) RETURN END INTEGER FUNCTION GETLIN(BUF, FD) INTEGER BUF(82) INTEGER FD INTEGER C INTEGER I INTEGER GETCH I = 1 23018 IF (.NOT.(I .LE. 80))GOTO 23020 C = GETCH(BUF(I), FD) IF (.NOT.(C .EQ. -1))GOTO 23021 GETLIN=(-1) RETURN 23021 CONTINUE IF (.NOT.(C .EQ. 10))GOTO 23023 I = I + 1 GOTO 23020 23023 CONTINUE 23022 CONTINUE 23019 I = I + 1 GOTO 23018 23020 CONTINUE BUF(I) = 0 GETLIN=(I-1) RETURN END SUBROUTINE INITST INTEGER I INTEGER PTR INTEGER LAST INTEGER INBUF INTEGER OUTBUF INTEGER ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) I = 1 23025 IF (.NOT.(I .LE. 3))GOTO 23027 PTR(I) = 1 LAST(I) = 0 23026 I = I + 1 GOTO 23025 23027 CONTINUE RETURN END SUBROUTINE PUTCH(C, FD) INTEGER C INTEGER FD INTEGER N, I INTEGER OUTMAP INTEGER PTR INTEGER LAST INTEGER INBUF INTEGER OUTBUF INTEGER ERRBUF COMMON / CRATIO / PTR(3), LAST(3), INBUF(82), OUTBUF(82), ERRBUF( *82) IF (.NOT.(FD .NE. 2 .AND. FD .NE. 3))GOTO 23028 RETURN 23028 CONTINUE IF (.NOT.(C .EQ. 10 .OR. PTR(FD) .GE. 82))GOTO 23030 N = LAST(FD) IF (.NOT.(FD .EQ. 2))GOTO 23032 I = 1 23034 IF (.NOT.(I .LE. N))GOTO 23036 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23035 I = I + 1 GOTO 23034 23036 CONTINUE WRITE (6, 100) (OUTBUF(I), I=1,N) GOTO 23033 23032 CONTINUE I = 1 23037 IF (.NOT.(I .LE. N))GOTO 23039 OUTBUF(I) = OUTMAP(OUTBUF(I)) 23038 I = I + 1 GOTO 23037 23039 CONTINUE WRITE (7, 100) (ERRBUF(I), I=1,N) 23033 CONTINUE 100 FORMAT(80 A1) PTR(FD) = 1 LAST(FD) = 0 23030 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23040 N = PTR(FD) PTR(FD) = N + 1 LAST(FD) = N IF (.NOT.(FD .EQ. 2))GOTO 23042 OUTBUF(N) = C GOTO 23043 23042 CONTINUE ERRBUF(N) = C 23043 CONTINUE 23040 CONTINUE RETURN END SUBROUTINE PUTLIN(BUF, FD) INTEGER BUF(82) INTEGER FD INTEGER I I = 1 23044 IF (.NOT.(BUF(I) .NE. 0))GOTO 23046 CALL PUTCH(BUF(I), FD) 23045 I = I + 1 GOTO 23044 23046 CONTINUE RETURN END INTEGER FUNCTION INMAP(C) INTEGER C INTEGER I INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. EXTBLK))GOTO 23047 INMAP=(INTBLK) RETURN 23047 CONTINUE I = 1 23049 IF (.NOT.(I .LE. 10))GOTO 23051 IF (.NOT.(C .EQ. EXTDIG(I)))GOTO 23052 INMAP=(INTDIG(I)) RETURN 23052 CONTINUE 23050 I = I + 1 GOTO 23049 23051 CONTINUE I = 1 23054 IF (.NOT.(I .LE. 26))GOTO 23056 IF (.NOT.(C .EQ. EXTLET(I)))GOTO 23057 INMAP=(INTLET(I)) RETURN 23057 CONTINUE 23055 I = I + 1 GOTO 23054 23056 CONTINUE I = 1 23059 IF (.NOT.(I .LE. 26))GOTO 23061 IF (.NOT.(C .EQ. EXTBIG(I)))GOTO 23062 INMAP=(INTBIG(I)) RETURN 23062 CONTINUE 23060 I = I + 1 GOTO 23059 23061 CONTINUE I = 1 23064 IF (.NOT.(I .LE. 33))GOTO 23066 IF (.NOT.(C .EQ. EXTCHR(I)))GOTO 23067 INMAP=(INTCHR(I)) RETURN 23067 CONTINUE 23065 I = I + 1 GOTO 23064 23066 CONTINUE INMAP=(C) RETURN END INTEGER FUNCTION OUTMAP(C) INTEGER C INTEGER I INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK IF (.NOT.(C .EQ. INTBLK))GOTO 23069 OUTMAP=(EXTBLK) RETURN 23069 CONTINUE I = 1 23071 IF (.NOT.(I .LE. 10))GOTO 23073 IF (.NOT.(C .EQ. INTDIG(I)))GOTO 23074 OUTMAP=(EXTDIG(I)) RETURN 23074 CONTINUE 23072 I = I + 1 GOTO 23071 23073 CONTINUE I = 1 23076 IF (.NOT.(I .LE. 26))GOTO 23078 IF (.NOT.(C .EQ. INTLET(I)))GOTO 23079 OUTMAP=(EXTLET(I)) RETURN 23079 CONTINUE 23077 I = I + 1 GOTO 23076 23078 CONTINUE I = 1 23081 IF (.NOT.(I .LE. 26))GOTO 23083 IF (.NOT.(C .EQ. INTBIG(I)))GOTO 23084 OUTMAP=(EXTBIG(I)) RETURN 23084 CONTINUE 23082 I = I + 1 GOTO 23081 23083 CONTINUE I = 1 23086 IF (.NOT.(I .LE. 33))GOTO 23088 IF (.NOT.(C .EQ. INTCHR(I)))GOTO 23089 OUTMAP=(EXTCHR(I)) RETURN 23089 CONTINUE 23087 I = I + 1 GOTO 23086 23088 CONTINUE OUTMAP=(C) RETURN END BLOCK DATA INTEGER EXTDIG INTEGER INTDIG INTEGER EXTLET INTEGER INTLET INTEGER EXTBIG INTEGER INTBIG INTEGER EXTCHR INTEGER INTCHR INTEGER EXTBLK INTEGER INTBLK COMMON / CMAPCH / EXTDIG(10), INTDIG(10), EXTLET(26), INTLET(26), *EXTBIG(26), INTBIG(26), EXTCHR(33), INTCHR(33), EXTBLK, INTBLK DATA EXTBLK /1H /, INTBLK /32/ DATA EXTDIG(1) /1H0/, INTDIG(1) /48/ DATA EXTDIG(2) /1H1/, INTDIG(2) /49/ DATA EXTDIG(3) /1H2/, INTDIG(3) /50/ DATA EXTDIG(4) /1H3/, INTDIG(4) /51/ DATA EXTDIG(5) /1H4/, INTDIG(5) /52/ DATA EXTDIG(6) /1H5/, INTDIG(6) /53/ DATA EXTDIG(7) /1H6/, INTDIG(7) /54/ DATA EXTDIG(8) /1H7/, INTDIG(8) /55/ DATA EXTDIG(9) /1H8/, INTDIG(9) /56/ DATA EXTDIG(10) /1H9/, INTDIG(10) /57/ DATA EXTLET(1) /1Ha/, INTLET(1) /97/ DATA EXTLET(2) /1Hb/, INTLET(2) /98/ DATA EXTLET(3) /1Hc/, INTLET(3) /99/ DATA EXTLET(4) /1Hd/, INTLET(4) /100/ DATA EXTLET(5) /1He/, INTLET(5) /101/ DATA EXTLET(6) /1Hf/, INTLET(6) /102/ DATA EXTLET(7) /1Hg/, INTLET(7) /103/ DATA EXTLET(8) /1Hh/, INTLET(8) /104/ DATA EXTLET(9) /1Hi/, INTLET(9) /105/ DATA EXTLET(10) /1Hj/, INTLET(10) /106/ DATA EXTLET(11) /1Hk/, INTLET(11) /107/ DATA EXTLET(12) /1Hl/, INTLET(12) /108/ DATA EXTLET(13) /1Hm/, INTLET(13) /109/ DATA EXTLET(14) /1Hn/, INTLET(14) /110/ DATA EXTLET(15) /1Ho/, INTLET(15) /111/ DATA EXTLET(16) /1Hp/, INTLET(16) /112/ DATA EXTLET(17) /1Hq/, INTLET(17) /113/ DATA EXTLET(18) /1Hr/, INTLET(18) /114/ DATA EXTLET(19) /1Hs/, INTLET(19) /115/ DATA EXTLET(20) /1Ht/, INTLET(20) /116/ DATA EXTLET(21) /1Hu/, INTLET(21) /117/ DATA EXTLET(22) /1Hv/, INTLET(22) /118/ DATA EXTLET(23) /1Hw/, INTLET(23) /119/ DATA EXTLET(24) /1Hx/, INTLET(24) /120/ DATA EXTLET(25) /1Hy/, INTLET(25) /121/ DATA EXTLET(26) /1Hz/, INTLET(26) /122/ DATA EXTBIG(1) /1HA/, INTBIG(1) /65/ DATA EXTBIG(2) /1HB/, INTBIG(2) /66/ DATA EXTBIG(3) /1HC/, INTBIG(3) /67/ DATA EXTBIG(4) /1HD/, INTBIG(4) /68/ DATA EXTBIG(5) /1HE/, INTBIG(5) /69/ DATA EXTBIG(6) /1HF/, INTBIG(6) /70/ DATA EXTBIG(7) /1HG/, INTBIG(7) /71/ DATA EXTBIG(8) /1HH/, INTBIG(8) /72/ DATA EXTBIG(9) /1HI/, INTBIG(9) /73/ DATA EXTBIG(10) /1HJ/, INTBIG(10) /74/ DATA EXTBIG(11) /1HK/, INTBIG(11) /75/ DATA EXTBIG(12) /1HL/, INTBIG(12) /76/ DATA EXTBIG(13) /1HM/, INTBIG(13) /77/ DATA EXTBIG(14) /1HN/, INTBIG(14) /78/ DATA EXTBIG(15) /1HO/, INTBIG(15) /79/ DATA EXTBIG(16) /1HP/, INTBIG(16) /80/ DATA EXTBIG(17) /1HQ/, INTBIG(17) /81/ DATA EXTBIG(18) /1HR/, INTBIG(18) /82/ DATA EXTBIG(19) /1HS/, INTBIG(19) /83/ DATA EXTBIG(20) /1HT/, INTBIG(20) /84/ DATA EXTBIG(21) /1HU/, INTBIG(21) /85/ DATA EXTBIG(22) /1HV/, INTBIG(22) /86/ DATA EXTBIG(23) /1HW/, INTBIG(23) /87/ DATA EXTBIG(24) /1HX/, INTBIG(24) /88/ DATA EXTBIG(25) /1HY/, INTBIG(25) /89/ DATA EXTBIG(26) /1HZ/, INTBIG(26) /90/ DATA EXTCHR(1) /1H!/, INTCHR(1) /33/ DATA EXTCHR(2) /1H"/, INTCHR(2) /34/ DATA EXTCHR(3) /1H#/, INTCHR(3) /35/ DATA EXTCHR(4) /1H$/, INTCHR(4) /36/ DATA EXTCHR(5) /1H%/, INTCHR(5) /37/ DATA EXTCHR(6) /1H&/, INTCHR(6) /38/ DATA EXTCHR(7) /1H'/, INTCHR(7) /39/ DATA EXTCHR(8) /1H(/, INTCHR(8) /40/ DATA EXTCHR(9) /1H)/, INTCHR(9) /41/ DATA EXTCHR(10) /1H*/, INTCHR(10) /42/ DATA EXTCHR(11) /1H+/, INTCHR(11) /43/ DATA EXTCHR(12) /1H,/, INTCHR(12) /44/ DATA EXTCHR(13) /1H-/, INTCHR(13) /45/ DATA EXTCHR(14) /1H./, INTCHR(14) /46/ DATA EXTCHR(15) /1H//, INTCHR(15) /47/ DATA EXTCHR(16) /1H:/, INTCHR(16) /58/ DATA EXTCHR(17) /1H;/, INTCHR(17) /59/ DATA EXTCHR(18) /1H/, INTCHR(20) /62/ DATA EXTCHR(21) /1H?/, INTCHR(21) /63/ DATA EXTCHR(22) /1H@/, INTCHR(22) /64/ DATA EXTCHR(23) /1H[/, INTCHR(23) /91/ DATA EXTCHR(24) /1H\/, INTCHR(24) /92/ DATA EXTCHR(25) /1H]/, INTCHR(25) /93/ DATA EXTCHR(26) /1H_/, INTCHR(26) /95/ DATA EXTCHR(27) /1H{/, INTCHR(27) /123/ DATA EXTCHR(28) /1H|/, INTCHR(28) /124/ DATA EXTCHR(29) /1H}/, INTCHR(29) /125/ DATA EXTCHR(30) /1H/, INTCHR(30) /8/ DATA EXTCHR(31) /1H /, INTCHR(31) /9/ DATA EXTCHR(32) /1H^/, INTCHR(32) /94/ DATA EXTCHR(33) /1H~/, INTCHR(33) /126/ c c c special characters -- you might have to change some of these c c exclamation point c double quote c pound (number) sign c dollar sign c percent c ampersand c single quote c left paren c right paren c asterisk c plus c comma c dash (minus) c period c slash c colon c semicolon c less than (left angle bracket) c equals c greater than (right angle bracket) c question mark c atsign c left bracket c backslash c right bracket c underscore c left brace c vertical bar c right brace c backspace (control-h) c tab (control-i) c caret (up-arrow) c tilde END #-t- ratlibint.f ascii 01/09/84 15:54 #-h- ratlibsym.rat ascii 01/09/84 15:54 #-h- endst local 10-may-83 12:20:17 subroutine endst(status) integer status common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (ptr(2) > 1) # flush STDOUT call putch(NEWLINE, STDOUT) if (ptr(3) > 1) # flush ERROUT call putch(NEWLINE, ERROUT) if (status == ERR) # notify user of ERR condition call putlin("Endst called with ERROR status@n", ERROUT) # # Place whatever statements needed here to close down the files # or whatever you bound to units 5,6,7 in initst # stop end #-t- endst local 10-may-83 12:20:17 #-h- getch local 10-may-83 12:20:18 character function getch(c, fd) character c filedes fd integer i # # you will want to comment out the next line if no input character mapping is # required # character inmap common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (fd != STDIN) return(EOF) if (ptr(1) > last(1)) # must read again { read (5, 100, end=1) (inbuf(i), i=1,MAXCARD) 100 format(MAXCARD a1) # # you will want to comment out the next 2 lines if no input character mapping is # required # for (i = 1; i <= MAXCARD; i = i + 1) inbuf(i) = inmap(inbuf(i)) for (i = MAXCARD; i > 0; i = i - 1) if (inbuf(i) != BLANK) break i = i + 1 inbuf(i) = NEWLINE ptr(1) = 1 last(1) = i } i = ptr(1) c = inbuf(i) ptr(1) = i + 1 return(c) 1 return(EOF) end #-t- getch local 10-may-83 12:20:18 #-h- getlin local 10-may-83 12:20:18 integer function getlin(buf, fd) character buf(MAXLINE) filedes fd character c integer i character getch for (i = 1; i <= MAXCARD; i = i + 1) { c = getch(buf(i), fd) if (c == EOF) return(EOF) else if (c == NEWLINE) { i = i + 1 break } } buf(i) = EOS return (i-1) end #-t- getlin local 10-may-83 12:20:18 #-h- initst local 10-may-83 12:20:18 subroutine initst integer i common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output for (i = 1; i <= 3; i = i + 1) { ptr(i) = 1 last(i) = 0 } # # Place here the appropriate statements to bind units 5,6,7 # to devices/files/ports/fribbits on your system for # STDIN,STDOUT,ERROUT respectively # return end #-t- initst local 10-may-83 12:20:18 #-h- putch local 10-may-83 12:20:18 subroutine putch(c, fd) character c filedes fd integer n, i # # you will want to comment out the next line if output mapping is not required # character outmap common / cratio / ptr(3), last(3), inbuf(MAXLINE), outbuf(MAXLINE), errbuf(MAXLINE) integer ptr # next available location in buffer integer last # last used location in buffer character inbuf # buffer for storing input character outbuf # buffer for storing output character errbuf # buffer for storing error output if (fd != STDOUT & fd != ERROUT) return if (c == NEWLINE | ptr(fd) >= MAXLINE) # flush appropriate buffer { n = last(fd) if (fd == STDOUT) { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (6, 100) (outbuf(i), i=1,n) } else { # # you will want to comment out the next 2 lines if output mapping is not needed # for (i = 1; i <= n; i = i + 1) outbuf(i) = outmap(outbuf(i)) write (7, 100) (errbuf(i), i=1,n) } 100 format(MAXCARD a1) ptr(fd) = 1 last(fd) = 0 } if (c != NEWLINE) { n = ptr(fd) ptr(fd) = n + 1 last(fd) = n if (fd == STDOUT) outbuf(n) = c else errbuf(n) = c } return end #-t- putch local 10-may-83 12:20:18 #-h- putlin local 10-may-83 12:20:19 subroutine putlin(buf, fd) character buf(MAXLINE) filedes fd integer i for (i = 1; buf(i) != EOS; i = i + 1) call putch(buf(i), fd) return end #-t- putlin local 10-may-83 12:20:19 #-h- inmap local 10-may-83 12:20:19 character function inmap(c) character c integer i common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK if (c == extblk) return(intblk) for (i = 1; i <= 10; i = i + 1) if (c == extdig(i)) return(intdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == extlet(i)) return(intlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == extbig(i)) return(intbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == extchr(i)) return(intchr(i)) return(c) end #-t- inmap local 10-may-83 12:20:19 #-h- outmap local 10-may-83 12:20:20 character function outmap(c) character c integer i common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK if (c == intblk) return(extblk) for (i = 1; i <= 10; i = i + 1) if (c == intdig(i)) return(extdig(i)) for (i = 1; i <= 26; i = i + 1) if (c == intlet(i)) return(extlet(i)) for (i = 1; i <= 26; i = i + 1) if (c == intbig(i)) return(extbig(i)) for (i = 1; i <= 33; i = i + 1) if (c == intchr(i)) return(extchr(i)) return(c) end #-t- outmap local 10-may-83 12:20:20 #-h- block1 local 10-may-83 12:20:20 block data common / cmapch / extdig(10), intdig(10), extlet(26), intlet(26), extbig(26), intbig(26), extchr(33), intchr(33), extblk, intblk character extdig # external digit representations character intdig # internal digit representations character extlet # external lower case letter representations character intlet # internal lower case letter representations character extbig # external upper case letter representations character intbig # internal upper case letter representations character extchr # external special character representations character intchr # internal special character representations character extblk # external representation for BLANK character intblk # internal representation for BLANK data extblk /%(1H %)/, intblk /BLANK/ data extdig(1) /%(1H0%)/, intdig(1) /DIG0/ data extdig(2) /%(1H1%)/, intdig(2) /DIG1/ data extdig(3) /%(1H2%)/, intdig(3) /DIG2/ data extdig(4) /%(1H3%)/, intdig(4) /DIG3/ data extdig(5) /%(1H4%)/, intdig(5) /DIG4/ data extdig(6) /%(1H5%)/, intdig(6) /DIG5/ data extdig(7) /%(1H6%)/, intdig(7) /DIG6/ data extdig(8) /%(1H7%)/, intdig(8) /DIG7/ data extdig(9) /%(1H8%)/, intdig(9) /DIG8/ data extdig(10) /%(1H9%)/, intdig(10) /DIG9/ data extlet(1) /%(1Ha%)/, intlet(1) /LETA/ data extlet(2) /%(1Hb%)/, intlet(2) /LETB/ data extlet(3) /%(1Hc%)/, intlet(3) /LETC/ data extlet(4) /%(1Hd%)/, intlet(4) /LETD/ data extlet(5) /%(1He%)/, intlet(5) /LETE/ data extlet(6) /%(1Hf%)/, intlet(6) /LETF/ data extlet(7) /%(1Hg%)/, intlet(7) /LETG/ data extlet(8) /%(1Hh%)/, intlet(8) /LETH/ data extlet(9) /%(1Hi%)/, intlet(9) /LETI/ data extlet(10) /%(1Hj%)/, intlet(10) /LETJ/ data extlet(11) /%(1Hk%)/, intlet(11) /LETK/ data extlet(12) /%(1Hl%)/, intlet(12) /LETL/ data extlet(13) /%(1Hm%)/, intlet(13) /LETM/ data extlet(14) /%(1Hn%)/, intlet(14) /LETN/ data extlet(15) /%(1Ho%)/, intlet(15) /LETO/ data extlet(16) /%(1Hp%)/, intlet(16) /LETP/ data extlet(17) /%(1Hq%)/, intlet(17) /LETQ/ data extlet(18) /%(1Hr%)/, intlet(18) /LETR/ data extlet(19) /%(1Hs%)/, intlet(19) /LETS/ data extlet(20) /%(1Ht%)/, intlet(20) /LETT/ data extlet(21) /%(1Hu%)/, intlet(21) /LETU/ data extlet(22) /%(1Hv%)/, intlet(22) /LETV/ data extlet(23) /%(1Hw%)/, intlet(23) /LETW/ data extlet(24) /%(1Hx%)/, intlet(24) /LETX/ data extlet(25) /%(1Hy%)/, intlet(25) /LETY/ data extlet(26) /%(1Hz%)/, intlet(26) /LETZ/ data extbig(1) /%(1HA%)/, intbig(1) /BIGA/ data extbig(2) /%(1HB%)/, intbig(2) /BIGB/ data extbig(3) /%(1HC%)/, intbig(3) /BIGC/ data extbig(4) /%(1HD%)/, intbig(4) /BIGD/ data extbig(5) /%(1HE%)/, intbig(5) /BIGE/ data extbig(6) /%(1HF%)/, intbig(6) /BIGF/ data extbig(7) /%(1HG%)/, intbig(7) /BIGG/ data extbig(8) /%(1HH%)/, intbig(8) /BIGH/ data extbig(9) /%(1HI%)/, intbig(9) /BIGI/ data extbig(10) /%(1HJ%)/, intbig(10) /BIGJ/ data extbig(11) /%(1HK%)/, intbig(11) /BIGK/ data extbig(12) /%(1HL%)/, intbig(12) /BIGL/ data extbig(13) /%(1HM%)/, intbig(13) /BIGM/ data extbig(14) /%(1HN%)/, intbig(14) /BIGN/ data extbig(15) /%(1HO%)/, intbig(15) /BIGO/ data extbig(16) /%(1HP%)/, intbig(16) /BIGP/ data extbig(17) /%(1HQ%)/, intbig(17) /BIGQ/ data extbig(18) /%(1HR%)/, intbig(18) /BIGR/ data extbig(19) /%(1HS%)/, intbig(19) /BIGS/ data extbig(20) /%(1HT%)/, intbig(20) /BIGT/ data extbig(21) /%(1HU%)/, intbig(21) /BIGU/ data extbig(22) /%(1HV%)/, intbig(22) /BIGV/ data extbig(23) /%(1HW%)/, intbig(23) /BIGW/ data extbig(24) /%(1HX%)/, intbig(24) /BIGX/ data extbig(25) /%(1HY%)/, intbig(25) /BIGY/ data extbig(26) /%(1HZ%)/, intbig(26) /BIGZ/ %c %c %c special characters -- you might have to change some of these %c data extchr(1) /%(1H!%)/, intchr(1) /BANG/ %c exclamation point data extchr(2) /%(1H"%)/, intchr(2) /DQUOTE/ %c double quote data extchr(3) /%(1H#%)/, intchr(3) /SHARP/ %c pound (number) sign data extchr(4) /%(1H$%)/, intchr(4) /DOLLAR/ %c dollar sign data extchr(5) /%(1H%%)/, intchr(5) /PERCENT/ %c percent data extchr(6) /%(1H&%)/, intchr(6) /AMPER/ %c ampersand data extchr(7) /%(1H'%)/, intchr(7) /SQUOTE/ %c single quote data extchr(8) /%(1H(%)/, intchr(8) /LPAREN/ %c left paren data extchr(9) /%(1H)%)/, intchr(9) /RPAREN/ %c right paren data extchr(10) /%(1H*%)/, intchr(10) /STAR/ %c asterisk data extchr(11) /%(1H+%)/, intchr(11) /PLUS/ %c plus data extchr(12) /%(1H,%)/, intchr(12) /COMMA/ %c comma data extchr(13) /%(1H-%)/, intchr(13) /MINUS/ %c dash (minus) data extchr(14) /%(1H.%)/, intchr(14) /PERIOD/ %c period data extchr(15) /%(1H/%)/, intchr(15) /SLASH/ %c slash data extchr(16) /%(1H:%)/, intchr(16) /COLON/ %c colon data extchr(17) /%(1H;%)/, intchr(17) /SEMICOL/ %c semicolon data extchr(18) /%(1H<%)/, intchr(18) /LESS/ %c less than (left angle bracket) data extchr(19) /%(1H=%)/, intchr(19) /EQUALS/ %c equals data extchr(20) /%(1H>%)/, intchr(20) /GREATER/ %c greater than (right angle bracket) data extchr(21) /%(1H?%)/, intchr(21) /QMARK/ %c question mark data extchr(22) /%(1H@%)/, intchr(22) /ATSIGN/ %c atsign data extchr(23) /%(1H[%)/, intchr(23) /LBRACK/ %c left bracket data extchr(24) /%(1H\%)/, intchr(24) /BACKSLASH/ %c backslash data extchr(25) /%(1H]%)/, intchr(25) /RBRACK/ %c right bracket data extchr(26) /%(1H_%)/, intchr(26) /UNDERLINE/ %c underscore data extchr(27) /%(1H{%)/, intchr(27) /LBRACE/ %c left brace data extchr(28) /%(1H|%)/, intchr(28) /BAR/ %c vertical bar data extchr(29) /%(1H}%)/, intchr(29) /RBRACE/ %c right brace data extchr(30) /%(1H%)/, intchr(30) /BS/ %c backspace (control-h) data extchr(31) /%(1H %)/, intchr(31) /TAB/ %c tab (control-i) data extchr(32) /%(1H^%)/, intchr(32) /CARET/ %c caret (up-arrow) data extchr(33) /%(1H~%)/, intchr(33) /TILDE/ %c tilde end #-t- block1 local 10-may-83 12:20:20 #-t- ratlibsym.rat ascii 01/09/84 15:54 #-h- ratp1.rat ascii 01/09/84 15:54 #-h- defns ascii 01/09/83 12:06:00 # Ratfor preprocessor # include ratdef #--------------------------------------------------------------- # 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 STDEFNS to "". # The suggested name for this file is `ratdef'. # #--------------------------------------------------------------- # If you want the preprocessor to output upper case only, # set the following definition: # # define (UPPERC,) # # This is defined by default #--------------------------------------------------------------- # If you want the preprocessor to perform the long name conversion, # set the following definition # # define (DO_LONGNAME,) # #--------------------------------------------------------------- # If you want the preprocessor to process the switch statement, # set the following definition # # define (DO_SWITCH,) # # This is defined by default #--------------------------------------------------------------- # Quoted string handling # # One of the major changes to the pre-processor with this release # is to permit pre-processors to be built which handle # quoted strings differently. # # This action is determined by one of three defined symbols: # # DO_PASS1 - all quoted strings encountered will have a character # variable name generated for them, with the appropriate # data statements expanded inline with the declaration. # As a result, all quoted strings are legal character # variables, and may be used anywhere a character array # could be used before. For example # # call putlin("Hello world.@n", STDOUT) # # is now legal. This is at the expense of requiring that # the output of the pre-processor must be run through the # second pass of the processor, RATP2. In addition, the # variable generated by the switch statement is declared # to be of type INTEGER. # # DO_F77_STRINGS - all quoted strings are output as F77 style strings. # it is expected that sites who wish to use ratfor # to pre-process into F77 will define this symbol # instead of DO_PASS1 and probably will define # STDEFNS to be "". Such a version of the pre-processor # should probably be called RAT77 # # DO_HOLLERITH - this outputs hollerith strings as before. # # The default is DO_PASS1. #--------------------------------------------------------------- # If you want to generate the fortran bootstrap, # set the following definition # # define (DO_BOOTSTRAP,) # # In addition, it will be necessary to append the fortran of several # of the library routines to the generated fortran file. #--------------------------------------------------------------- # 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,"ratdef") define (ALPHA_CHARACTERS,"_") # the set of legal characters in alpha tokens # VMS users might like to set this to "_$" define (UPPERC,) # define if Fortran compiler wants upper case define (DO_SWITCH,) # process the switch statement # # Pick only ONE of the following pairs !!!!! # define (DO_PASS1,) # output char decl and data statements for "...." define (USE_STRING,"usage: ratp1 [-n] [file] ... >outfile") #define (DO_F77_STRINGS,) # output F77 strings for "...." #define (USE_STRING,"usage: rat77 [-n] [file] ... >outfile") #define (DO_HOLLERITH,) # output hollerith strings for "...." #define (USE_STRING,"usage: ratfor [-n] [file] ... >outfile") define (RADIX,'%') # % indicates alternate radix define (TOGGLE,'%') # toggle for literal lines define (ARGFLAG,'$') # parameter delimeter in macros 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,'0') # used in long-name uniquing define (MAXIDLENGTH,6) # for Fortran 66 and 77 # Lexical items: define (LEXBREAK,-8) define (LEXCASE,-25) define (LEXDEFAULT,-26) define (LEXDIGITS,-9) define (LEXDO,-10) define (LEXELSE,-11) define (LEXEND,-21) define (LEXFOR,-16) define (LEXIF,-19) define (LEXLITERAL,-27) define (LEXNEXT,-13) define (LEXOTHER,-14) define (LEXREPEAT,-17) define (LEXRETURN,-20) define (LEXSTOP,-22) define (LEXSTRING,-23) define (LEXSWITCH,-24) define (LEXUNTIL,-18) define (LEXWHILE,-15) define (LSTRIPC,-10) define (RSTRIPC,-11) define (LITQUOTEC,-12) # 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 (ELSEDEFTYPE,-17) define (ENDDEFTYPE,-18) define (NOTDEFTYPE,-19) define (UNDEFTYPE,-21) define (LINKTYPE,-22) define (LENTOKTYPE,-23) # Size-limiting definitions: define(A_S_X,1) define(EVALSIZE,arith(A_S_X,*,500)) define(MEMSIZE,arith(A_S_X,*,4250)) # symbol tables and macro text define(MAXDEF,arith(A_S_X,*,250)) # max chars in a defn define(SBUFSIZE,arith(A_S_X,*,600)) # buffer for string statements define (BUFSIZE,arith(2,*,MAXDEF)) # pushback buffer size define (MAXFORSTK,300) # max space for for reinit clauses define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) define (MAXSTACK,100) # max stack depth for parser define (MAXSWITCH,300) # max stack for switch statement define (MAXTOK,120) # max chars in a token define (NFILES,arith(MAXOFILES,-,3)) # maximum number of include file nests define (MAXNBRSTR,20) # max nbr string decls per module define (CALLSIZE,50) define (ARGSIZE,100) define (COND_STACK_DEPTH,10) # size of conditional stack define (C_TRUE,1) # conditional value is true # Where to find the common blocks: define(COMMON_BLOCKS,"common") define(ext_subr,#) define(ext_func,) #-t- defns ascii 01/09/83 12:06:00 #-h- main ascii 01/09/83 12:06:00 DRIVER(ratfor) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, n ext_func integer getarg, open ext_subr query, initkw, ratarg, lodsym, cant, parse, close, lndict character arg (FILENAMESIZE) call query (USE_STRING) call initkw # initialize variables call ratarg # process command line flags if (dosym == YES) # load symbols call lodsym(arg) # Read standard definitions file n = 1 for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) { if (arg (1) == '-') if (arg(2) == EOS) infile (1) = STDIN else next # skip command flags else { infile (1) = open (arg, READ) if (infile (1) == ERR) call cant (arg) } n = n + 1 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 parse } DRETURN end #-t- main ascii 01/09/83 12:06:00 #-h- baderr ascii 01/09/83 12:06:00 # baderr --- report fatal error message, then die subroutine baderr (msg) character msg (ARB) ext_subr synerr, endst call synerr (msg) call endst(ERR) return end #-t- baderr ascii 01/09/83 12:06:00 #-h- balpar ascii 01/09/83 12:06:00 # balpar - copy balanced paren string subroutine balpar character t, token (MAXTOK) ext_func character gettok, gnbtok ext_subr synerr, outstr, pbstr, squash integer nlpar if (gnbtok (token, MAXTOK) != '(') { call synerr ("missing left paren") return } call outstr (token) nlpar = 1 repeat { t = gettok (token, MAXTOK) if (t == ';' | t == '{' | t == '}' | t == EOF) { call pbstr (token) break } if (t == '@n') # delete newlines token (1) = EOS else if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 # else nothing special call outstr (token) } until (nlpar <= 0) if (nlpar != 0) call synerr ("missing parenthesis in condition") return end #-t- balpar ascii 01/09/83 12:06:00 #-h- brknxt ascii 01/09/83 12:06:00 # brknxt - generate code for break n and next n; n = 1 is default subroutine brknxt (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token integer i, n character t ext_func integer alldig, ctoi ext_func character gnbtok ext_subr pbstr, outgo, synerr # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) n = 0 t = gnbtok (scrtok, MAXTOK) if (alldig (scrtok) == YES) { # have break n or next n i = 1 n = ctoi (scrtok, i) - 1 } else if (t != ';') # default case call pbstr (scrtok) 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 #-t- brknxt ascii 01/09/83 12:06:00 #-h- cascod ascii 01/09/83 12:06:00 # cascod - generate code for case or default label subroutine cascod (lab, token) integer lab, token # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer t, l, lb, ub, i, j, junk ext_func integer caslab, labgen ext_func character gnbtok ext_subr synerr, outgo, baderr, outcon if (swtop <= 0) { call synerr ("illegal case or default") return } 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 == '-') 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 == ':') break else if (t != ',') call synerr ("illegal case syntax") } } else { # default : ... t = gnbtok (scrtok, MAXTOK) if (swstak (swtop + 2) != 0) call baderr ("multiple defaults in switch statement") else swstak (swtop + 2) = l } if (t == EOF) call synerr ("unexpected EOF") else if (t != ':') call baderr ("missing colon in case or default label") xfer = NO call outcon (l) return end #-t- cascod ascii 01/09/83 12:06:00 #-h- caslab ascii 01/09/83 12:06:00 # caslab - get one case label integer function caslab (n, t) integer n, t character tok (MAXTOK) integer i, s ext_func character gnbtok ext_func integer ctoi ext_subr synerr t = gnbtok (tok, MAXTOK) while (t == '@n') t = gnbtok (tok, MAXTOK) if (t == EOF) return (t) if (t == '-') s = -1 else s = +1 if (t == '-' | t == '+') t = gnbtok (tok, MAXTOK) if (t != DIGIT) { call synerr ("invalid case label") n = 0 } else { i = 1 n = s * ctoi (tok, i) } t = gnbtok (tok, MAXTOK) while (t == '@n') t = gnbtok (tok, MAXTOK) return end #-t- caslab ascii 01/09/83 12:06:00 #-h- contln ascii 01/09/83 12:06:00 ### contln - start a continuation line subroutine contln # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) string blstar " *" call outdon call scopy(blstar, 1, outbuf, 1) outp = 6 return end #-t- contln ascii 01/09/83 12:06:00 #-h- deftok ascii 01/09/83 12:06:00 # deftok - get token; process macro calls and invocations # 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 # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t, c, defn (MAXDEF) integer ap, argstk (ARGSIZE), callst (CALLSIZE), nlb, plev (CALLSIZE), ifl ext_func integer ludef, push, ifparm, enter ext_func character gctok ext_subr puttok, getdef, entdef, baderr, putchr, pbstr, putbak, evalr, fold string balp "()" cp = 0 ap = 1 ep = 1 repeat { t = gctok (token, toksiz) if (t == EOF) break 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) == UNDEFTYPE) { # undefine the token call getund (token) # get name to undefine call rmdef (token, deftbl) } 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 = gctok (token, toksiz) if (t == ' ') { # allow blanks before arguments t = gctok (token, toksiz) call pbstr (token) if (t != '(') call putbak (' ') } else call pbstr (token) if (t != '(') call pbstr (balp) else if (ifparm (defn) == NO) call pbstr (balp) plev (cp) = 0 } else if (t == LSTRIPC) { nlb = 1 repeat { t = gctok (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 == '(') { if (plev (cp) > 0) call puttok (token) plev (cp) = plev (cp) + 1 } else if (t == ')') { 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 == ',' & 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 #-t- deftok ascii 01/09/83 12:06:00 #-h- dmpdcl ascii 01/09/83 12:06:00 # dmpdcl - dump accumulated declarations subroutine dmpdcl(token) character token(ARB) integer i, j, n character c ext_func integer index ext_func character esc # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) string char "character" string comstr "c " string dats "data " string eoss "EOS" if (sbp > 1) # something to do { for (i = 1; i < sbp; i = i + 1) { call outtab call outdef(char, token) call outch(' ') c = sbuf(i) j = 1 for (i = i + 1; sbuf(i) != EOS; i = i + 1) { token(j) = sbuf(i) j = j + 1 } token(j) = EOS i = i + 1 call outstr(token) call outdon # call outstr(comstr) # call outstr(token) # call outch(' ') # call outch(c) # for (j = i; sbuf(j) != EOS; j = j + 1) # call outch(sbuf(j)) # call outch(c) # call outdon j = index(token, '(') if (j > 0) token(j) = EOS j = 1 repeat { if (sbuf(i) == EOS & c == '@'') break if (j == 1) { call outtab call outstr(dats) } else call outch(',') call outstr(token) if (c == '"') { call outch('(') call outnum(j) call outch(')') } call outch('/') if (sbuf(i) == EOS) { call outdef(eoss, token) call outch('/') break } else { n = esc(sbuf, i) call outnum(n) call outch('/') } j = j + 1 i = i + 1 } call outdon } sbp = 1 } return end #-t- dmpdcl ascii 01/09/83 12:06:00 #-h- doarth ascii 01/09/83 12:06:00 # doarth - do arithmetic operation subroutine doarth (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k, l, ans, first, second character op ext_func integer ctoi ext_subr pbnum, synerr k = argstk (i + 2) first = ctoi(evalst, k) l = argstk (i + 4) second = ctoi(evalst, l) op = evalst (argstk (i + 3)) if (op == '+') call pbnum (first + second) else if (op == '-') call pbnum (first - second) else if (op == '*' ) { if (evalst(argstk(i+3) + 1) == '*') { ans = 1 for ( ; second > 0; second = second - 1) ans = ans * first call pbnum(ans) } else call pbnum (first * second) } else if (op == '/' ) call pbnum (first / second) else call synerr ("arith error") return end #-t- doarth ascii 01/09/83 12:06:00 #-h- docode ascii 01/09/83 12:06:00 # docode - generate code for beginning of do subroutine docode (lab) integer lab integer labgen # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gnbtok ext_subr outtab, outstr, outch, pbstr, outnum, eatup, outdon string sdo "do" xfer = NO call outtab call outstr (sdo) call outch (' ') lab = labgen (2) if (gnbtok (scrtok, MAXTOK) == DIGIT) # check for fortran DO call outstr (scrtok) else { call pbstr (scrtok) call outnum (lab) } call outch (' ') call eatup call outdon return end #-t- docode ascii 01/09/83 12:06:00 #-h- doif ascii 01/09/83 12:06:00 # doif - select one of two (macro) arguments subroutine doif (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer a2, a3, a4, a5 ext_func integer equal ext_subr pbstr 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 #-t- doif ascii 01/09/83 12:06:00 #-h- doincr ascii 01/09/83 12:06:00 # doincr - increment macro argument by 1 subroutine doincr (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k ext_func integer ctoi ext_subr pbnum k = argstk (i + 2) call pbnum (ctoi (evalst, k) + 1) return end #-t- doincr ascii 01/09/83 12:06:00 #-h- dolent ascii 01/09/83 12:06:00 # dolent - push back length of argument subroutine dolent(argstk, i, j) integer argstk(ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k ext_func integer length ext_subr pbnum k = argstk(i + 2) call pbnum(length(evalst(k))) return end #-t- dolent ascii 01/09/83 12:06:00 #-h- domac ascii 01/09/83 12:06:00 # domac - install macro definition in table subroutine domac (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer a2, a3 ext_subr entdef ext_func character type if (j - i > 2) { a2 = argstk (i + 2) a3 = argstk (i + 3) if (type(evalst(a2)) != LETTER) call synerr("Illegal first argument to mdefine") else call entdef (evalst (a2), evalst (a3), deftbl) # subarrays } return end #-t- domac ascii 01/09/83 12:06:00 #-h- dostat ascii 01/09/83 12:06:00 # dostat - generate code for end of do statement subroutine dostat (lab) integer lab ext_subr outcon call outcon (lab) call outcon (lab + 1) return end #-t- dostat ascii 01/09/83 12:06:00 #-h- dosub ascii 01/09/83 12:06:00 # dosub - select macro substring subroutine dosub (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer ap, fc, k, nc ext_func integer ctoi, length ext_subr putbak 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 #-t- dosub ascii 01/09/83 12:06:00 #-h- dother ascii 01/09/83 12:06:00 # process one other string in for clause character function dother(token) character token(MAXTOK), t integer nlpar ext_func character gettok ext_subr outtab, synerr, pbstr, squash, outstr, outdon call outtab nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == ';' | (t == ',' & nlpar == 0)) break if (t == EOF) { call synerr("unexpected EOF") call pbstr(token) break } if (t != '@n') call outstr(token) } call outdon return(t) end #-t- dother ascii 01/09/83 12:06:00 #-h- eatup ascii 01/09/83 12:06:00 # eatup - process rest of statement; interpret continuations subroutine eatup character ptoken (MAXTOK), t, token (MAXTOK) integer nlpar ext_func character gettok ext_subr pbstr, synerr, squash, outstr nlpar = 0 repeat { t = gettok (token, MAXTOK) if (t == ';' | t == '@n') break if (t == '}' | t == '{') { call pbstr (token) break } if (t == EOF) { call synerr ("unexpected EOF") call pbstr (token) break } if (t == ',' | t == '+' | t == '-' | t == '*' | t == '(' | t == AND | t == OR | t == NOT | t == '!' | t == '~' | t == '^' | t == '=') { while (gettok (ptoken, MAXTOK) == '@n') ; call pbstr (ptoken) } if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 call outstr (token) } until (nlpar < 0) if (nlpar != 0) call synerr ("unbalanced parentheses") return end #-t- eatup ascii 01/09/83 12:06:00 #-h- elenth ascii 01/09/83 12:06:00 # calculate length of buf, taking escaped characters into account integer function elenth(buf) character buf(ARB), c integer i, n ext_func character esc n = 0 for (i=1; buf(i) != EOS; i=i+1) { c = esc(buf, i) n = n + 1 } elenth = n return end #-t- elenth ascii 01/09/83 12:06:00 #-h- elseif ascii 01/09/83 12:06:00 # elseif - generate code for end of if before else subroutine elseif (lab) integer lab ext_subr outgo, outcon call outgo (lab+1) call outcon (lab) return end #-t- elseif ascii 01/09/83 12:06:00 #-h- entdkw ascii 01/09/83 12:06:00 # entdkw --- install macro processor keywords subroutine entdkw ext_subr ulstal string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" string undefn "undefine" string linknm "linkage" string lentnm "lentok" call ulstal (defnam, DEFTYPE) call ulstal (macnam, MACTYPE) call ulstal (incnam, INCTYPE) call ulstal (subnam, SUBTYPE) call ulstal (ifnam, IFTYPE) call ulstal (arnam, ARITHTYPE) call ulstal (undefn, UNDEFTYPE) call ulstal(linknm, DEFTYPE) call ulstal(lentnm, LENTOKTYPE) return end #-t- entdkw ascii 01/09/83 12:06:00 #-h- entrkw ascii 01/09/83 12:06:00 # entrkw --- install Ratfor keywords in symbol table subroutine entrkw # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer junk ext_func integer enter 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" junk = enter (sif, LEXIF, rkwtbl) junk = enter (selse, LEXELSE, rkwtbl) junk = enter (swhile, LEXWHILE, rkwtbl) junk = enter (sdo, LEXDO, rkwtbl) junk = enter (sbreak, LEXBREAK, rkwtbl) junk = enter (snext, LEXNEXT, rkwtbl) junk = enter (sfor, LEXFOR, rkwtbl) junk = enter (srept, LEXREPEAT, rkwtbl) junk = enter (suntil, LEXUNTIL, rkwtbl) junk = enter (sret, LEXRETURN, rkwtbl) junk = enter (sstr, LEXSTRING, rkwtbl) junk = enter (sswtch, LEXSWITCH, rkwtbl) junk = enter (scase, LEXCASE, rkwtbl) junk = enter (sdeflt, LEXDEFAULT, rkwtbl) return end #-t- entrkw ascii 01/09/83 12:06:00 #-h- evalr ascii 01/09/83 12:06:00 # evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer argno, k, m, n, t, td ext_func integer index, length ext_subr domac, doincr, dosub, doif, doarth, putbak, pbstr 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 if (td == LENTOKTYPE) call dolent (argstk, i, j) else { for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) if (evalst (k - 1) != ARGFLAG) call putbak (evalst (k)) else { argno = index (digits, evalst (k)) - 1 if (argno >= 0) # was a digit { if (argno < j - i) # user provided argument { n = i + argno + 1 m = argstk (n) call pbstr (evalst (m)) } k = k - 1 # skip over $ } else call putbak (evalst (k)) } if (k == t) # do last character call putbak (evalst (k)) } return end #-t- evalr ascii 01/09/83 12:06:00 #-h- fclaus ascii 01/09/83 12:06:00 # process for init or re-init clause subroutine fclaus character token(MAXTOK), t ext_func character gnbtok, dother ext_subr pbstr, synerr repeat { t = gnbtok(token, MAXTOK) # get rid of leading blanks call pbstr(token) # ... t = dother(token) # process single other } until (t == ';' | t == EOF) return end #-t- fclaus ascii 01/09/83 12:06:00 #-h- finit ascii 01/09/83 12:06:00 # finit - initialize for each input file subroutine finit # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) outp = 0 # output character pointer level = 1 # file control linect (1) = 1 sbp = 1 fnamp = 2 fnames (1) = EOS bp = 0 # nothing in push back buffer fordep = 0 # for stack fcname (1) = EOS # current function name swtop = 0 # switch stack swlast = 1 csp = 0 curcnd = C_TRUE return end #-t- finit ascii 01/09/83 12:06:00 #-h- forcod ascii 01/09/83 12:06:00 # forcod - beginning of for statement subroutine forcod (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t integer i, j, nlpar, len ext_func character gettok, gnbtok ext_func integer length, labgen ext_subr outcon, synerr, pbstr, fclaus, outnum, outtab, outstr, outch ext_subr squash, outgo, baderr, scopy string ifnot "if (.not." string semi ";" lab = labgen (3) call outcon (0) if (gnbtok (scrtok, MAXTOK) != '(') { call synerr ("missing left paren") return } if (gnbtok (scrtok, MAXTOK) != ';') { # real init clause call pbstr (scrtok) call fclaus # output init clause } if (gnbtok (scrtok, MAXTOK) == ';') # empty condition call outcon (lab) else { # non-empty condition call pbstr (scrtok) call outnum (lab) call outtab call outstr (ifnot) call outch ('(') nlpar = 0 while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == ';') break if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) return } if (t != '@n') call outstr (scrtok) } call outch (')') call outch (')') call outgo (lab+2) if (nlpar < 0) call synerr ("invalid for clause") } fordep = fordep + 1 # stack reinit clause len = 0 # total length of re-init 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 (scrtok, MAXTOK) call pbstr (scrtok) while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) break } if (nlpar >= 0 & t != '@n') { if (j + length (scrtok) >= MAXFORSTK) call baderr ("for clause too long") call scopy (scrtok, 1, forstk, j) j = j + length (scrtok) len = len + length (scrtok) } } lab = lab + 1 # label for next's return end #-t- forcod ascii 01/09/83 12:06:00 #-h- fors ascii 01/09/83 12:06:00 # fors - process end of for statement subroutine fors (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, j ext_func integer length ext_subr outnum, pbstr, fclaus, outgo, outcon 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 putbak (';') # push back trailing colon call pbstr (forstk (j)) # push back re-init clause call fclaus # output clause } call outgo (lab - 1) call outcon (lab + 1) fordep = fordep - 1 return end #-t- fors ascii 01/09/83 12:06:00 #-h- gctok ascii 01/09/83 12:06:00 # gctok - get next token, subject to conditionals character function gctok(token, toksiz) character token(MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character temp(9) integer ctype, i, n, j, cndval(4), newcnd, value ext_func character gtok ext_func integer equal, lookup ext_subr upper, baderr, skpblk string letts "eEiI" string cndtbl "ifdef/ifnotdef/elsedef/enddef/" data cndval(1)/IFDEFTYPE/, cndval(2)/IFNOTDEFTYPE/, cndval(3)/ELSEDEFTYPE/, cndval(4)/ENDDEFTYPE/ repeat { gctok = gtok (token, toksiz) if (gctok == EOF) break ctype = NOTDEFTYPE # assume not conditional for (i = 1; letts(i) != EOS; i = i + 1) # see if correct first char if (letts(i) == token(1)) break if (letts(i) != EOS) { # YES, check further n = 1 # index into cndval for (i = 1; cndtbl(i) != EOS; i = i + 1) { for (j = 1; cndtbl(i) != '/'; j = j + 1) { temp(j) = cndtbl(i) i = i + 1 } temp(j) = EOS j = equal(token, temp) if (j == NO) { call upper(temp) j = equal(token, temp) } if (j == YES) { ctype = cndval(n) break } n = n + 1 } } if (ctype == NOTDEFTYPE) { if (curcnd == C_TRUE) break } else if (ctype == ENDDEFTYPE) { if (csp <= 0) call baderr("Illegal enddef encountered") curcnd = cndstk(csp) csp = csp - 1 } else { if (ctype == ELSEDEFTYPE) newcnd = - curcnd else { if (csp >= COND_STACK_DEPTH) call baderr("Conditionals nested too deeply") csp = csp + 1 cndstk(csp) = curcnd call skpblk if (gtok(temp, 9) != '(') call baderr("missing `(' in conditional") call skpblk if (gtok(token, toksiz) != ALPHA) call baderr("invalid conditional token") call skpblk if (gtok(temp, 9) != ')') call baderr("missing `)' in conditional") if (lookup(token, value, deftbl) == YES) newcnd = C_TRUE else newcnd = - C_TRUE if (ctype == IFNOTDEFTYPE) newcnd = - newcnd } curcnd = min (newcnd, cndstk (csp) ) } } return end #-t- gctok ascii 01/09/83 12:06:00 #-h- gennam ascii 01/09/83 12:06:00 # gennam - generate name for string and character variables integer function gennam(root, countr, buf) character root(ARB), buf(incr(MAXIDLENGTH)), temp(4) integer countr, x, i, d, j string digits "0123456789abcdefghijklmnopqrst" x = countr countr = countr + 1 if (countr > arith(30,**,3)) countr = 1 for (i = 1; x > 0; i = i + 1) { d = mod(x, 30) + 1 temp(i) = digits(d) x = x / 30 } temp(i) = EOS j = 1 call insstr(root, buf, j, MAXIDLENGTH) for (x = 4 - i; x > 0; x = x - 1) call inschr('0', buf, j, MAXIDLENGTH) for (i = i - 1; i > 0; i = i - 1) call inschr(temp(i), buf, j, MAXIDLENGTH) call inschr('z', buf, j, MAXIDLENGTH) buf(j) = EOS return (j-1) end #-t- gennam ascii 01/09/83 12:06:00 #-h- getdef ascii 01/09/83 12:06:00 # getdef (for no arguments) - get name and definition subroutine getdef (token, toksiz, defn, defsiz) character token (MAXTOK), defn (MAXDEF) integer toksiz, defsiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c, t, ptoken (MAXTOK) integer i, nlpar ext_func character gctok, ngetch ext_subr skpblk, pbstr, baderr, putbak call skpblk c = gctok (ptoken, MAXTOK) if (c == '(') t = '(' # define (name, defn) else { t = ' ' # define name defn call pbstr (ptoken) } call skpblk if (gctok (token, toksiz) != ALPHA) call baderr ("non-alphanumeric name") call skpblk c = gctok (ptoken, MAXTOK) if (t == ' ') { # 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 == '#' | c == '@n' | c == EOF) if (c == '#') call putbak (c) } else if (t == '(') { # define (name, defn) if (c != ',') 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) == '(') nlpar = nlpar + 1 else if (defn (i) == ')') nlpar = nlpar - 1 # else normal character in defn (i) } else call baderr ("getdef is confused") defn (i - 1) = EOS return end #-t- getdef ascii 01/09/83 12:06:00 #-h- gettok ascii 01/09/83 12:06:00 # gettok - get token. handles file inclusion and line numbers character function gettok (token, toksiz) character token (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, len character name (MAXNAME), t, tbuf(9) ext_func integer equal, open, length ext_func character deftok ext_subr skpblk, pbstr, synerr, putbak, scopy, close string fncn "function" string incl "include" for ( ; level > 0; level = level - 1) { repeat { gettok = deftok(token, toksiz) if (gettok == EOF) break else if (gettok != ALPHA) return for (i = 1; i <= 9; i = i + 1) { t = token(i) tbuf(i) = t if (t == EOS) break } if (i < 8 | t != EOS) return call fold(tbuf) if (equal (tbuf, fncn) == YES) { call skpblk t = deftok (fcname, MAXNAME) call pbstr (fcname) if (t != ALPHA) call synerr ("missing function name") call putbak (' ') return } else if (equal (tbuf, incl) == NO) return # process 'include' statements: call skpblk t = deftok (name, MAXNAME) if (t == '"') { 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) = 1 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 } } token (1) = EOF # in case called more than once token (2) = EOS gettok = EOF return end #-t- gettok ascii 01/09/83 12:06:00 #-h- getund ascii 01/09/83 12:06:00 # getund - get name for undefine statement subroutine getund(token) character token(MAXTOK), temp(4) ext_func character gctok call skpblk if (gctok(token, MAXTOK) != '(') call baderr("missing `(' in undefine") call skpblk if (gctok(token, MAXTOK) != ALPHA) call baderr("non-alphanumeric name") call skpblk if (gctok(temp, 4) != ')') call baderr("missing `)' in undefine") return end #-t- getund ascii 01/09/83 12:06:00 #-h- gnbtok ascii 01/09/83 12:06:00 # gnbtok - get nonblank token character function gnbtok (token, toksiz) character token (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gettok ext_subr skpblk repeat { call skpblk gnbtok = gettok (token, toksiz) } until (gnbtok != ' ') return end #-t- gnbtok ascii 01/09/83 12:06:00 #-h- gtok ascii 01/09/83 12:06:00 # gtok - get token for Ratfor character function gtok (lexstr, toksiz) character lexstr (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c integer i, b, n, d ext_func character ngetch, clower, esc ext_func integer itoc, index, ctoi ext_subr putbak, synerr, relate character ctype ext_func character type string digits "0123456789abcdefghijklmnopqrstuvwxyz" string alfchr ALPHA_CHARACTERS repeat # get next character, gobbling "_@n" { c = ngetch (lexstr (1)) if (c == '_') if (ngetch(c) != '@n') { call putbak(c) c = '_' break } } until (lexstr(1) != '_') if (c == ' ' | c == '@t') { lexstr (1) = ' ' while (c == ' ' | c == '@t') # compress many blanks to one c = ngetch (c) if (c == '#') while (ngetch (c) != '@n') # strip comments ; if (c != '@n') call putbak (c) else lexstr (1) = '@n' lexstr (2) = EOS gtok = lexstr (1) return } i = 1 if (type(c) == LETTER) { # alpha for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) ctype = type(c) if (ctype != LETTER & ctype != DIGIT & index(alfchr, c) == 0) break } call putbak (c) gtok = ALPHA } else if (type(c) == DIGIT) { # digits for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) if (type(c) != DIGIT) break } if (c == RADIX) { # n%ddd lexstr(i + 1) = EOS # terminate numeric string n = 1 b = ctoi(lexstr, n) # have base of number } 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 == '[') { # allow [ for { lexstr (1) = '{' gtok = '{' } else if (c == ']') { # allow ] for } lexstr (1) = '}' gtok = '}' } else if (c == '$') { # $( and $) now used by macro processor if (ngetch (lexstr (2)) == '(') { i = 2 gtok = LSTRIPC } else if (lexstr (2) == ')') { i = 2 gtok = RSTRIPC } else { call putbak (lexstr (2)) gtok = '$' } } else if (c == '"' | c == '@'') { # string or character constant gtok = c for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (lexstr(i) == '_') { # see if continuation if (ngetch(c) == '@n') { while (c == '@n' | c == ' ' | c == '@t') c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == '@@') { # keep @ intact if (ngetch(c) == EOF) call putbak(c) else { i = i + 1 if (i >= toksiz - 1) i = toksiz - 1 lexstr(i) = c } c = '@@' } if (c == lexstr(1)) # found terminator break if (lexstr(i) == '@n' | i >= toksiz - 1) { call synerr ("missing quote") lexstr(i) = lexstr(1) call putbak('@n') break } } if (lexstr(1) == '@'') { # character constant n = 2 c = esc(lexstr, n) if (lexstr(n + 1) != '@'') # flag old style string literal call synerr("missing apostrophe in character literal") n = c i = itoc(n, lexstr, toksiz) # convert to characters gtok = DIGIT } } else if (c == '%') { # possible literal quote if (ngetch(lexstr(2)) != '(') { # not literal quote call putbak(lexstr(2)) gtok = '%' } else { gtok = '"' lexstr(1) = LITQUOTEC for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (c == '_') { # possible continuation if (ngetch(c) == '@n') { # YES it is while (c == '@n' | c == ' ' | c == '@t') c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == '%') # are we done? if (ngetch(c) == ')') { # YES lexstr(i) = LITQUOTEC break } else call putbak(c) if (lexstr(i) == '@n' | i >= toksiz - 1) { call synerr("missing literal quote") lexstr(i) = LITQUOTEC call putbak('@n') break } } } } else if (c == LITQUOTEC) { # pushed back literal quote gtok = '"' for (i = 2; ngetch(lexstr(i)) != LITQUOTEC; i = i + 1) ; } else if (c == '#') { # strip comments while (ngetch (lexstr (1)) != '@n') ; gtok = '@n' } else if (c == '>' | c == '<' | c == NOT | c == AND | c == OR | c == '=' | c == '!' | c == '~' | c == '^') { 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 #-t- gtok ascii 01/09/83 12:06:00 #-h- ifcode ascii 01/09/83 12:06:00 # ifcode - generate initial code for if subroutine ifcode (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer labgen ext_subr ifgo xfer = NO lab = labgen (2) call ifgo (lab) return end #-t- ifcode ascii 01/09/83 12:06:00 #-h- ifgo ascii 01/09/83 12:06:00 # ifgo - generate "if (.not.(...))goto lab" subroutine ifgo (lab) integer lab ext_subr outtab, outstr, balpar, outch, outgo string ifnot "if (.not." call outtab # get to column 7 call outstr (ifnot) # " if (.not. " call balpar # collect and output condition call outch (')') # " ) " call outgo (lab) # " goto lab " return end #-t- ifgo ascii 01/09/83 12:06:00 #-h- ifparm ascii 01/09/83 12:06:00 # ifparm - determines if the defined symbol has arguments in its # definition. This effects how the macro is expanded. integer function ifparm (strng) character strng (ARB) character c integer i ext_func integer index ext_func character type c = strng (1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == MACTYPE | c == LENTOKTYPE) 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 #-t- ifparm ascii 01/09/83 12:06:00 #-h- initkw ascii 01/09/83 12:06:00 # initkw - initialize tables and important global variables # this routine assumes that there is no error return from mktabl # entfkw and entrkw assume successful entry of elements in those tables, also subroutine initkw # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func pointer mktabl ext_subr dsinit, entdkw, entrkw, entfkw call dsinit (MEMSIZE) deftbl = mktabl (1) # symbol table for definitions call entdkw rkwtbl = mktabl (1) # symbol table for Ratfor key words call entrkw label = 23000 strcnt = 1 return end #-t- initkw ascii 01/09/83 12:06:00 #-h- inschr ascii 01/09/83 12:06:00 # inschr - put c in buf(bp) if it fits, increment bp subroutine inschr(c, buf, bp, maxsiz) integer bp, maxsiz character c, buf(ARB) ext_subr baderr if (bp > maxsiz) call baderr("buffer overflow") buf(bp) = c bp = bp + 1 return end #-t- inschr ascii 01/09/83 12:06:00 #-h- insdcl ascii 01/09/83 12:06:00 # insdcl - insert declaration information - will be dumped by dmpdcl subroutine insdcl(name, value, c) character name(ARB), value(ARB), c character temp(10) integer strip, dosize, len, junk, first, last, i ext_func integer index, elenth, itoc, length # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) if (value(1) == c) strip = YES else strip = NO dosize = YES # must calculate size if (index(name, '(') > 0 | c == '@'') # size specified by user or char litral dosize = NO call inschr(c, sbuf, sbp, SBUFSIZE) # store type of declaration call insstr(name, sbuf, sbp, SBUFSIZE) # variable name if (dosize == YES) # insert (len) { len = elenth(value) if (strip == YES) len = len - 2 # do not count delimiter if (c == '"') # need location for EOS len = len + 1 call inschr('(', sbuf, sbp, SBUFSIZE) junk = itoc(len, temp, 10) call insstr(temp, sbuf, sbp, SBUFSIZE) call inschr(')', sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) first = 1 last = length(value) if (strip == YES) { first = first + 1 last = last -1 } for (i = first; i <= last; i = i + 1) { call inschr(value(i), sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) return end #-t- insdcl ascii 01/09/83 12:06:00 #-h- insstr ascii 01/09/83 12:06:00 # insstr - put s in buf(bp) by repeated calls to inschr subroutine insstr(s, buf, bp, maxsiz) character s(ARB), buf(ARB) integer bp, maxsiz integer i ext_subr inschr for (i = 1; s(i) != EOS; i=i+1) call inschr(s(i), buf, bp, maxsiz) return end #-t- insstr ascii 01/09/83 12:06:00 #-h- labelc ascii 01/09/83 12:06:00 # labelc - output statement number subroutine labelc (lexstr) character lexstr (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer length ext_subr synerr, outstr, outtab xfer = NO # can't suppress goto's now if (length (lexstr) == 5) # warn about 23xxx labels if (lexstr (1) == '2' & lexstr (2) == '3') call synerr ("warning: possible label conflict") call outstr (lexstr) call outtab return end #-t- labelc ascii 01/09/83 12:06:00 #-h- labgen ascii 01/09/83 12:06:00 # labgen - generate n consecutive labels, return first one integer function labgen (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) labgen = label label = label + n return end #-t- labgen ascii 01/09/83 12:06:00 #-h- lex ascii 01/09/83 12:06:00 # lex - return lexical type of token integer function lex (lexstr) character lexstr (MAXTOK) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gnbtok ext_func integer lookup repeat { lex = gnbtok (lexstr, MAXTOK) if (lex != '@n') break } if (lex == EOF | lex == ';' | lex == '{' | lex == '}') return if (lex == DIGIT) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else { call scopy(lexstr, 1, scrtok, 1) call fold(scrtok) if (lookup (scrtok, lex, rkwtbl) == NO) lex = LEXOTHER } return end #-t- lex ascii 01/09/83 12:06:00 #-h- litral ascii 01/09/83 12:06:00 # litral - process literal Fortran line subroutine litral # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character ngetch ext_subr outdon # Finish off any left-over characters if (outp > 0) call outdon for (outp = 1; ngetch (outbuf (outp)) != '@n'; outp = outp + 1) ; outp = outp - 1 call outdon return end #-t- litral ascii 01/09/83 12:06:00 #-h- locsym ascii 01/09/83 12:06:00 # locsym - locate standard definitions file subroutine locsym(file) character file(FILENAMESIZE) string defns STDEFNS call scopy(defns, 1, file, 1) return end #-t- locsym ascii 01/09/83 12:06:00 #-h- lodsym ascii 01/09/83 12:06:00 # lodsym - load standard definitions file subroutine lodsym(fbuf) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character fbuf(FILENAMESIZE) ext_func integer open ext_subr remark, parse, close call locsym(fbuf) # locate file with standard definitions if (fbuf(1) != EOS) { infile(1) = open(fbuf, READ) if (infile(1) == ERR) call remark("cannot open standard definitions file") else { call parse call close(infile(1)) } } return end #-t- lodsym ascii 01/09/83 12:06:00 #-h- ngetch ascii 01/09/83 12:06:00 # ngetch - get a (possibly pushed back) character character function ngetch (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character getch if (bp > 0) { c = buf(bp) bp = bp - 1 } else { c = getch(c, infile (level) ) if (c == '@n') linect (level) = linect (level) + 1 } return (c) end #-t- ngetch ascii 01/09/83 12:06:00 #-h- otherc ascii 01/09/83 12:06:00 # otherc - output ordinary Fortran statement subroutine otherc (lexstr) character lexstr (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outtab, squash, outstr, eatup, outdon ext_func character type xfer = NO call outtab call outstr (lexstr) call eatup call outdon return end #-t- otherc ascii 01/09/83 12:06:00 #-h- outch ascii 01/09/83 12:06:00 # outch - put one character into output buffer subroutine outch (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outdon if (outp >= 72) # continuation needed call contln outp = outp + 1 outbuf (outp) = c return end #-t- outch ascii 01/09/83 12:06:00 #-h- outcon ascii 01/09/83 12:06:00 # outcon - output "n continue" subroutine outcon (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outnum, outtab, outstr, outdon 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 #-t- outcon ascii 01/09/83 12:06:00 #-h- outdef ascii 01/09/83 12:06:00 # output defined value of string `str' subroutine outdef(str, tok) character str(ARB), tok(MAXTOK), t ext_func character gnbtok call putbak('/') # push back delimiter call pbstr(str) # push back string repeat { t = gnbtok(tok, MAXTOK) if (t == '/') break call outstr(tok) } return end #-t- outdef ascii 01/09/83 12:06:00 #-h- outdon ascii 01/09/83 12:06:00 # outdon - finish off an output line subroutine outdon # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr putlin outbuf (outp + 1) = '@n' outbuf (outp + 2) = EOS call putlin (outbuf, STDOUT) outp = 0 return end #-t- outdon ascii 01/09/83 12:06:00 #-h- outgo ascii 01/09/83 12:06:00 # outgo - output "goto n" subroutine outgo (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outtab, outstr, outnum, outdon string sgoto "goto " if (xfer == YES) return call outtab call outstr (sgoto) call outnum (n) call outdon return end #-t- outgo ascii 01/09/83 12:06:00 #-h- outnum ascii 01/09/83 12:06:00 # outnum - output decimal number subroutine outnum (n) integer n character chars (MAXCHARS) integer i, m ext_subr outch m = iabs (n) i = 0 repeat { i = i + 1 chars (i) = mod (m, 10) + '0' m = m / 10 } until (m == 0 | i >= MAXCHARS) if (n < 0) call outch ('-') for ( ; i > 0; i = i - 1) call outch (chars (i)) return end #-t- outnum ascii 01/09/83 12:06:00 #-h- outstr ascii 01/09/83 12:06:00 # outstr - output string; handles quoted literals subroutine outstr (str) character str (ARB) character varbuf(incr(MAXIDLENGTH)) integer i, n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer qstfix ext_func integer gennam ext_subr outch, outnum, strout string stroot "st" if (str(1) == LITQUOTEC) # literal quoted string for (i = 2; str(i) != LITQUOTEC; i = i + 1) call outch(str(i)) else if (str(1) != '"') # not a quoted string call strout(str, YES) # output string, uppercase if defined else { n = qstfix(str) i = gennam(stroot, strcnt, varbuf) call insdcl(varbuf, str, '"') call strout(varbuf, YES) } return end #-t- outstr ascii 01/09/83 12:06:00 #-h- outtab ascii 01/09/83 12:06:00 # outtab - get past column 6 subroutine outtab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outch while (outp < 6) call outch (' ') return end #-t- outtab ascii 01/09/83 12:06:00 #-h- parse ascii 01/09/83 12:06:00 # parse - parse Ratfor source program subroutine parse # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character lexstr (MAXTOK) integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i ext_func integer lex ext_subr finit, ifcode, docode, whilec, forcod, repcod, swcode, synerr ext_subr cascod, labelc, elseif, litral, baderr, swend , otherc, brknxt ext_subr retcod, strdcl, pbstr, unstak call finit sp = 1 lextyp (1) = EOF repeat { if (sbp > 1) # accumulated declarations? call dmpdcl(lexstr) # output them token = lex (lexstr) if (token == EOF) break if (token == LEXIF) call ifcode (lab) else if (token == LEXDO) call docode (lab) else if (token == LEXWHILE) call whilec (lab) else if (token == LEXFOR) call forcod (lab) else if (token == LEXREPEAT) call repcod (lab) else if (token == LEXSWITCH) call swcode (lab) else if (token == LEXCASE | token == 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) } else if (token == LEXDIGITS) call labelc (lexstr) else if (token == LEXELSE) { if (lextyp (sp) == LEXIF) call elseif (labval (sp)) else call synerr ("illegal else") } else if (token == LEXLITERAL) call litral if (token == LEXIF | token == LEXELSE | token == LEXWHILE | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH | token == LEXDO | token == LEXDIGITS | token == '{') { 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 == '}') { if (lextyp (sp) == '{') sp = sp - 1 else if (lextyp (sp) == LEXSWITCH) { call swend (labval (sp)) sp = sp - 1 } else call synerr ("illegal right brace") } else if (token == LEXOTHER) call otherc (lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt (sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod else if (token == LEXSTRING) call strdcl token = lex (lexstr) # peek at next token call pbstr (lexstr) call unstak (sp, lextyp, labval, token) if (token == EOF) break } } if (sp != 1) call synerr ("unexpected EOF") if (csp > 0) call synerr("conditional processing still active at EOF") if (sbp > 1) # accumulated declarations? call synerr("Accumulated declarations at EOF") return end #-t- parse ascii 01/09/83 12:06:00 #-h- pbnum ascii 01/09/83 12:06:00 # pbnum - convert number to string, push back on input subroutine pbnum (n) integer n integer m, num ext_subr putbak string digits "0123456789" num = abs(n) repeat { m = mod (num, 10) call putbak (digits (m + 1)) num = num / 10 } until (num == 0) if (n < 0) call putbak('-') return end #-t- pbnum ascii 01/09/83 12:06:00 #-h- pbstr ascii 01/09/83 12:06:00 # pbstr - push string back onto input subroutine pbstr (in) character in (ARB) integer i ext_func integer length ext_subr putbak for (i = length (in); i > 0; i = i - 1) call putbak (in (i)) return end #-t- pbstr ascii 01/09/83 12:06:00 #-h- push ascii 01/09/83 12:06:00 # push - push ep onto argstk, return new pointer ap integer function push (ep, argstk, ap) integer ap, argstk (ARGSIZE), ep ext_subr baderr if (ap > ARGSIZE) call baderr ("arg stack overflow") argstk (ap) = ep push = ap + 1 return end #-t- push ascii 01/09/83 12:06:00 #-h- putbak ascii 01/09/83 12:06:00 # putbak - push character back onto input subroutine putbak (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr baderr if (bp >= BUFSIZE) call baderr ("too many characters pushed back") else { bp = bp + 1 buf (bp) = c } return end #-t- putbak ascii 01/09/83 12:06:00 #-h- putchr ascii 01/09/83 12:06:00 # putchr - put single char into eval stack subroutine putchr (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr baderr if (ep > EVALSIZE) call baderr ("evaluation stack overflow") evalst (ep) = c ep = ep + 1 return end #-t- putchr ascii 01/09/83 12:06:00 #-h- puttok ascii 01/09/83 12:06:00 # puttok-put token into eval stack subroutine puttok (str) character str (MAXTOK) integer i ext_subr putchr for (i = 1; str (i) != EOS; i = i + 1) call putchr (str (i)) return end #-t- puttok ascii 01/09/83 12:06:00 #-h- qstfix ascii 01/09/83 12:06:00 # qstfix - fix quoted string # collapses quoted string in the same array, removing first and last quotes # and converting intermediate @" ==> " # returns the length of the string as its value integer function qstfix(str) character str(ARB) integer last, n, i integer length last = length(str) n = 1 for (i = 2; i < last; i = i + 1) { str(n) = str(i) # copy character n = n + 1 } str(n) = EOS return(n-1) end #-t- qstfix ascii 01/09/83 12:06:00 #-h- ratarg ascii 01/09/83 12:06:00 # ratarg - routine to crack command line flags to ratfor subroutine ratarg integer i ext_func integer getarg # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) dosym = YES # load "symbols" by default for (i = 1; getarg(i, scrtok, MAXTOK) != EOF; i = i + 1) if (scrtok(1) == '-' & scrtok(2) != EOS) # found a flag if (scrtok(2) == 'n' | scrtok(2) == 'N') # user does not want ratdef dosym = NO return end #-t- ratarg ascii 01/09/83 12:06:00 #-h- relate ascii 01/09/83 12:06:00 # relate - convert relational shorthands into long form subroutine relate (token, last) character token (ARB) integer last ext_func character ngetch ext_func integer length ext_subr putbak if (ngetch (token (2)) != '=') { call putbak (token (2)) token (3) = 't' } else token (3) = 'e' token (4) = '.' token (5) = EOS token (6) = EOS # for .not. and .and. if (token (1) == '>') token (2) = 'g' else if (token (1) == '<') token (2) = 'l' else if (token (1) == NOT | token(1) == '!' | token(1) == '~' | token(1) == '^') { if (token (2) != '=') { token (3) = 'o' token (4) = 't' token (5) = '.' } token (2) = 'n' } else if (token (1) == '=') { if (token (2) != '=') { token (2) = EOS last = 1 return } token (2) = 'e' token (3) = 'q' } else if (token (1) == AND) { token (2) = 'a' token (3) = 'n' token (4) = 'd' token (5) = '.' } else if (token (1) == OR) { token (2) = 'o' token (3) = 'r' } else # can't happen token (2) = EOS token (1) = '.' last = length (token) return end #-t- relate ascii 01/09/83 12:06:00 #-h- repcod ascii 01/09/83 12:06:00 # repcod - generate code for beginning of repeat subroutine repcod (lab) integer lab ext_func integer labgen ext_subr outcon call outcon (0) # in case there was a label lab = labgen (3) call outcon (lab) lab = lab + 1 # label to go on next's return end #-t- repcod ascii 01/09/83 12:06:00 #-h- retcod ascii 01/09/83 12:06:00 # retcod - generate code for return subroutine retcod # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t ext_func character gnbtok ext_subr pbstr, outtab, scopy, squash, outstr, outch, eatup, outdon string sret "return" t = gnbtok (scrtok, MAXTOK) if (t != '@n' & t != ';' & t != '}') { call pbstr (scrtok) if ( fcname(1) == EOS ) { # we are in a subroutine call synerr("can't give 'return' an argument from a subroutine") call eatup return } call outtab call scopy (fcname, 1, scrtok, 1) call outstr (scrtok) call outch ('=') call eatup call outdon } else if (t == '}') call pbstr (scrtok) call outtab call outstr (sret) call outdon xfer = YES return end #-t- retcod ascii 01/09/83 12:06:00 #-h- skpblk ascii 01/09/83 12:06:00 # skpblk - skip blanks and tabs in current input file subroutine skpblk # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c ext_func character ngetch ext_subr putbak repeat c = ngetch (c) until (c != ' ' & c != '@t') call putbak (c) return end #-t- skpblk ascii 01/09/83 12:06:00 #-h- strdcl ascii 01/09/83 12:06:00 # strdcl - generate code for string declaration subroutine strdcl # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t, dchar (MAXTOK) integer i, j, k, n, len ext_func character gnbtok, esc ext_func integer length, ctoi, lex, elenth ext_subr synerr, squash, outtab, pbstr, outstr, outch, insstr, inschr ext_subr outnum, outdon string char "character" string dat "data " string eoss "EOS" t = gnbtok (scrtok, MAXTOK) if (t != ALPHA) call synerr ("missing string token") if (gnbtok(dchar, MAXTOK) == '(') # user-specified size { call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != DIGIT) call synerr("invalid string size") call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != ')') call synerr("missing right paren") call concat(scrtok, dchar, scrtok) t = gnbtok(dchar, MAXTOK) } call insdcl(scrtok, dchar, '"') return end #-t- strdcl ascii 01/09/83 12:06:00 #-h- strout ascii 01/09/83 12:06:00 # strout - output character array, upper-casing if desired subroutine strout(str, ifup) character str(ARB), c integer ifup, i ext_func character cupper ext_func integer length # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) if ( (length(str) + outp) > 72 ) # don't split keywords call contln for (i = 1; str(i) != EOS; i = i + 1) { c = str(i) if (ifup == YES) c = cupper(c) call outch(c) } return end #-t- strout ascii 01/09/83 12:06:00 #-h- swcode ascii 01/09/83 12:06:00 # swcode - generate code for beginning of switch statement subroutine swcode (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer labgen, gnbtok ext_subr baderr, outtab, swvar , outch, balpar, outdon, outgo, synerr, pbstr string intstr "integer" lab = labgen (2) 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 (lab) call outch ('=') call balpar call outdon call outtab # Integer Innn call outstr (intstr) call outch (' ') call swvar (lab) call outdon call outgo (lab) # goto L xfer = YES while (gnbtok (scrtok, MAXTOK) == '@n') ; if (scrtok (1) != '{') { call synerr ("missing left brace in switch statement") call pbstr (scrtok) } return end #-t- swcode ascii 01/09/83 12:06:00 #-h- swend ascii 01/09/83 12:06:00 # swend - finish off switch statement; generate dispatch code subroutine swend (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer lb, ub, n, i, j ext_subr outgo, outcon, outtab, swvar , outch, outnum, outdon 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." 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 outcon (lab) # L continue if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table if (lb != 1) { # L Innn=Innn-lb+1 call outtab call swvar (lab) call outch ('=') call swvar (lab) if (lb < 1) call outch ('+') call outnum (-lb + 1) call outdon } call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr (sif) call swvar (lab) call outstr (slt) call swvar (lab) call outstr (sgt) call outnum (ub - lb + 1) call outch (')') 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 (',') } 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 (',') } call outch (')') call outch (',') call swvar (lab) 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 (lab) 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 (lab) call outstr (sle) call outnum (swstak (i + 1)) } call outch (')') # ) goto ... call outgo (swstak (i + 2)) } if (lab + 1 != swstak (swtop + 2)) call outgo (swstak (swtop + 2)) } call outcon (lab + 1) # L+1 continue swlast = swtop # pop switch stack swtop = swstak (swtop) return end #-t- swend ascii 01/09/83 12:06:00 #-h- swvar ascii 01/09/83 12:06:00 # swvar - output switch variable Innn, where nnn = lab subroutine swvar (lab) integer lab ext_subr outch, outnum call outch ('I') call outnum (lab) return end #-t- swvar ascii 01/09/83 12:06:00 #-h- synerr ascii 01/09/83 12:06:00 # synerr --- report non-fatal error subroutine synerr (msg) character msg (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character lc (MAXCHARS) integer i, junk ext_func integer itoc ext_subr putlin, putch, remark string in " in " string errmsg "error at line " if (curcnd != C_TRUE) # avoid error messages in non-preprocessed code return 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) { # print file name call putlin (in, ERROUT) call putlin (fnames (i), ERROUT) break } call putch (':', ERROUT) call putch (' ', ERROUT) call remark (msg) return end #-t- synerr ascii 01/09/83 12:06:00 #-h- ulstal ascii 01/09/83 12:06:00 # ulstal - install lower and upper case versions of symbol subroutine ulstal (name, val) character name (ARB), defn (2), val # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr entdef, upper defn (1) = val defn (2) = EOS call entdef (name, defn, deftbl) call upper (name) call entdef (name, defn, deftbl) return end #-t- ulstal ascii 01/09/83 12:06:00 #-h- unstak ascii 01/09/83 12:06:00 # unstak - unstack at end of statement subroutine unstak (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token ext_subr outcon, dostat, whiles, fors, untils for ( ; sp > 1; sp = sp - 1) { if (lextyp (sp) == '{') break if (lextyp (sp) == LEXSWITCH) break if (lextyp (sp) == LEXIF & token == LEXELSE) break if (lextyp (sp) == LEXIF) call outcon (labval (sp)) else if (lextyp (sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon (labval (sp) + 1) } else if (lextyp (sp) == LEXDO) call dostat (labval (sp)) else if (lextyp (sp) == LEXWHILE) call whiles (labval (sp)) else if (lextyp (sp) == LEXFOR) call fors (labval (sp)) else if (lextyp (sp) == LEXREPEAT) call untils (labval (sp), token) } return end #-t- unstak ascii 01/09/83 12:06:00 #-h- untils ascii 01/09/83 12:06:00 # untils - generate code for until or end of repeat subroutine untils (lab, token) integer lab, token # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character ptoken (MAXTOK) integer junk ext_func integer lex ext_subr outnum, ifgo, outgo, outcon xfer = NO call outnum (lab) if (token == LEXUNTIL) { junk = lex (ptoken) call ifgo (lab - 1) } else call outgo (lab - 1) call outcon (lab + 1) return end #-t- untils ascii 01/09/83 12:06:00 #-h- whilec ascii 01/09/83 12:06:00 # whilec - generate code for beginning of while subroutine whilec (lab) integer lab ext_func integer labgen ext_subr outcon, outnum, ifgo call outcon (0) # unlabeled continue, in case there was a label lab = labgen (2) call outnum (lab) call ifgo (lab + 1) return end #-t- whilec ascii 01/09/83 12:06:00 #-h- whiles ascii 01/09/83 12:06:00 # whiles - generate code for end of while subroutine whiles (lab) integer lab ext_subr outgo, outcon call outgo (lab) call outcon (lab + 1) return end #-t- whiles ascii 01/09/83 12:06:00 #-t- ratp1.rat ascii 01/09/84 15:54 #-h- ratp1b2ch.f ascii 01/09/84 15:54 CALL INITST CALL RATFOR CALL ENDST(0) END SUBROUTINE RATFOR INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER I, N INTEGER GETARG, OPEN BYTE ARG (36) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL INITKW INFILE (1) = 1 CALL PARSE RETURN END SUBROUTINE BADERR (MSG) BYTE MSG (100) CALL SYNERR (MSG) CALL ENDST(-3) RETURN END SUBROUTINE BALPAR BYTE T, TOKEN (120) BYTE GETTOK, GNBTOK INTEGER NLPAR BYTE ST001Z(19) BYTE ST002Z(33) DATA ST001Z(1)/109/,ST001Z(2)/105/,ST001Z(3)/115/,ST001Z(4)/115/, *ST001Z(5)/105/,ST001Z(6)/110/,ST001Z(7)/103/,ST001Z(8)/32/,ST001Z( *9)/108/,ST001Z(10)/101/,ST001Z(11)/102/,ST001Z(12)/116/,ST001Z(13) */32/,ST001Z(14)/112/,ST001Z(15)/97/,ST001Z(16)/114/,ST001Z(17)/101 */,ST001Z(18)/110/,ST001Z(19)/0/ DATA ST002Z(1)/109/,ST002Z(2)/105/,ST002Z(3)/115/,ST002Z(4)/115/, *ST002Z(5)/105/,ST002Z(6)/110/,ST002Z(7)/103/,ST002Z(8)/32/,ST002Z( *9)/112/,ST002Z(10)/97/,ST002Z(11)/114/,ST002Z(12)/101/,ST002Z(13)/ *110/,ST002Z(14)/116/,ST002Z(15)/104/,ST002Z(16)/101/,ST002Z(17)/11 *5/,ST002Z(18)/105/,ST002Z(19)/115/,ST002Z(20)/32/,ST002Z(21)/105/, *ST002Z(22)/110/,ST002Z(23)/32/,ST002Z(24)/99/,ST002Z(25)/111/, *ST002Z(26)/110/,ST002Z(27)/100/,ST002Z(28)/105/,ST002Z(29)/116/, *ST002Z(30)/105/,ST002Z(31)/111/,ST002Z(32)/110/,ST002Z(33)/0/ IF (.NOT.(GNBTOK (TOKEN, 120) .NE. 40))GOTO 23000 CALL SYNERR (ST001Z) RETURN 23000 CONTINUE CALL OUTSTR (TOKEN) NLPAR = 1 23002 CONTINUE T = GETTOK (TOKEN, 120) 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) = 0 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 CALL OUTSTR (TOKEN) 23003 IF (.NOT.(NLPAR .LE. 0))GOTO 23002 23004 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23013 CALL SYNERR (ST002Z) 23013 CONTINUE RETURN END SUBROUTINE BRKNXT (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN INTEGER I, N BYTE T INTEGER ALLDIG, CTOI BYTE GNBTOK INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE ST003Z(14) BYTE ST004Z(13) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST003Z(1)/105/,ST003Z(2)/108/,ST003Z(3)/108/,ST003Z(4)/101/, *ST003Z(5)/103/,ST003Z(6)/97/,ST003Z(7)/108/,ST003Z(8)/32/,ST003Z(9 *)/98/,ST003Z(10)/114/,ST003Z(11)/101/,ST003Z(12)/97/,ST003Z(13)/10 *7/,ST003Z(14)/0/ DATA ST004Z(1)/105/,ST004Z(2)/108/,ST004Z(3)/108/,ST004Z(4)/101/, *ST004Z(5)/103/,ST004Z(6)/97/,ST004Z(7)/108/,ST004Z(8)/32/,ST004Z(9 *)/110/,ST004Z(10)/101/,ST004Z(11)/120/,ST004Z(12)/116/,ST004Z(13)/ *0/ N = 0 T = GNBTOK (SCRTOK, 120) IF (.NOT.(ALLDIG (SCRTOK) .EQ. 1))GOTO 23015 I = 1 N = CTOI (SCRTOK, I) - 1 GOTO 23016 23015 CONTINUE IF (.NOT.(T .NE. 59))GOTO 23017 CALL PBSTR (SCRTOK) 23017 CONTINUE 23016 CONTINUE I = SP 23019 IF (.NOT.(I .GT. 0))GOTO 23021 IF (.NOT.(LEXTYP (I) .EQ. -15 .OR. LEXTYP (I) .EQ. -10 .OR. LEXTYP * (I) .EQ. -16 .OR. LEXTYP (I) .EQ. -17))GOTO 23022 IF (.NOT.(N .GT. 0))GOTO 23024 N = N - 1 GOTO 23020 23024 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23026 CALL OUTGO (LABVAL (I) + 1) GOTO 23027 23026 CONTINUE CALL OUTGO (LABVAL (I)) 23027 CONTINUE 23025 CONTINUE XFER = 1 RETURN 23022 CONTINUE 23020 I = I - 1 GOTO 23019 23021 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23028 CALL SYNERR (ST003Z) GOTO 23029 23028 CONTINUE CALL SYNERR (ST004Z) 23029 CONTINUE RETURN END SUBROUTINE CONTLN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE BLSTAR(7) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BLSTAR(1)/32/,BLSTAR(2)/32/,BLSTAR(3)/32/,BLSTAR(4)/32/, *BLSTAR(5)/32/,BLSTAR(6)/42/,BLSTAR(7)/0/ CALL OUTDON CALL SCOPY(BLSTAR, 1, OUTBUF, 1) OUTP = 6 RETURN END BYTE FUNCTION DEFTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE T, C, DEFN (250) INTEGER AP, ARGSTK (100), CALLST (50), NLB, PLEV (50), IFL INTEGER LUDEF, PUSH, IFPARM, ENTER BYTE GCTOK BYTE BALP(3) BYTE ST005Z(20) BYTE ST006Z(14) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ DATA ST005Z(1)/99/,ST005Z(2)/97/,ST005Z(3)/108/,ST005Z(4)/108/, *ST005Z(5)/32/,ST005Z(6)/115/,ST005Z(7)/116/,ST005Z(8)/97/,ST005Z(9 *)/99/,ST005Z(10)/107/,ST005Z(11)/32/,ST005Z(12)/111/,ST005Z(13)/11 *8/,ST005Z(14)/101/,ST005Z(15)/114/,ST005Z(16)/102/,ST005Z(17)/108/ *,ST005Z(18)/111/,ST005Z(19)/119/,ST005Z(20)/0/ DATA ST006Z(1)/69/,ST006Z(2)/79/,ST006Z(3)/70/,ST006Z(4)/32/, *ST006Z(5)/105/,ST006Z(6)/110/,ST006Z(7)/32/,ST006Z(8)/115/,ST006Z( *9)/116/,ST006Z(10)/114/,ST006Z(11)/105/,ST006Z(12)/110/,ST006Z(13) */103/,ST006Z(14)/0/ CP = 0 AP = 1 EP = 1 23030 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -1))GOTO 23033 GOTO 23032 23033 CONTINUE IF (.NOT.(T .EQ. -9))GOTO 23035 IF (.NOT.(LUDEF (TOKEN, DEFN, DEFTBL) .EQ. 0))GOTO 23037 IF (.NOT.(CP .EQ. 0))GOTO 23039 GOTO 23032 23039 CONTINUE CALL PUTTOK (TOKEN) 23040 CONTINUE GOTO 23038 23037 CONTINUE IF (.NOT.(DEFN (1) .EQ. -4))GOTO 23041 CALL GETDEF (TOKEN, TOKSIZ, DEFN, 250) CALL ENTDEF (TOKEN, DEFN, DEFTBL) GOTO 23042 23041 CONTINUE IF (.NOT.(DEFN (1) .EQ. -21))GOTO 23043 CALL GETUND (TOKEN) CALL RMDEF (TOKEN, DEFTBL) GOTO 23044 23043 CONTINUE CP = CP + 1 IF (.NOT.(CP .GT. 50))GOTO 23045 CALL BADERR (ST005Z) 23045 CONTINUE CALLST (CP) = AP AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (DEFN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (TOKEN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. 32))GOTO 23047 T = GCTOK (TOKEN, TOKSIZ) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. 40))GOTO 23049 CALL PUTBAK (32) 23049 CONTINUE GOTO 23048 23047 CONTINUE CALL PBSTR (TOKEN) 23048 CONTINUE IF (.NOT.(T .NE. 40))GOTO 23051 CALL PBSTR (BALP) GOTO 23052 23051 CONTINUE IF (.NOT.(IFPARM (DEFN) .EQ. 0))GOTO 23053 CALL PBSTR (BALP) 23053 CONTINUE 23052 CONTINUE PLEV (CP) = 0 23044 CONTINUE 23042 CONTINUE 23038 CONTINUE GOTO 23036 23035 CONTINUE IF (.NOT.(T .EQ. -10))GOTO 23055 NLB = 1 23057 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -10))GOTO 23060 NLB = NLB + 1 GOTO 23061 23060 CONTINUE IF (.NOT.(T .EQ. -11))GOTO 23062 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0))GOTO 23064 GOTO 23059 23064 CONTINUE GOTO 23063 23062 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23066 CALL BADERR (ST006Z) 23066 CONTINUE 23063 CONTINUE 23061 CONTINUE CALL PUTTOK (TOKEN) 23058 GOTO 23057 23059 CONTINUE GOTO 23056 23055 CONTINUE IF (.NOT.(CP .EQ. 0))GOTO 23068 GOTO 23032 23068 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23070 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23072 CALL PUTTOK (TOKEN) 23072 CONTINUE PLEV (CP) = PLEV (CP) + 1 GOTO 23071 23070 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23074 PLEV (CP) = PLEV (CP) - 1 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23076 CALL PUTTOK (TOKEN) GOTO 23077 23076 CONTINUE CALL PUTCHR (0) CALL EVALR (ARGSTK, CALLST (CP), AP - 1) AP = CALLST (CP) EP = ARGSTK (AP) CP = CP - 1 23077 CONTINUE GOTO 23075 23074 CONTINUE IF (.NOT.(T .EQ. 44 .AND. PLEV (CP) .EQ. 1))GOTO 23078 CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) GOTO 23079 23078 CONTINUE CALL PUTTOK (TOKEN) 23079 CONTINUE 23075 CONTINUE 23071 CONTINUE 23069 CONTINUE 23056 CONTINUE 23036 CONTINUE 23031 GOTO 23030 23032 CONTINUE DEFTOK = T RETURN END SUBROUTINE DMPDCL(TOKEN) BYTE TOKEN(100) INTEGER I, J, N BYTE C INTEGER INDEX BYTE ESC INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE CHAR(10) BYTE COMSTR(7) BYTE DATS(6) BYTE EOSS(4) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA COMSTR(1)/99/,COMSTR(2)/32/,COMSTR(3)/32/,COMSTR(4)/32/, *COMSTR(5)/32/,COMSTR(6)/32/,COMSTR(7)/0/ DATA DATS(1)/100/,DATS(2)/97/,DATS(3)/116/,DATS(4)/97/,DATS(5)/32/ *,DATS(6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ IF (.NOT.(SBP .GT. 1))GOTO 23080 I = 1 23082 IF (.NOT.(I .LT. SBP))GOTO 23084 CALL OUTTAB CALL OUTDEF(CHAR, TOKEN) CALL OUTCH(32) C = SBUF(I) J = 1 I = I + 1 23085 IF (.NOT.(SBUF(I) .NE. 0))GOTO 23087 TOKEN(J) = SBUF(I) J = J + 1 23086 I = I + 1 GOTO 23085 23087 CONTINUE TOKEN(J) = 0 I = I + 1 CALL OUTSTR(TOKEN) CALL OUTDON J = INDEX(TOKEN, 40) IF (.NOT.(J .GT. 0))GOTO 23088 TOKEN(J) = 0 23088 CONTINUE J = 1 23090 CONTINUE IF (.NOT.(SBUF(I) .EQ. 0 .AND. C .EQ. 39))GOTO 23093 GOTO 23092 23093 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23095 CALL OUTTAB CALL OUTSTR(DATS) GOTO 23096 23095 CONTINUE CALL OUTCH(44) 23096 CONTINUE CALL OUTSTR(TOKEN) IF (.NOT.(C .EQ. 34))GOTO 23097 CALL OUTCH(40) CALL OUTNUM(J) CALL OUTCH(41) 23097 CONTINUE CALL OUTCH(47) IF (.NOT.(SBUF(I) .EQ. 0))GOTO 23099 CALL OUTDEF(EOSS, TOKEN) CALL OUTCH(47) GOTO 23092 23099 CONTINUE N = ESC(SBUF, I) CALL OUTNUM(N) CALL OUTCH(47) 23100 CONTINUE J = J + 1 I = I + 1 23091 GOTO 23090 23092 CONTINUE CALL OUTDON 23083 I = I + 1 GOTO 23082 23084 CONTINUE SBP = 1 23080 CONTINUE RETURN END SUBROUTINE DOARTH (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER K, L, ANS, FIRST, SECOND BYTE OP INTEGER CTOI BYTE ST007Z(12) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST007Z(1)/97/,ST007Z(2)/114/,ST007Z(3)/105/,ST007Z(4)/116/, *ST007Z(5)/104/,ST007Z(6)/32/,ST007Z(7)/101/,ST007Z(8)/114/,ST007Z( *9)/114/,ST007Z(10)/111/,ST007Z(11)/114/,ST007Z(12)/0/ K = ARGSTK (I + 2) FIRST = CTOI(EVALST, K) L = ARGSTK (I + 4) SECOND = CTOI(EVALST, L) OP = EVALST (ARGSTK (I + 3)) IF (.NOT.(OP .EQ. 43))GOTO 23101 CALL PBNUM (FIRST + SECOND) GOTO 23102 23101 CONTINUE IF (.NOT.(OP .EQ. 45))GOTO 23103 CALL PBNUM (FIRST - SECOND) GOTO 23104 23103 CONTINUE IF (.NOT.(OP .EQ. 42 ))GOTO 23105 IF (.NOT.(EVALST(ARGSTK(I+3) + 1) .EQ. 42))GOTO 23107 ANS = 1 23109 IF (.NOT.(SECOND .GT. 0))GOTO 23111 ANS = ANS * FIRST 23110 SECOND = SECOND - 1 GOTO 23109 23111 CONTINUE CALL PBNUM(ANS) GOTO 23108 23107 CONTINUE CALL PBNUM (FIRST * SECOND) 23108 CONTINUE GOTO 23106 23105 CONTINUE IF (.NOT.(OP .EQ. 47 ))GOTO 23112 CALL PBNUM (FIRST / SECOND) GOTO 23113 23112 CONTINUE CALL SYNERR (ST007Z) 23113 CONTINUE 23106 CONTINUE 23104 CONTINUE 23102 CONTINUE RETURN END SUBROUTINE DOCODE (LAB) INTEGER LAB INTEGER LABGEN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE GNBTOK BYTE SDO(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR (SDO) CALL OUTCH (32) LAB = LABGEN (2) IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 2))GOTO 23114 CALL OUTSTR (SCRTOK) GOTO 23115 23114 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) 23115 CONTINUE CALL OUTCH (32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOIF (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER A2, A3, A4, A5 INTEGER EQUAL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 5))GOTO 23116 RETURN 23116 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 23118 CALL PBSTR (EVALST (A4)) GOTO 23119 23118 CONTINUE CALL PBSTR (EVALST (A5)) 23119 CONTINUE RETURN END SUBROUTINE DOINCR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER K INTEGER CTOI COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK (I + 2) CALL PBNUM (CTOI (EVALST, K) + 1) RETURN END SUBROUTINE DOLENT(ARGSTK, I, J) INTEGER ARGSTK(100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER K INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK(I + 2) CALL PBNUM(LENGTH(EVALST(K))) RETURN END SUBROUTINE DOMAC (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER A2, A3 BYTE TYPE BYTE ST008Z(34) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST008Z(1)/73/,ST008Z(2)/108/,ST008Z(3)/108/,ST008Z(4)/101/, *ST008Z(5)/103/,ST008Z(6)/97/,ST008Z(7)/108/,ST008Z(8)/32/,ST008Z(9 *)/102/,ST008Z(10)/105/,ST008Z(11)/114/,ST008Z(12)/115/,ST008Z(13)/ *116/,ST008Z(14)/32/,ST008Z(15)/97/,ST008Z(16)/114/,ST008Z(17)/103/ *,ST008Z(18)/117/,ST008Z(19)/109/,ST008Z(20)/101/,ST008Z(21)/110/, *ST008Z(22)/116/,ST008Z(23)/32/,ST008Z(24)/116/,ST008Z(25)/111/, *ST008Z(26)/32/,ST008Z(27)/109/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/101/, *ST008Z(34)/0/ IF (.NOT.(J - I .GT. 2))GOTO 23120 A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) IF (.NOT.(TYPE(EVALST(A2)) .NE. 1))GOTO 23122 CALL SYNERR(ST008Z) GOTO 23123 23122 CONTINUE CALL ENTDEF (EVALST (A2), EVALST (A3), DEFTBL) 23123 CONTINUE 23120 CONTINUE RETURN END SUBROUTINE DOSTAT (LAB) INTEGER LAB CALL OUTCON (LAB) CALL OUTCON (LAB + 1) RETURN END SUBROUTINE DOSUB (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER AP, FC, K, NC INTEGER CTOI, LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 3))GOTO 23124 RETURN 23124 CONTINUE IF (.NOT.(J - I .LT. 4))GOTO 23126 NC = 120 GOTO 23127 23126 CONTINUE K = ARGSTK (I + 4) NC = CTOI (EVALST, K) 23127 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 23128 K = FC + MIN0(NC, LENGTH (EVALST (FC))) - 1 23130 IF (.NOT.(K .GE. FC))GOTO 23132 CALL PUTBAK (EVALST (K)) 23131 K = K - 1 GOTO 23130 23132 CONTINUE 23128 CONTINUE RETURN END BYTE FUNCTION DOTHER(TOKEN) BYTE TOKEN(120), T INTEGER NLPAR BYTE GETTOK BYTE ST009Z(15) DATA ST009Z(1)/117/,ST009Z(2)/110/,ST009Z(3)/101/,ST009Z(4)/120/, *ST009Z(5)/112/,ST009Z(6)/101/,ST009Z(7)/99/,ST009Z(8)/116/,ST009Z( *9)/101/,ST009Z(10)/100/,ST009Z(11)/32/,ST009Z(12)/69/,ST009Z(13)/7 *9/,ST009Z(14)/70/,ST009Z(15)/0/ CALL OUTTAB NLPAR = 0 23133 CONTINUE T = GETTOK(TOKEN, 120) IF (.NOT.(T .EQ. 40))GOTO 23136 NLPAR = NLPAR + 1 GOTO 23137 23136 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23138 NLPAR = NLPAR - 1 23138 CONTINUE 23137 CONTINUE IF (.NOT.(T .EQ. 59 .OR. (T .EQ. 44 .AND. NLPAR .EQ. 0)))GOTO 2314 *0 GOTO 23135 23140 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23142 CALL SYNERR(ST009Z) CALL PBSTR(TOKEN) GOTO 23135 23142 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23144 CALL OUTSTR(TOKEN) 23144 CONTINUE 23134 GOTO 23133 23135 CONTINUE CALL OUTDON DOTHER=(T) RETURN END SUBROUTINE EATUP BYTE PTOKEN (120), T, TOKEN (120) INTEGER NLPAR BYTE GETTOK BYTE ST00AZ(15) BYTE ST00BZ(23) DATA ST00AZ(1)/117/,ST00AZ(2)/110/,ST00AZ(3)/101/,ST00AZ(4)/120/, *ST00AZ(5)/112/,ST00AZ(6)/101/,ST00AZ(7)/99/,ST00AZ(8)/116/,ST00AZ( *9)/101/,ST00AZ(10)/100/,ST00AZ(11)/32/,ST00AZ(12)/69/,ST00AZ(13)/7 *9/,ST00AZ(14)/70/,ST00AZ(15)/0/ DATA ST00BZ(1)/117/,ST00BZ(2)/110/,ST00BZ(3)/98/,ST00BZ(4)/97/, *ST00BZ(5)/108/,ST00BZ(6)/97/,ST00BZ(7)/110/,ST00BZ(8)/99/,ST00BZ(9 *)/101/,ST00BZ(10)/100/,ST00BZ(11)/32/,ST00BZ(12)/112/,ST00BZ(13)/9 *7/,ST00BZ(14)/114/,ST00BZ(15)/101/,ST00BZ(16)/110/,ST00BZ(17)/116/ *,ST00BZ(18)/104/,ST00BZ(19)/101/,ST00BZ(20)/115/,ST00BZ(21)/101/, *ST00BZ(22)/115/,ST00BZ(23)/0/ NLPAR = 0 23146 CONTINUE T = GETTOK (TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23149 GOTO 23148 23149 CONTINUE IF (.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23151 CALL PBSTR (TOKEN) GOTO 23148 23151 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23153 CALL SYNERR (ST00AZ) CALL PBSTR (TOKEN) GOTO 23148 23153 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 *.OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. *T .EQ. 33 .OR. T .EQ. 126 .OR. T .EQ. 94 .OR. T .EQ. 61))GOTO 2315 *5 23157 IF (.NOT.(GETTOK (PTOKEN, 120) .EQ. 10))GOTO 23158 GOTO 23157 23158 CONTINUE CALL PBSTR (PTOKEN) 23155 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23159 NLPAR = NLPAR + 1 GOTO 23160 23159 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23161 NLPAR = NLPAR - 1 23161 CONTINUE 23160 CONTINUE CALL OUTSTR (TOKEN) 23147 IF (.NOT.(NLPAR .LT. 0))GOTO 23146 23148 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23163 CALL SYNERR (ST00BZ) 23163 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) BYTE BUF(100), C INTEGER I, N BYTE ESC N = 0 I=1 23165 IF (.NOT.(BUF(I) .NE. 0))GOTO 23167 C = ESC(BUF, I) N = N + 1 23166 I=I+1 GOTO 23165 23167 CONTINUE ELENTH = N RETURN END SUBROUTINE ELSEIF (LAB) INTEGER LAB CALL OUTGO (LAB+1) CALL OUTCON (LAB) RETURN END SUBROUTINE ENTDKW BYTE DEFNAM(7) BYTE MACNAM(8) BYTE INCNAM(5) BYTE SUBNAM(7) BYTE IFNAM(7) BYTE ARNAM(6) BYTE UNDEFN(9) BYTE LINKNM(8) BYTE LENTNM(7) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/, *DEFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/0/ DATA MACNAM(1)/109/,MACNAM(2)/100/,MACNAM(3)/101/,MACNAM(4)/102/, *MACNAM(5)/105/,MACNAM(6)/110/,MACNAM(7)/101/,MACNAM(8)/0/ DATA INCNAM(1)/105/,INCNAM(2)/110/,INCNAM(3)/99/,INCNAM(4)/114/, *INCNAM(5)/0/ DATA SUBNAM(1)/115/,SUBNAM(2)/117/,SUBNAM(3)/98/,SUBNAM(4)/115/, *SUBNAM(5)/116/,SUBNAM(6)/114/,SUBNAM(7)/0/ DATA IFNAM(1)/105/,IFNAM(2)/102/,IFNAM(3)/101/,IFNAM(4)/108/,IFNAM *(5)/115/,IFNAM(6)/101/,IFNAM(7)/0/ DATA ARNAM(1)/97/,ARNAM(2)/114/,ARNAM(3)/105/,ARNAM(4)/116/,ARNAM( *5)/104/,ARNAM(6)/0/ DATA UNDEFN(1)/117/,UNDEFN(2)/110/,UNDEFN(3)/100/,UNDEFN(4)/101/, *UNDEFN(5)/102/,UNDEFN(6)/105/,UNDEFN(7)/110/,UNDEFN(8)/101/,UNDEFN *(9)/0/ DATA LINKNM(1)/108/,LINKNM(2)/105/,LINKNM(3)/110/,LINKNM(4)/107/, *LINKNM(5)/97/,LINKNM(6)/103/,LINKNM(7)/101/,LINKNM(8)/0/ DATA LENTNM(1)/108/,LENTNM(2)/101/,LENTNM(3)/110/,LENTNM(4)/116/, *LENTNM(5)/111/,LENTNM(6)/107/,LENTNM(7)/0/ CALL ULSTAL (DEFNAM, -4) CALL ULSTAL (MACNAM, -10) CALL ULSTAL (INCNAM, -12) CALL ULSTAL (SUBNAM, -13) CALL ULSTAL (IFNAM, -11) CALL ULSTAL (ARNAM, -14) CALL ULSTAL (UNDEFN, -21) CALL ULSTAL(LINKNM, -4) CALL ULSTAL(LENTNM, -23) RETURN END SUBROUTINE ENTRKW INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER JUNK INTEGER ENTER BYTE SIF(3) BYTE SELSE(5) BYTE SWHILE(6) BYTE SDO(3) BYTE SBREAK(6) BYTE SNEXT(5) BYTE SFOR(4) BYTE SREPT(7) BYTE SUNTIL(6) BYTE SRET(7) BYTE SSTR(7) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/0/ DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE *(5)/0/ DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/, *SWHILE(5)/101/,SWHILE(6)/0/ DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/, *SBREAK(5)/107/,SBREAK(6)/0/ DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT *(5)/0/ DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/0/ DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT *(5)/97/,SREPT(6)/116/,SREPT(7)/0/ DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/, *SUNTIL(5)/108/,SUNTIL(6)/0/ DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1 *10/,SSTR(6)/103/,SSTR(7)/0/ JUNK = ENTER (SIF, -19, RKWTBL) JUNK = ENTER (SELSE, -11, RKWTBL) JUNK = ENTER (SWHILE, -15, RKWTBL) JUNK = ENTER (SDO, -10, RKWTBL) JUNK = ENTER (SBREAK, -8, RKWTBL) JUNK = ENTER (SNEXT, -13, RKWTBL) JUNK = ENTER (SFOR, -16, RKWTBL) JUNK = ENTER (SREPT, -17, RKWTBL) JUNK = ENTER (SUNTIL, -18, RKWTBL) JUNK = ENTER (SRET, -20, RKWTBL) JUNK = ENTER (SSTR, -23, RKWTBL) RETURN END SUBROUTINE EVALR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER ARGNO, K, M, N, T, TD INTEGER INDEX, LENGTH BYTE DIGITS(11) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ T = ARGSTK (I) TD = EVALST (T) IF (.NOT.(TD .EQ. -10))GOTO 23168 CALL DOMAC (ARGSTK, I, J) GOTO 23169 23168 CONTINUE IF (.NOT.(TD .EQ. -12))GOTO 23170 CALL DOINCR (ARGSTK, I, J) GOTO 23171 23170 CONTINUE IF (.NOT.(TD .EQ. -13))GOTO 23172 CALL DOSUB (ARGSTK, I, J) GOTO 23173 23172 CONTINUE IF (.NOT.(TD .EQ. -11))GOTO 23174 CALL DOIF (ARGSTK, I, J) GOTO 23175 23174 CONTINUE IF (.NOT.(TD .EQ. -14))GOTO 23176 CALL DOARTH (ARGSTK, I, J) GOTO 23177 23176 CONTINUE IF (.NOT.(TD .EQ. -23))GOTO 23178 CALL DOLENT (ARGSTK, I, J) GOTO 23179 23178 CONTINUE K = T + LENGTH (EVALST (T)) - 1 23180 IF (.NOT.(K .GT. T))GOTO 23182 IF (.NOT.(EVALST (K - 1) .NE. 36))GOTO 23183 CALL PUTBAK (EVALST (K)) GOTO 23184 23183 CONTINUE ARGNO = INDEX (DIGITS, EVALST (K)) - 1 IF (.NOT.(ARGNO .GE. 0))GOTO 23185 IF (.NOT.(ARGNO .LT. J - I))GOTO 23187 N = I + ARGNO + 1 M = ARGSTK (N) CALL PBSTR (EVALST (M)) 23187 CONTINUE K = K - 1 GOTO 23186 23185 CONTINUE CALL PUTBAK (EVALST (K)) 23186 CONTINUE 23184 CONTINUE 23181 K = K - 1 GOTO 23180 23182 CONTINUE IF (.NOT.(K .EQ. T))GOTO 23189 CALL PUTBAK (EVALST (K)) 23189 CONTINUE 23179 CONTINUE 23177 CONTINUE 23175 CONTINUE 23173 CONTINUE 23171 CONTINUE 23169 CONTINUE RETURN END SUBROUTINE FCLAUS BYTE TOKEN(120), T BYTE GNBTOK, DOTHER 23191 CONTINUE T = GNBTOK(TOKEN, 120) CALL PBSTR(TOKEN) T = DOTHER(TOKEN) 23192 IF (.NOT.(T .EQ. 59 .OR. T .EQ. -1))GOTO 23191 23193 CONTINUE RETURN END SUBROUTINE FINIT INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTP = 0 LEVEL = 1 LINECT (1) = 1 SBP = 1 FNAMP = 2 FNAMES (1) = 0 BP = 0 FORDEP = 0 FCNAME (1) = 0 CSP = 0 CURCND = 1 RETURN END SUBROUTINE FORCOD (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE T INTEGER I, J, NLPAR, LEN BYTE GETTOK, GNBTOK INTEGER LENGTH, LABGEN BYTE IFNOT(10) BYTE SEMI(2) BYTE ST00CZ(19) BYTE ST00DZ(19) BYTE ST00EZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ DATA SEMI(1)/59/,SEMI(2)/0/ DATA ST00CZ(1)/109/,ST00CZ(2)/105/,ST00CZ(3)/115/,ST00CZ(4)/115/, *ST00CZ(5)/105/,ST00CZ(6)/110/,ST00CZ(7)/103/,ST00CZ(8)/32/,ST00CZ( *9)/108/,ST00CZ(10)/101/,ST00CZ(11)/102/,ST00CZ(12)/116/,ST00CZ(13) */32/,ST00CZ(14)/112/,ST00CZ(15)/97/,ST00CZ(16)/114/,ST00CZ(17)/101 */,ST00CZ(18)/110/,ST00CZ(19)/0/ DATA ST00DZ(1)/105/,ST00DZ(2)/110/,ST00DZ(3)/118/,ST00DZ(4)/97/, *ST00DZ(5)/108/,ST00DZ(6)/105/,ST00DZ(7)/100/,ST00DZ(8)/32/,ST00DZ( *9)/102/,ST00DZ(10)/111/,ST00DZ(11)/114/,ST00DZ(12)/32/,ST00DZ(13)/ *99/,ST00DZ(14)/108/,ST00DZ(15)/97/,ST00DZ(16)/117/,ST00DZ(17)/115/ *,ST00DZ(18)/101/,ST00DZ(19)/0/ DATA ST00EZ(1)/102/,ST00EZ(2)/111/,ST00EZ(3)/114/,ST00EZ(4)/32/, *ST00EZ(5)/99/,ST00EZ(6)/108/,ST00EZ(7)/97/,ST00EZ(8)/117/,ST00EZ(9 *)/115/,ST00EZ(10)/101/,ST00EZ(11)/32/,ST00EZ(12)/116/,ST00EZ(13)/1 *11/,ST00EZ(14)/111/,ST00EZ(15)/32/,ST00EZ(16)/108/,ST00EZ(17)/111/ *,ST00EZ(18)/110/,ST00EZ(19)/103/,ST00EZ(20)/0/ LAB = LABGEN (3) CALL OUTCON (0) IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 40))GOTO 23194 CALL SYNERR (ST00CZ) RETURN 23194 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 59))GOTO 23196 CALL PBSTR (SCRTOK) CALL FCLAUS 23196 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 59))GOTO 23198 CALL OUTCON (LAB) GOTO 23199 23198 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) CALL OUTTAB CALL OUTSTR (IFNOT) CALL OUTCH (40) NLPAR = 0 23200 IF (.NOT.(NLPAR .GE. 0))GOTO 23201 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 59))GOTO 23202 GOTO 23201 23202 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23204 NLPAR = NLPAR + 1 GOTO 23205 23204 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23206 NLPAR = NLPAR - 1 23206 CONTINUE 23205 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23208 CALL PBSTR (SCRTOK) RETURN 23208 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23210 CALL OUTSTR (SCRTOK) 23210 CONTINUE GOTO 23200 23201 CONTINUE CALL OUTCH (41) CALL OUTCH (41) CALL OUTGO (LAB+2) IF (.NOT.(NLPAR .LT. 0))GOTO 23212 CALL SYNERR (ST00DZ) 23212 CONTINUE 23199 CONTINUE FORDEP = FORDEP + 1 LEN = 0 J = 1 I = 1 23214 IF (.NOT.(I .LT. FORDEP))GOTO 23216 J = J + LENGTH (FORSTK (J)) + 1 23215 I = I + 1 GOTO 23214 23216 CONTINUE FORSTK (J) = 0 NLPAR = 0 T = GNBTOK (SCRTOK, 120) CALL PBSTR (SCRTOK) 23217 IF (.NOT.(NLPAR .GE. 0))GOTO 23218 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 40))GOTO 23219 NLPAR = NLPAR + 1 GOTO 23220 23219 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23221 NLPAR = NLPAR - 1 23221 CONTINUE 23220 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23223 CALL PBSTR (SCRTOK) GOTO 23218 23223 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10))GOTO 23225 IF (.NOT.(J + LENGTH (SCRTOK) .GE. 300))GOTO 23227 CALL BADERR (ST00EZ) 23227 CONTINUE CALL SCOPY (SCRTOK, 1, FORSTK, J) J = J + LENGTH (SCRTOK) LEN = LEN + LENGTH (SCRTOK) 23225 CONTINUE GOTO 23217 23218 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER I, J INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) J = 1 I = 1 23229 IF (.NOT.(I .LT. FORDEP))GOTO 23231 J = J + LENGTH (FORSTK (J)) + 1 23230 I = I + 1 GOTO 23229 23231 CONTINUE IF (.NOT.(LENGTH (FORSTK (J)) .GT. 0))GOTO 23232 CALL PUTBAK (59) CALL PBSTR (FORSTK (J)) CALL FCLAUS 23232 CONTINUE CALL OUTGO (LAB - 1) CALL OUTCON (LAB + 1) FORDEP = FORDEP - 1 RETURN END BYTE FUNCTION GCTOK(TOKEN, TOKSIZ) BYTE TOKEN(120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE TEMP(9) INTEGER CTYPE, I, N, J, CNDVAL(4), NEWCND, VALUE BYTE GTOK INTEGER EQUAL, LOOKUP BYTE LETTS(5) BYTE CNDTBL(31) BYTE ST00FZ(27) BYTE ST00GZ(31) BYTE ST00HZ(27) BYTE ST00IZ(26) BYTE ST00JZ(27) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA LETTS(1)/101/,LETTS(2)/69/,LETTS(3)/105/,LETTS(4)/73/,LETTS(5 *)/0/ DATA CNDTBL(1)/105/,CNDTBL(2)/102/,CNDTBL(3)/100/,CNDTBL(4)/101/, *CNDTBL(5)/102/,CNDTBL(6)/47/,CNDTBL(7)/105/,CNDTBL(8)/102/,CNDTBL( *9)/110/,CNDTBL(10)/111/,CNDTBL(11)/116/,CNDTBL(12)/100/,CNDTBL(13) */101/,CNDTBL(14)/102/,CNDTBL(15)/47/,CNDTBL(16)/101/,CNDTBL(17)/10 *8/,CNDTBL(18)/115/,CNDTBL(19)/101/,CNDTBL(20)/100/,CNDTBL(21)/101/ *,CNDTBL(22)/102/,CNDTBL(23)/47/,CNDTBL(24)/101/,CNDTBL(25)/110/, *CNDTBL(26)/100/,CNDTBL(27)/100/,CNDTBL(28)/101/,CNDTBL(29)/102/, *CNDTBL(30)/47/,CNDTBL(31)/0/ DATA CNDVAL(1)/-15/, CNDVAL(2)/-16/, CNDVAL(3)/-17/, CNDVAL(4)/-18 */ DATA ST00FZ(1)/73/,ST00FZ(2)/108/,ST00FZ(3)/108/,ST00FZ(4)/101/, *ST00FZ(5)/103/,ST00FZ(6)/97/,ST00FZ(7)/108/,ST00FZ(8)/32/,ST00FZ(9 *)/101/,ST00FZ(10)/110/,ST00FZ(11)/100/,ST00FZ(12)/100/,ST00FZ(13)/ *101/,ST00FZ(14)/102/,ST00FZ(15)/32/,ST00FZ(16)/101/,ST00FZ(17)/110 */,ST00FZ(18)/99/,ST00FZ(19)/111/,ST00FZ(20)/117/,ST00FZ(21)/110/, *ST00FZ(22)/116/,ST00FZ(23)/101/,ST00FZ(24)/114/,ST00FZ(25)/101/, *ST00FZ(26)/100/,ST00FZ(27)/0/ DATA ST00GZ(1)/67/,ST00GZ(2)/111/,ST00GZ(3)/110/,ST00GZ(4)/100/, *ST00GZ(5)/105/,ST00GZ(6)/116/,ST00GZ(7)/105/,ST00GZ(8)/111/,ST00GZ *(9)/110/,ST00GZ(10)/97/,ST00GZ(11)/108/,ST00GZ(12)/115/,ST00GZ(13) */32/,ST00GZ(14)/110/,ST00GZ(15)/101/,ST00GZ(16)/115/,ST00GZ(17)/11 *6/,ST00GZ(18)/101/,ST00GZ(19)/100/,ST00GZ(20)/32/,ST00GZ(21)/116/, *ST00GZ(22)/111/,ST00GZ(23)/111/,ST00GZ(24)/32/,ST00GZ(25)/100/, *ST00GZ(26)/101/,ST00GZ(27)/101/,ST00GZ(28)/112/,ST00GZ(29)/108/, *ST00GZ(30)/121/,ST00GZ(31)/0/ DATA ST00HZ(1)/109/,ST00HZ(2)/105/,ST00HZ(3)/115/,ST00HZ(4)/115/, *ST00HZ(5)/105/,ST00HZ(6)/110/,ST00HZ(7)/103/,ST00HZ(8)/32/,ST00HZ( *9)/96/,ST00HZ(10)/40/,ST00HZ(11)/39/,ST00HZ(12)/32/,ST00HZ(13)/105 */,ST00HZ(14)/110/,ST00HZ(15)/32/,ST00HZ(16)/99/,ST00HZ(17)/111/, *ST00HZ(18)/110/,ST00HZ(19)/100/,ST00HZ(20)/105/,ST00HZ(21)/116/, *ST00HZ(22)/105/,ST00HZ(23)/111/,ST00HZ(24)/110/,ST00HZ(25)/97/, *ST00HZ(26)/108/,ST00HZ(27)/0/ DATA ST00IZ(1)/105/,ST00IZ(2)/110/,ST00IZ(3)/118/,ST00IZ(4)/97/, *ST00IZ(5)/108/,ST00IZ(6)/105/,ST00IZ(7)/100/,ST00IZ(8)/32/,ST00IZ( *9)/99/,ST00IZ(10)/111/,ST00IZ(11)/110/,ST00IZ(12)/100/,ST00IZ(13)/ *105/,ST00IZ(14)/116/,ST00IZ(15)/105/,ST00IZ(16)/111/,ST00IZ(17)/11 *0/,ST00IZ(18)/97/,ST00IZ(19)/108/,ST00IZ(20)/32/,ST00IZ(21)/116/, *ST00IZ(22)/111/,ST00IZ(23)/107/,ST00IZ(24)/101/,ST00IZ(25)/110/, *ST00IZ(26)/0/ DATA ST00JZ(1)/109/,ST00JZ(2)/105/,ST00JZ(3)/115/,ST00JZ(4)/115/, *ST00JZ(5)/105/,ST00JZ(6)/110/,ST00JZ(7)/103/,ST00JZ(8)/32/,ST00JZ( *9)/96/,ST00JZ(10)/41/,ST00JZ(11)/39/,ST00JZ(12)/32/,ST00JZ(13)/105 */,ST00JZ(14)/110/,ST00JZ(15)/32/,ST00JZ(16)/99/,ST00JZ(17)/111/, *ST00JZ(18)/110/,ST00JZ(19)/100/,ST00JZ(20)/105/,ST00JZ(21)/116/, *ST00JZ(22)/105/,ST00JZ(23)/111/,ST00JZ(24)/110/,ST00JZ(25)/97/, *ST00JZ(26)/108/,ST00JZ(27)/0/ 23234 CONTINUE GCTOK = GTOK (TOKEN, TOKSIZ) IF (.NOT.(GCTOK .EQ. -1))GOTO 23237 GOTO 23236 23237 CONTINUE CTYPE = -19 I = 1 23239 IF (.NOT.(LETTS(I) .NE. 0))GOTO 23241 IF (.NOT.(LETTS(I) .EQ. TOKEN(1)))GOTO 23242 GOTO 23241 23242 CONTINUE 23240 I = I + 1 GOTO 23239 23241 CONTINUE IF (.NOT.(LETTS(I) .NE. 0))GOTO 23244 N = 1 I = 1 23246 IF (.NOT.(CNDTBL(I) .NE. 0))GOTO 23248 J = 1 23249 IF (.NOT.(CNDTBL(I) .NE. 47))GOTO 23251 TEMP(J) = CNDTBL(I) I = I + 1 23250 J = J + 1 GOTO 23249 23251 CONTINUE TEMP(J) = 0 J = EQUAL(TOKEN, TEMP) IF (.NOT.(J .EQ. 0))GOTO 23252 CALL UPPER(TEMP) J = EQUAL(TOKEN, TEMP) 23252 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23254 CTYPE = CNDVAL(N) GOTO 23248 23254 CONTINUE N = N + 1 23247 I = I + 1 GOTO 23246 23248 CONTINUE 23244 CONTINUE IF (.NOT.(CTYPE .EQ. -19))GOTO 23256 IF (.NOT.(CURCND .EQ. 1))GOTO 23258 GOTO 23236 23258 CONTINUE GOTO 23257 23256 CONTINUE IF (.NOT.(CTYPE .EQ. -18))GOTO 23260 IF (.NOT.(CSP .LE. 0))GOTO 23262 CALL BADERR(ST00FZ) 23262 CONTINUE CURCND = CNDSTK(CSP) CSP = CSP - 1 GOTO 23261 23260 CONTINUE IF (.NOT.(CTYPE .EQ. -17))GOTO 23264 NEWCND = - CURCND GOTO 23265 23264 CONTINUE IF (.NOT.(CSP .GE. 10))GOTO 23266 CALL BADERR(ST00GZ) 23266 CONTINUE CSP = CSP + 1 CNDSTK(CSP) = CURCND CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 40))GOTO 23268 CALL BADERR(ST00HZ) 23268 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. -9))GOTO 23270 CALL BADERR(ST00IZ) 23270 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 41))GOTO 23272 CALL BADERR(ST00JZ) 23272 CONTINUE IF (.NOT.(LOOKUP(TOKEN, VALUE, DEFTBL) .EQ. 1))GOTO 23274 NEWCND = 1 GOTO 23275 23274 CONTINUE NEWCND = - 1 23275 CONTINUE IF (.NOT.(CTYPE .EQ. -16))GOTO 23276 NEWCND = - NEWCND 23276 CONTINUE 23265 CONTINUE CURCND = MIN0(NEWCND, CNDSTK (CSP) ) 23261 CONTINUE 23257 CONTINUE 23235 GOTO 23234 23236 CONTINUE RETURN END INTEGER FUNCTION GENNAM(ROOT, COUNTR, BUF) BYTE ROOT(100), BUF(7), TEMP(4) INTEGER COUNTR, X, I, D, J BYTE DIGITS(31) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/0/ X = COUNTR COUNTR = COUNTR + 1 IF (.NOT.(COUNTR .GT. 27000))GOTO 23278 COUNTR = 1 23278 CONTINUE I = 1 23280 IF (.NOT.(X .GT. 0))GOTO 23282 D = MOD(X, 30) + 1 TEMP(I) = DIGITS(D) X = X / 30 23281 I = I + 1 GOTO 23280 23282 CONTINUE TEMP(I) = 0 J = 1 CALL INSSTR(ROOT, BUF, J, 6) X = 4 - I 23283 IF (.NOT.(X .GT. 0))GOTO 23285 CALL INSCHR(48, BUF, J, 6) 23284 X = X - 1 GOTO 23283 23285 CONTINUE I = I - 1 23286 IF (.NOT.(I .GT. 0))GOTO 23288 CALL INSCHR(TEMP(I), BUF, J, 6) 23287 I = I - 1 GOTO 23286 23288 CONTINUE CALL INSCHR(122, BUF, J, 6) BUF(J) = 0 GENNAM=(J-1) RETURN END SUBROUTINE GETDEF (TOKEN, TOKSIZ, DEFN, DEFSIZ) BYTE TOKEN (120), DEFN (250) INTEGER TOKSIZ, DEFSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE C, T, PTOKEN (120) INTEGER I, NLPAR BYTE GCTOK, NGETCH BYTE ST00KZ(22) BYTE ST00LZ(20) BYTE ST00MZ(24) BYTE ST00NZ(20) BYTE ST00OZ(20) BYTE ST00PZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST00KZ(1)/110/,ST00KZ(2)/111/,ST00KZ(3)/110/,ST00KZ(4)/45/, *ST00KZ(5)/97/,ST00KZ(6)/108/,ST00KZ(7)/112/,ST00KZ(8)/104/,ST00KZ( *9)/97/,ST00KZ(10)/110/,ST00KZ(11)/117/,ST00KZ(12)/109/,ST00KZ(13)/ *101/,ST00KZ(14)/114/,ST00KZ(15)/105/,ST00KZ(16)/99/,ST00KZ(17)/32/ *,ST00KZ(18)/110/,ST00KZ(19)/97/,ST00KZ(20)/109/,ST00KZ(21)/101/, *ST00KZ(22)/0/ DATA ST00LZ(1)/100/,ST00LZ(2)/101/,ST00LZ(3)/102/,ST00LZ(4)/105/, *ST00LZ(5)/110/,ST00LZ(6)/105/,ST00LZ(7)/116/,ST00LZ(8)/105/,ST00LZ *(9)/111/,ST00LZ(10)/110/,ST00LZ(11)/32/,ST00LZ(12)/116/,ST00LZ(13) */111/,ST00LZ(14)/111/,ST00LZ(15)/32/,ST00LZ(16)/108/,ST00LZ(17)/11 *1/,ST00LZ(18)/110/,ST00LZ(19)/103/,ST00LZ(20)/0/ DATA ST00MZ(1)/109/,ST00MZ(2)/105/,ST00MZ(3)/115/,ST00MZ(4)/115/, *ST00MZ(5)/105/,ST00MZ(6)/110/,ST00MZ(7)/103/,ST00MZ(8)/32/,ST00MZ( *9)/99/,ST00MZ(10)/111/,ST00MZ(11)/109/,ST00MZ(12)/109/,ST00MZ(13)/ *97/,ST00MZ(14)/32/,ST00MZ(15)/105/,ST00MZ(16)/110/,ST00MZ(17)/32/, *ST00MZ(18)/100/,ST00MZ(19)/101/,ST00MZ(20)/102/,ST00MZ(21)/105/, *ST00MZ(22)/110/,ST00MZ(23)/101/,ST00MZ(24)/0/ DATA ST00NZ(1)/100/,ST00NZ(2)/101/,ST00NZ(3)/102/,ST00NZ(4)/105/, *ST00NZ(5)/110/,ST00NZ(6)/105/,ST00NZ(7)/116/,ST00NZ(8)/105/,ST00NZ *(9)/111/,ST00NZ(10)/110/,ST00NZ(11)/32/,ST00NZ(12)/116/,ST00NZ(13) */111/,ST00NZ(14)/111/,ST00NZ(15)/32/,ST00NZ(16)/108/,ST00NZ(17)/11 *1/,ST00NZ(18)/110/,ST00NZ(19)/103/,ST00NZ(20)/0/ DATA ST00OZ(1)/109/,ST00OZ(2)/105/,ST00OZ(3)/115/,ST00OZ(4)/115/, *ST00OZ(5)/105/,ST00OZ(6)/110/,ST00OZ(7)/103/,ST00OZ(8)/32/,ST00OZ( *9)/114/,ST00OZ(10)/105/,ST00OZ(11)/103/,ST00OZ(12)/104/,ST00OZ(13) */116/,ST00OZ(14)/32/,ST00OZ(15)/112/,ST00OZ(16)/97/,ST00OZ(17)/114 */,ST00OZ(18)/101/,ST00OZ(19)/110/,ST00OZ(20)/0/ DATA ST00PZ(1)/103/,ST00PZ(2)/101/,ST00PZ(3)/116/,ST00PZ(4)/100/, *ST00PZ(5)/101/,ST00PZ(6)/102/,ST00PZ(7)/32/,ST00PZ(8)/105/,ST00PZ( *9)/115/,ST00PZ(10)/32/,ST00PZ(11)/99/,ST00PZ(12)/111/,ST00PZ(13)/1 *10/,ST00PZ(14)/102/,ST00PZ(15)/117/,ST00PZ(16)/115/,ST00PZ(17)/101 */,ST00PZ(18)/100/,ST00PZ(19)/0/ CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(C .EQ. 40))GOTO 23289 T = 40 GOTO 23290 23289 CONTINUE T = 32 CALL PBSTR (PTOKEN) 23290 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK (TOKEN, TOKSIZ) .NE. -9))GOTO 23291 CALL BADERR (ST00KZ) 23291 CONTINUE CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(T .EQ. 32))GOTO 23293 CALL PBSTR (PTOKEN) I = 1 23295 CONTINUE C = NGETCH (C) IF (.NOT.(I .GT. DEFSIZ))GOTO 23298 CALL BADERR (ST00LZ) 23298 CONTINUE DEFN (I) = C I = I + 1 23296 IF (.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23295 23297 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23300 CALL PUTBAK (C) 23300 CONTINUE GOTO 23294 23293 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23302 IF (.NOT.(C .NE. 44))GOTO 23304 CALL BADERR (ST00MZ) 23304 CONTINUE NLPAR = 0 I = 1 23306 IF (.NOT.(NLPAR .GE. 0))GOTO 23308 IF (.NOT.(I .GT. DEFSIZ))GOTO 23309 CALL BADERR (ST00NZ) GOTO 23310 23309 CONTINUE IF (.NOT.(NGETCH (DEFN (I)) .EQ. -1))GOTO 23311 CALL BADERR (ST00OZ) GOTO 23312 23311 CONTINUE IF (.NOT.(DEFN (I) .EQ. 40))GOTO 23313 NLPAR = NLPAR + 1 GOTO 23314 23313 CONTINUE IF (.NOT.(DEFN (I) .EQ. 41))GOTO 23315 NLPAR = NLPAR - 1 23315 CONTINUE 23314 CONTINUE 23312 CONTINUE 23310 CONTINUE 23307 I = I + 1 GOTO 23306 23308 CONTINUE GOTO 23303 23302 CONTINUE CALL BADERR (ST00PZ) 23303 CONTINUE 23294 CONTINUE DEFN (I - 1) = 0 RETURN END BYTE FUNCTION GETTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER I, LEN BYTE NAME (36), T, TBUF(9) INTEGER EQUAL, OPEN, LENGTH BYTE DEFTOK BYTE FNCN(9) BYTE INCL(8) BYTE ST00QZ(22) BYTE ST00RZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11 *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/0/ DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11 *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/0/ DATA ST00QZ(1)/109/,ST00QZ(2)/105/,ST00QZ(3)/115/,ST00QZ(4)/115/, *ST00QZ(5)/105/,ST00QZ(6)/110/,ST00QZ(7)/103/,ST00QZ(8)/32/,ST00QZ( *9)/102/,ST00QZ(10)/117/,ST00QZ(11)/110/,ST00QZ(12)/99/,ST00QZ(13)/ *116/,ST00QZ(14)/105/,ST00QZ(15)/111/,ST00QZ(16)/110/,ST00QZ(17)/32 */,ST00QZ(18)/110/,ST00QZ(19)/97/,ST00QZ(20)/109/,ST00QZ(21)/101/, *ST00QZ(22)/0/ DATA ST00RZ(1)/99/,ST00RZ(2)/97/,ST00RZ(3)/110/,ST00RZ(4)/39/, *ST00RZ(5)/116/,ST00RZ(6)/32/,ST00RZ(7)/111/,ST00RZ(8)/112/,ST00RZ( *9)/101/,ST00RZ(10)/110/,ST00RZ(11)/32/,ST00RZ(12)/105/,ST00RZ(13)/ *110/,ST00RZ(14)/99/,ST00RZ(15)/108/,ST00RZ(16)/117/,ST00RZ(17)/100 */,ST00RZ(18)/101/,ST00RZ(19)/0/ 23317 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ) IF (.NOT.(GETTOK .EQ. -1))GOTO 23320 GOTO 23319 23320 CONTINUE IF (.NOT.(GETTOK .NE. -9))GOTO 23322 RETURN 23322 CONTINUE 23321 CONTINUE I = 1 23324 IF (.NOT.(I .LE. 9))GOTO 23326 T = TOKEN(I) TBUF(I) = T IF (.NOT.(T .EQ. 0))GOTO 23327 GOTO 23326 23327 CONTINUE 23325 I = I + 1 GOTO 23324 23326 CONTINUE IF (.NOT.(I .LT. 8 .OR. T .NE. 0))GOTO 23329 RETURN 23329 CONTINUE CALL FOLD(TBUF) IF (.NOT.(EQUAL (TBUF, FNCN) .EQ. 1))GOTO 23331 CALL SKPBLK T = DEFTOK (FCNAME, 36) CALL PBSTR (FCNAME) IF (.NOT.(T .NE. -9))GOTO 23333 CALL SYNERR (ST00QZ) 23333 CONTINUE CALL PUTBAK (32) RETURN 23331 CONTINUE IF (.NOT.(EQUAL (TBUF, INCL) .EQ. 0))GOTO 23335 RETURN 23335 CONTINUE 23332 CONTINUE CALL SKPBLK T = DEFTOK (NAME, 36) IF (.NOT.(T .EQ. 34))GOTO 23337 LEN = LENGTH (NAME) - 1 I = 1 23339 IF (.NOT.(I .LT. LEN))GOTO 23341 NAME (I) = NAME (I + 1) 23340 I = I + 1 GOTO 23339 23341 CONTINUE NAME (I) = 0 23337 CONTINUE I = LENGTH (NAME) + 1 CALL SYNERR (ST00RZ) 23318 GOTO 23317 23319 CONTINUE TOKEN (1) = -1 TOKEN (2) = 0 GETTOK = -1 RETURN END SUBROUTINE GETUND(TOKEN) BYTE TOKEN(120), TEMP(4) BYTE GCTOK BYTE ST00SZ(24) BYTE ST00TZ(22) BYTE ST010Z(24) DATA ST00SZ(1)/109/,ST00SZ(2)/105/,ST00SZ(3)/115/,ST00SZ(4)/115/, *ST00SZ(5)/105/,ST00SZ(6)/110/,ST00SZ(7)/103/,ST00SZ(8)/32/,ST00SZ( *9)/96/,ST00SZ(10)/40/,ST00SZ(11)/39/,ST00SZ(12)/32/,ST00SZ(13)/105 */,ST00SZ(14)/110/,ST00SZ(15)/32/,ST00SZ(16)/117/,ST00SZ(17)/110/, *ST00SZ(18)/100/,ST00SZ(19)/101/,ST00SZ(20)/102/,ST00SZ(21)/105/, *ST00SZ(22)/110/,ST00SZ(23)/101/,ST00SZ(24)/0/ DATA ST00TZ(1)/110/,ST00TZ(2)/111/,ST00TZ(3)/110/,ST00TZ(4)/45/, *ST00TZ(5)/97/,ST00TZ(6)/108/,ST00TZ(7)/112/,ST00TZ(8)/104/,ST00TZ( *9)/97/,ST00TZ(10)/110/,ST00TZ(11)/117/,ST00TZ(12)/109/,ST00TZ(13)/ *101/,ST00TZ(14)/114/,ST00TZ(15)/105/,ST00TZ(16)/99/,ST00TZ(17)/32/ *,ST00TZ(18)/110/,ST00TZ(19)/97/,ST00TZ(20)/109/,ST00TZ(21)/101/, *ST00TZ(22)/0/ DATA ST010Z(1)/109/,ST010Z(2)/105/,ST010Z(3)/115/,ST010Z(4)/115/, *ST010Z(5)/105/,ST010Z(6)/110/,ST010Z(7)/103/,ST010Z(8)/32/,ST010Z( *9)/96/,ST010Z(10)/41/,ST010Z(11)/39/,ST010Z(12)/32/,ST010Z(13)/105 */,ST010Z(14)/110/,ST010Z(15)/32/,ST010Z(16)/117/,ST010Z(17)/110/, *ST010Z(18)/100/,ST010Z(19)/101/,ST010Z(20)/102/,ST010Z(21)/105/, *ST010Z(22)/110/,ST010Z(23)/101/,ST010Z(24)/0/ CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. 40))GOTO 23342 CALL BADERR(ST00SZ) 23342 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. -9))GOTO 23344 CALL BADERR(ST00TZ) 23344 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TEMP, 4) .NE. 41))GOTO 23346 CALL BADERR(ST010Z) 23346 CONTINUE RETURN END BYTE FUNCTION GNBTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE GETTOK COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23348 CONTINUE CALL SKPBLK GNBTOK = GETTOK (TOKEN, TOKSIZ) 23349 IF (.NOT.(GNBTOK .NE. 32))GOTO 23348 23350 CONTINUE RETURN END BYTE FUNCTION GTOK (LEXSTR, TOKSIZ) BYTE LEXSTR (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE C INTEGER I, B, N, D BYTE NGETCH, CLOWER, ESC INTEGER ITOC, INDEX, CTOI BYTE CTYPE BYTE TYPE BYTE DIGITS(37) BYTE ALFCHR(2) BYTE ST011Z(14) BYTE ST012Z(40) BYTE ST013Z(22) BYTE ST014Z(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/117/,DIGITS(32)/118/,DIGITS(33)/119/, *DIGITS(34)/120/,DIGITS(35)/121/,DIGITS(36)/122/,DIGITS(37)/0/ DATA ALFCHR(1)/95/,ALFCHR(2)/0/ DATA ST011Z(1)/109/,ST011Z(2)/105/,ST011Z(3)/115/,ST011Z(4)/115/, *ST011Z(5)/105/,ST011Z(6)/110/,ST011Z(7)/103/,ST011Z(8)/32/,ST011Z( *9)/113/,ST011Z(10)/117/,ST011Z(11)/111/,ST011Z(12)/116/,ST011Z(13) */101/,ST011Z(14)/0/ DATA ST012Z(1)/109/,ST012Z(2)/105/,ST012Z(3)/115/,ST012Z(4)/115/, *ST012Z(5)/105/,ST012Z(6)/110/,ST012Z(7)/103/,ST012Z(8)/32/,ST012Z( *9)/97/,ST012Z(10)/112/,ST012Z(11)/111/,ST012Z(12)/115/,ST012Z(13)/ *116/,ST012Z(14)/114/,ST012Z(15)/111/,ST012Z(16)/112/,ST012Z(17)/10 *4/,ST012Z(18)/101/,ST012Z(19)/32/,ST012Z(20)/105/,ST012Z(21)/110/, *ST012Z(22)/32/,ST012Z(23)/99/,ST012Z(24)/104/,ST012Z(25)/97/, *ST012Z(26)/114/,ST012Z(27)/97/,ST012Z(28)/99/,ST012Z(29)/116/, *ST012Z(30)/101/,ST012Z(31)/114/,ST012Z(32)/32/,ST012Z(33)/108/, *ST012Z(34)/105/,ST012Z(35)/116/,ST012Z(36)/101/,ST012Z(37)/114/, *ST012Z(38)/97/,ST012Z(39)/108/,ST012Z(40)/0/ DATA ST013Z(1)/109/,ST013Z(2)/105/,ST013Z(3)/115/,ST013Z(4)/115/, *ST013Z(5)/105/,ST013Z(6)/110/,ST013Z(7)/103/,ST013Z(8)/32/,ST013Z( *9)/108/,ST013Z(10)/105/,ST013Z(11)/116/,ST013Z(12)/101/,ST013Z(13) */114/,ST013Z(14)/97/,ST013Z(15)/108/,ST013Z(16)/32/,ST013Z(17)/113 */,ST013Z(18)/117/,ST013Z(19)/111/,ST013Z(20)/116/,ST013Z(21)/101/, *ST013Z(22)/0/ DATA ST014Z(1)/116/,ST014Z(2)/111/,ST014Z(3)/107/,ST014Z(4)/101/, *ST014Z(5)/110/,ST014Z(6)/32/,ST014Z(7)/116/,ST014Z(8)/111/,ST014Z( *9)/111/,ST014Z(10)/32/,ST014Z(11)/108/,ST014Z(12)/111/,ST014Z(13)/ *110/,ST014Z(14)/103/,ST014Z(15)/0/ 23351 CONTINUE C = NGETCH (LEXSTR (1)) IF (.NOT.(C .EQ. 95))GOTO 23354 IF (.NOT.(NGETCH(C) .NE. 10))GOTO 23356 CALL PUTBAK(C) C = 95 GOTO 23353 23356 CONTINUE 23354 CONTINUE 23352 IF (.NOT.(LEXSTR(1) .NE. 95))GOTO 23351 23353 CONTINUE IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23358 LEXSTR (1) = 32 23360 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23361 C = NGETCH (C) GOTO 23360 23361 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23362 23364 IF (.NOT.(NGETCH (C) .NE. 10))GOTO 23365 GOTO 23364 23365 CONTINUE 23362 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23366 CALL PUTBAK (C) GOTO 23367 23366 CONTINUE LEXSTR (1) = 10 23367 CONTINUE LEXSTR (2) = 0 GTOK = LEXSTR (1) RETURN 23358 CONTINUE I = 1 IF (.NOT.(TYPE(C) .EQ. 1))GOTO 23368 I = 1 23370 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23372 C = NGETCH (LEXSTR (I + 1)) CTYPE = TYPE(C) IF (.NOT.(CTYPE .NE. 1 .AND. CTYPE .NE. 2 .AND. INDEX(ALFCHR, C) *.EQ. 0))GOTO 23373 GOTO 23372 23373 CONTINUE 23371 I = I + 1 GOTO 23370 23372 CONTINUE CALL PUTBAK (C) GTOK = -9 GOTO 23369 23368 CONTINUE IF (.NOT.(TYPE(C) .EQ. 2))GOTO 23375 I = 1 23377 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23379 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(TYPE(C) .NE. 2))GOTO 23380 GOTO 23379 23380 CONTINUE 23378 I = I + 1 GOTO 23377 23379 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23382 LEXSTR(I + 1) = 0 N = 1 B = CTOI(LEXSTR, N) 23382 CONTINUE IF (.NOT.(C .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO 23384 N = 0 23386 CONTINUE D = INDEX (DIGITS, CLOWER (NGETCH (C))) - 1 IF (.NOT.(D .LT. 0))GOTO 23389 GOTO 23388 23389 CONTINUE N = B * N + D 23387 GOTO 23386 23388 CONTINUE CALL PUTBAK (C) I = ITOC (N, LEXSTR, TOKSIZ) GOTO 23385 23384 CONTINUE CALL PUTBAK (C) 23385 CONTINUE GTOK = 2 GOTO 23376 23375 CONTINUE IF (.NOT.(C .EQ. 91))GOTO 23391 LEXSTR (1) = 123 GTOK = 123 GOTO 23392 23391 CONTINUE IF (.NOT.(C .EQ. 93))GOTO 23393 LEXSTR (1) = 125 GTOK = 125 GOTO 23394 23393 CONTINUE IF (.NOT.(C .EQ. 36))GOTO 23395 IF (.NOT.(NGETCH (LEXSTR (2)) .EQ. 40))GOTO 23397 I = 2 GTOK = -10 GOTO 23398 23397 CONTINUE IF (.NOT.(LEXSTR (2) .EQ. 41))GOTO 23399 I = 2 GTOK = -11 GOTO 23400 23399 CONTINUE CALL PUTBAK (LEXSTR (2)) GTOK = 36 23400 CONTINUE 23398 CONTINUE GOTO 23396 23395 CONTINUE IF (.NOT.(C .EQ. 34 .OR. C .EQ. 39))GOTO 23401 GTOK = C I = 2 23403 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23405 LEXSTR(I) = C IF (.NOT.(LEXSTR(I) .EQ. 95))GOTO 23406 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23408 23410 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23411 C = NGETCH(C) GOTO 23410 23411 CONTINUE LEXSTR(I) = C GOTO 23409 23408 CONTINUE CALL PUTBAK(C) 23409 CONTINUE C = LEXSTR(I) 23406 CONTINUE IF (.NOT.(C .EQ. 64))GOTO 23412 IF (.NOT.(NGETCH(C) .EQ. -1))GOTO 23414 CALL PUTBAK(C) GOTO 23415 23414 CONTINUE I = I + 1 IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23416 I = TOKSIZ - 1 23416 CONTINUE LEXSTR(I) = C 23415 CONTINUE C = 64 23412 CONTINUE IF (.NOT.(C .EQ. LEXSTR(1)))GOTO 23418 GOTO 23405 23418 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23420 CALL SYNERR (ST011Z) LEXSTR(I) = LEXSTR(1) CALL PUTBAK(10) GOTO 23405 23420 CONTINUE 23404 I = I + 1 GOTO 23403 23405 CONTINUE IF (.NOT.(LEXSTR(1) .EQ. 39))GOTO 23422 N = 2 C = ESC(LEXSTR, N) IF (.NOT.(LEXSTR(N + 1) .NE. 39))GOTO 23424 CALL SYNERR(ST012Z) 23424 CONTINUE N = C I = ITOC(N, LEXSTR, TOKSIZ) GTOK = 2 23422 CONTINUE GOTO 23402 23401 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23426 IF (.NOT.(NGETCH(LEXSTR(2)) .NE. 40))GOTO 23428 CALL PUTBAK(LEXSTR(2)) GTOK = 37 GOTO 23429 23428 CONTINUE GTOK = 34 LEXSTR(1) = -12 I = 2 23430 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23432 LEXSTR(I) = C IF (.NOT.(C .EQ. 95))GOTO 23433 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23435 23437 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23438 C = NGETCH(C) GOTO 23437 23438 CONTINUE LEXSTR(I) = C GOTO 23436 23435 CONTINUE CALL PUTBAK(C) 23436 CONTINUE C = LEXSTR(I) 23433 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23439 IF (.NOT.(NGETCH(C) .EQ. 41))GOTO 23441 LEXSTR(I) = -12 GOTO 23432 23441 CONTINUE CALL PUTBAK(C) 23442 CONTINUE 23439 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23443 CALL SYNERR(ST013Z) LEXSTR(I) = -12 CALL PUTBAK(10) GOTO 23432 23443 CONTINUE 23431 I = I + 1 GOTO 23430 23432 CONTINUE 23429 CONTINUE GOTO 23427 23426 CONTINUE IF (.NOT.(C .EQ. -12))GOTO 23445 GTOK = 34 I = 2 23447 IF (.NOT.(NGETCH(LEXSTR(I)) .NE. -12))GOTO 23449 23448 I = I + 1 GOTO 23447 23449 CONTINUE GOTO 23446 23445 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23450 23452 IF (.NOT.(NGETCH (LEXSTR (1)) .NE. 10))GOTO 23453 GOTO 23452 23453 CONTINUE GTOK = 10 GOTO 23451 23450 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 38 . *OR. C .EQ. 124 .OR. C .EQ. 61 .OR. C .EQ. 33 .OR. C .EQ. 126 .OR. *C .EQ. 94))GOTO 23454 CALL RELATE (LEXSTR, I) GTOK = C GOTO 23455 23454 CONTINUE GTOK = C 23455 CONTINUE 23451 CONTINUE 23446 CONTINUE 23427 CONTINUE 23402 CONTINUE 23396 CONTINUE 23394 CONTINUE 23392 CONTINUE 23376 CONTINUE 23369 CONTINUE IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23456 CALL SYNERR (ST014Z) 23456 CONTINUE LEXSTR (I + 1) = 0 RETURN END SUBROUTINE IFCODE (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER LABGEN COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 LAB = LABGEN (2) CALL IFGO (LAB) RETURN END SUBROUTINE IFGO (LAB) INTEGER LAB BYTE IFNOT(10) 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)/0/ CALL OUTTAB CALL OUTSTR (IFNOT) CALL BALPAR CALL OUTCH (41) CALL OUTGO (LAB) RETURN END INTEGER FUNCTION IFPARM (STRNG) BYTE STRNG (100) BYTE C INTEGER I INTEGER INDEX BYTE 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 .OR. C .EQ. -23))GOTO 23458 IFPARM = 1 GOTO 23459 23458 CONTINUE IFPARM = 0 I = 1 23460 IF (.NOT.(INDEX (STRNG (I), 36) .GT. 0))GOTO 23462 I = I + INDEX (STRNG (I), 36) IF (.NOT.(TYPE (STRNG (I)) .EQ. 2))GOTO 23463 IF (.NOT.(TYPE (STRNG (I + 1)) .NE. 2))GOTO 23465 IFPARM = 1 GOTO 23462 23465 CONTINUE 23463 CONTINUE 23461 GOTO 23460 23462 CONTINUE 23459 CONTINUE RETURN END SUBROUTINE INITKW INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER MKTABL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT (4250) DEFTBL = MKTABL (1) CALL ENTDKW RKWTBL = MKTABL (1) CALL ENTRKW LABEL = 23000 STRCNT = 1 RETURN END SUBROUTINE INSCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ BYTE C, BUF(100) BYTE ST015Z(16) DATA ST015Z(1)/98/,ST015Z(2)/117/,ST015Z(3)/102/,ST015Z(4)/102/, *ST015Z(5)/101/,ST015Z(6)/114/,ST015Z(7)/32/,ST015Z(8)/111/,ST015Z( *9)/118/,ST015Z(10)/101/,ST015Z(11)/114/,ST015Z(12)/102/,ST015Z(13) */108/,ST015Z(14)/111/,ST015Z(15)/119/,ST015Z(16)/0/ IF (.NOT.(BP .GT. MAXSIZ))GOTO 23467 CALL BADERR(ST015Z) 23467 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END SUBROUTINE INSDCL(NAME, VALUE, C) BYTE NAME(100), VALUE(100), C BYTE TEMP(10) INTEGER STRIP, DOSIZE, LEN, JUNK, FIRST, LAST, I INTEGER INDEX, ELENTH, ITOC, LENGTH INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(VALUE(1) .EQ. C))GOTO 23469 STRIP = 1 GOTO 23470 23469 CONTINUE STRIP = 0 23470 CONTINUE DOSIZE = 1 IF (.NOT.(INDEX(NAME, 40) .GT. 0 .OR. C .EQ. 39))GOTO 23471 DOSIZE = 0 23471 CONTINUE CALL INSCHR(C, SBUF, SBP, 600) CALL INSSTR(NAME, SBUF, SBP, 600) IF (.NOT.(DOSIZE .EQ. 1))GOTO 23473 LEN = ELENTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23475 LEN = LEN - 2 23475 CONTINUE IF (.NOT.(C .EQ. 34))GOTO 23477 LEN = LEN + 1 23477 CONTINUE CALL INSCHR(40, SBUF, SBP, 600) JUNK = ITOC(LEN, TEMP, 10) CALL INSSTR(TEMP, SBUF, SBP, 600) CALL INSCHR(41, SBUF, SBP, 600) 23473 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) FIRST = 1 LAST = LENGTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23479 FIRST = FIRST + 1 LAST = LAST -1 23479 CONTINUE I = FIRST 23481 IF (.NOT.(I .LE. LAST))GOTO 23483 CALL INSCHR(VALUE(I), SBUF, SBP, 600) 23482 I = I + 1 GOTO 23481 23483 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) RETURN END SUBROUTINE INSSTR(S, BUF, BP, MAXSIZ) BYTE S(100), BUF(100) INTEGER BP, MAXSIZ INTEGER I I = 1 23484 IF (.NOT.(S(I) .NE. 0))GOTO 23486 CALL INSCHR(S(I), BUF, BP, MAXSIZ) 23485 I=I+1 GOTO 23484 23486 CONTINUE RETURN END SUBROUTINE LABELC (LEXSTR) BYTE LEXSTR (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER LENGTH BYTE ST016Z(33) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST016Z(1)/119/,ST016Z(2)/97/,ST016Z(3)/114/,ST016Z(4)/110/, *ST016Z(5)/105/,ST016Z(6)/110/,ST016Z(7)/103/,ST016Z(8)/58/,ST016Z( *9)/32/,ST016Z(10)/112/,ST016Z(11)/111/,ST016Z(12)/115/,ST016Z(13)/ *115/,ST016Z(14)/105/,ST016Z(15)/98/,ST016Z(16)/108/,ST016Z(17)/101 */,ST016Z(18)/32/,ST016Z(19)/108/,ST016Z(20)/97/,ST016Z(21)/98/, *ST016Z(22)/101/,ST016Z(23)/108/,ST016Z(24)/32/,ST016Z(25)/99/, *ST016Z(26)/111/,ST016Z(27)/110/,ST016Z(28)/102/,ST016Z(29)/108/, *ST016Z(30)/105/,ST016Z(31)/99/,ST016Z(32)/116/,ST016Z(33)/0/ XFER = 0 IF (.NOT.(LENGTH (LEXSTR) .EQ. 5))GOTO 23487 IF (.NOT.(LEXSTR (1) .EQ. 50 .AND. LEXSTR (2) .EQ. 51))GOTO 23489 CALL SYNERR (ST016Z) 23489 CONTINUE 23487 CONTINUE CALL OUTSTR (LEXSTR) CALL OUTTAB RETURN END INTEGER FUNCTION LABGEN (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) LABGEN = LABEL LABEL = LABEL + N RETURN END INTEGER FUNCTION LEX (LEXSTR) BYTE LEXSTR (120) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE GNBTOK INTEGER LOOKUP COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23491 CONTINUE LEX = GNBTOK (LEXSTR, 120) IF (.NOT.(LEX .NE. 10))GOTO 23494 GOTO 23493 23494 CONTINUE 23492 GOTO 23491 23493 CONTINUE IF (.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX *.EQ. 125))GOTO 23496 RETURN 23496 CONTINUE IF (.NOT.(LEX .EQ. 2))GOTO 23498 LEX = -9 GOTO 23499 23498 CONTINUE IF (.NOT.(LEX .EQ. 37))GOTO 23500 LEX = -27 GOTO 23501 23500 CONTINUE CALL SCOPY(LEXSTR, 1, SCRTOK, 1) CALL FOLD(SCRTOK) IF (.NOT.(LOOKUP (SCRTOK, LEX, RKWTBL) .EQ. 0))GOTO 23502 LEX = -14 23502 CONTINUE 23501 CONTINUE 23499 CONTINUE RETURN END SUBROUTINE LITRAL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GT. 0))GOTO 23504 CALL OUTDON 23504 CONTINUE OUTP = 1 23506 IF (.NOT.(NGETCH (OUTBUF (OUTP)) .NE. 10))GOTO 23508 23507 OUTP = OUTP + 1 GOTO 23506 23508 CONTINUE OUTP = OUTP - 1 CALL OUTDON RETURN END BYTE FUNCTION NGETCH (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE GETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(BP .GT. 0))GOTO 23509 C = BUF(BP) BP = BP - 1 GOTO 23510 23509 CONTINUE C = GETCH(C, INFILE (LEVEL) ) IF (.NOT.(C .EQ. 10))GOTO 23511 LINECT (LEVEL) = LINECT (LEVEL) + 1 23511 CONTINUE 23510 CONTINUE NGETCH=(C) RETURN END SUBROUTINE OTHERC (LEXSTR) BYTE LEXSTR (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE TYPE COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTTAB CALL OUTSTR (LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GE. 72))GOTO 23513 CALL CONTLN 23513 CONTINUE OUTP = OUTP + 1 OUTBUF (OUTP) = C RETURN END SUBROUTINE OUTCON (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE CONTIN(9) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/, *CONTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN *(9)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23515 RETURN 23515 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23517 CALL OUTNUM (N) 23517 CONTINUE CALL OUTTAB CALL OUTSTR (CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDEF(STR, TOK) BYTE STR(100), TOK(120), T BYTE GNBTOK CALL PUTBAK(47) CALL PBSTR(STR) 23519 CONTINUE T = GNBTOK(TOK, 120) IF (.NOT.(T .EQ. 47))GOTO 23522 GOTO 23521 23522 CONTINUE CALL OUTSTR(TOK) 23520 GOTO 23519 23521 CONTINUE RETURN END SUBROUTINE OUTDON INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTBUF (OUTP + 1) = 10 OUTBUF (OUTP + 2) = 0 CALL PUTLIN (OUTBUF, 2) OUTP = 0 RETURN END SUBROUTINE OUTGO (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE SGOTO(6) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/0/ IF (.NOT.(XFER .EQ. 1))GOTO 23524 RETURN 23524 CONTINUE CALL OUTTAB CALL OUTSTR (SGOTO) CALL OUTNUM (N) CALL OUTDON RETURN END SUBROUTINE OUTNUM (N) INTEGER N BYTE CHARS (20) INTEGER I, M M = IABS (N) I = 0 23526 CONTINUE I = I + 1 CHARS (I) = MOD (M, 10) + 48 M = M / 10 23527 IF (.NOT.(M .EQ. 0 .OR. I .GE. 20))GOTO 23526 23528 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23529 CALL OUTCH (45) 23529 CONTINUE 23531 IF (.NOT.(I .GT. 0))GOTO 23533 CALL OUTCH (CHARS (I)) 23532 I = I - 1 GOTO 23531 23533 CONTINUE RETURN END SUBROUTINE OUTSTR (STR) BYTE STR (100) BYTE VARBUF(7) INTEGER I, N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) INTEGER QSTFIX INTEGER GENNAM BYTE STROOT(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA STROOT(1)/115/,STROOT(2)/116/,STROOT(3)/0/ IF (.NOT.(STR(1) .EQ. -12))GOTO 23534 I = 2 23536 IF (.NOT.(STR(I) .NE. -12))GOTO 23538 CALL OUTCH(STR(I)) 23537 I = I + 1 GOTO 23536 23538 CONTINUE GOTO 23535 23534 CONTINUE IF (.NOT.(STR(1) .NE. 34))GOTO 23539 CALL STROUT(STR, 1) GOTO 23540 23539 CONTINUE N = QSTFIX(STR) I = GENNAM(STROOT, STRCNT, VARBUF) CALL INSDCL(VARBUF, STR, 34) CALL STROUT(VARBUF, 1) 23540 CONTINUE 23535 CONTINUE RETURN END SUBROUTINE OUTTAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23541 IF (.NOT.(OUTP .LT. 6))GOTO 23542 CALL OUTCH (32) GOTO 23541 23542 CONTINUE RETURN END SUBROUTINE PARSE INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE LEXSTR (120) INTEGER LAB, LABVAL (100), LEXTYP (100), SP, TOKEN, I INTEGER LEX BYTE ST017Z(13) BYTE ST018Z(25) BYTE ST019Z(20) BYTE ST01AZ(15) BYTE ST01BZ(43) BYTE ST01CZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST017Z(1)/105/,ST017Z(2)/108/,ST017Z(3)/108/,ST017Z(4)/101/, *ST017Z(5)/103/,ST017Z(6)/97/,ST017Z(7)/108/,ST017Z(8)/32/,ST017Z(9 *)/101/,ST017Z(10)/108/,ST017Z(11)/115/,ST017Z(12)/101/,ST017Z(13)/ *0/ DATA ST018Z(1)/115/,ST018Z(2)/116/,ST018Z(3)/97/,ST018Z(4)/99/, *ST018Z(5)/107/,ST018Z(6)/32/,ST018Z(7)/111/,ST018Z(8)/118/,ST018Z( *9)/101/,ST018Z(10)/114/,ST018Z(11)/102/,ST018Z(12)/108/,ST018Z(13) */111/,ST018Z(14)/119/,ST018Z(15)/32/,ST018Z(16)/105/,ST018Z(17)/11 *0/,ST018Z(18)/32/,ST018Z(19)/112/,ST018Z(20)/97/,ST018Z(21)/114/, *ST018Z(22)/115/,ST018Z(23)/101/,ST018Z(24)/114/,ST018Z(25)/0/ DATA ST019Z(1)/105/,ST019Z(2)/108/,ST019Z(3)/108/,ST019Z(4)/101/, *ST019Z(5)/103/,ST019Z(6)/97/,ST019Z(7)/108/,ST019Z(8)/32/,ST019Z(9 *)/114/,ST019Z(10)/105/,ST019Z(11)/103/,ST019Z(12)/104/,ST019Z(13)/ *116/,ST019Z(14)/32/,ST019Z(15)/98/,ST019Z(16)/114/,ST019Z(17)/97/, *ST019Z(18)/99/,ST019Z(19)/101/,ST019Z(20)/0/ DATA ST01AZ(1)/117/,ST01AZ(2)/110/,ST01AZ(3)/101/,ST01AZ(4)/120/, *ST01AZ(5)/112/,ST01AZ(6)/101/,ST01AZ(7)/99/,ST01AZ(8)/116/,ST01AZ( *9)/101/,ST01AZ(10)/100/,ST01AZ(11)/32/,ST01AZ(12)/69/,ST01AZ(13)/7 *9/,ST01AZ(14)/70/,ST01AZ(15)/0/ DATA ST01BZ(1)/99/,ST01BZ(2)/111/,ST01BZ(3)/110/,ST01BZ(4)/100/, *ST01BZ(5)/105/,ST01BZ(6)/116/,ST01BZ(7)/105/,ST01BZ(8)/111/,ST01BZ *(9)/110/,ST01BZ(10)/97/,ST01BZ(11)/108/,ST01BZ(12)/32/,ST01BZ(13)/ *112/,ST01BZ(14)/114/,ST01BZ(15)/111/,ST01BZ(16)/99/,ST01BZ(17)/101 */,ST01BZ(18)/115/,ST01BZ(19)/115/,ST01BZ(20)/105/,ST01BZ(21)/110/, *ST01BZ(22)/103/,ST01BZ(23)/32/,ST01BZ(24)/115/,ST01BZ(25)/116/, *ST01BZ(26)/105/,ST01BZ(27)/108/,ST01BZ(28)/108/,ST01BZ(29)/32/, *ST01BZ(30)/97/,ST01BZ(31)/99/,ST01BZ(32)/116/,ST01BZ(33)/105/, *ST01BZ(34)/118/,ST01BZ(35)/101/,ST01BZ(36)/32/,ST01BZ(37)/97/, *ST01BZ(38)/116/,ST01BZ(39)/32/,ST01BZ(40)/69/,ST01BZ(41)/79/, *ST01BZ(42)/70/,ST01BZ(43)/0/ DATA ST01CZ(1)/65/,ST01CZ(2)/99/,ST01CZ(3)/99/,ST01CZ(4)/117/, *ST01CZ(5)/109/,ST01CZ(6)/117/,ST01CZ(7)/108/,ST01CZ(8)/97/,ST01CZ( *9)/116/,ST01CZ(10)/101/,ST01CZ(11)/100/,ST01CZ(12)/32/,ST01CZ(13)/ *100/,ST01CZ(14)/101/,ST01CZ(15)/99/,ST01CZ(16)/108/,ST01CZ(17)/97/ *,ST01CZ(18)/114/,ST01CZ(19)/97/,ST01CZ(20)/116/,ST01CZ(21)/105/, *ST01CZ(22)/111/,ST01CZ(23)/110/,ST01CZ(24)/115/,ST01CZ(25)/32/, *ST01CZ(26)/97/,ST01CZ(27)/116/,ST01CZ(28)/32/,ST01CZ(29)/69/, *ST01CZ(30)/79/,ST01CZ(31)/70/,ST01CZ(32)/0/ CALL FINIT SP = 1 LEXTYP (1) = -1 23543 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23546 CALL DMPDCL(LEXSTR) 23546 CONTINUE TOKEN = LEX (LEXSTR) IF (.NOT.(TOKEN .EQ. -1))GOTO 23548 GOTO 23545 23548 CONTINUE IF (.NOT.(TOKEN .EQ. -19))GOTO 23550 CALL IFCODE (LAB) GOTO 23551 23550 CONTINUE IF (.NOT.(TOKEN .EQ. -10))GOTO 23552 CALL DOCODE (LAB) GOTO 23553 23552 CONTINUE IF (.NOT.(TOKEN .EQ. -15))GOTO 23554 CALL WHILEC (LAB) GOTO 23555 23554 CONTINUE IF (.NOT.(TOKEN .EQ. -16))GOTO 23556 CALL FORCOD (LAB) GOTO 23557 23556 CONTINUE IF (.NOT.(TOKEN .EQ. -17))GOTO 23558 CALL REPCOD (LAB) GOTO 23559 23558 CONTINUE IF (.NOT.(TOKEN .EQ. -9))GOTO 23560 CALL LABELC (LEXSTR) GOTO 23561 23560 CONTINUE IF (.NOT.(TOKEN .EQ. -11))GOTO 23562 IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23564 CALL ELSEIF (LABVAL (SP)) GOTO 23565 23564 CONTINUE CALL SYNERR (ST017Z) 23565 CONTINUE GOTO 23563 23562 CONTINUE IF (.NOT.(TOKEN .EQ. -27))GOTO 23566 CALL LITRAL 23566 CONTINUE 23563 CONTINUE 23561 CONTINUE 23559 CONTINUE 23557 CONTINUE 23555 CONTINUE 23553 CONTINUE 23551 CONTINUE IF (.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 *.OR. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -10 .OR. *TOKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23568 SP = SP + 1 IF (.NOT.(SP .GT. 100))GOTO 23570 CALL BADERR (ST018Z) 23570 CONTINUE LEXTYP (SP) = TOKEN LABVAL (SP) = LAB GOTO 23569 23568 CONTINUE IF (.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23572 IF (.NOT.(TOKEN .EQ. 125))GOTO 23574 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23576 SP = SP - 1 GOTO 23577 23576 CONTINUE CALL SYNERR (ST019Z) 23577 CONTINUE GOTO 23575 23574 CONTINUE IF (.NOT.(TOKEN .EQ. -14))GOTO 23578 CALL OTHERC (LEXSTR) GOTO 23579 23578 CONTINUE IF (.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23580 CALL BRKNXT (SP, LEXTYP, LABVAL, TOKEN) GOTO 23581 23580 CONTINUE IF (.NOT.(TOKEN .EQ. -20))GOTO 23582 CALL RETCOD GOTO 23583 23582 CONTINUE IF (.NOT.(TOKEN .EQ. -23))GOTO 23584 CALL STRDCL 23584 CONTINUE 23583 CONTINUE 23581 CONTINUE 23579 CONTINUE 23575 CONTINUE TOKEN = LEX (LEXSTR) CALL PBSTR (LEXSTR) CALL UNSTAK (SP, LEXTYP, LABVAL, TOKEN) IF (.NOT.(TOKEN .EQ. -1))GOTO 23586 GOTO 23545 23586 CONTINUE 23572 CONTINUE 23569 CONTINUE 23544 GOTO 23543 23545 CONTINUE IF (.NOT.(SP .NE. 1))GOTO 23588 CALL SYNERR (ST01AZ) 23588 CONTINUE IF (.NOT.(CSP .GT. 0))GOTO 23590 CALL SYNERR(ST01BZ) 23590 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23592 CALL SYNERR(ST01CZ) 23592 CONTINUE RETURN END SUBROUTINE PBNUM (N) INTEGER N INTEGER M, NUM BYTE 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)/0/ NUM = IABS(N) 23594 CONTINUE M = MOD (NUM, 10) CALL PUTBAK (DIGITS (M + 1)) NUM = NUM / 10 23595 IF (.NOT.(NUM .EQ. 0))GOTO 23594 23596 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23597 CALL PUTBAK(45) 23597 CONTINUE RETURN END SUBROUTINE PBSTR (IN) BYTE IN (100) INTEGER I INTEGER LENGTH I = LENGTH (IN) 23599 IF (.NOT.(I .GT. 0))GOTO 23601 CALL PUTBAK (IN (I)) 23600 I = I - 1 GOTO 23599 23601 CONTINUE RETURN END INTEGER FUNCTION PUSH (EP, ARGSTK, AP) INTEGER AP, ARGSTK (100), EP BYTE ST01DZ(19) DATA ST01DZ(1)/97/,ST01DZ(2)/114/,ST01DZ(3)/103/,ST01DZ(4)/32/, *ST01DZ(5)/115/,ST01DZ(6)/116/,ST01DZ(7)/97/,ST01DZ(8)/99/,ST01DZ(9 *)/107/,ST01DZ(10)/32/,ST01DZ(11)/111/,ST01DZ(12)/118/,ST01DZ(13)/1 *01/,ST01DZ(14)/114/,ST01DZ(15)/102/,ST01DZ(16)/108/,ST01DZ(17)/111 */,ST01DZ(18)/119/,ST01DZ(19)/0/ IF (.NOT.(AP .GT. 100))GOTO 23602 CALL BADERR (ST01DZ) 23602 CONTINUE ARGSTK (AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTBAK (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE ST01EZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01EZ(1)/116/,ST01EZ(2)/111/,ST01EZ(3)/111/,ST01EZ(4)/32/, *ST01EZ(5)/109/,ST01EZ(6)/97/,ST01EZ(7)/110/,ST01EZ(8)/121/,ST01EZ( *9)/32/,ST01EZ(10)/99/,ST01EZ(11)/104/,ST01EZ(12)/97/,ST01EZ(13)/11 *4/,ST01EZ(14)/97/,ST01EZ(15)/99/,ST01EZ(16)/116/,ST01EZ(17)/101/, *ST01EZ(18)/114/,ST01EZ(19)/115/,ST01EZ(20)/32/,ST01EZ(21)/112/, *ST01EZ(22)/117/,ST01EZ(23)/115/,ST01EZ(24)/104/,ST01EZ(25)/101/, *ST01EZ(26)/100/,ST01EZ(27)/32/,ST01EZ(28)/98/,ST01EZ(29)/97/, *ST01EZ(30)/99/,ST01EZ(31)/107/,ST01EZ(32)/0/ IF (.NOT.(BP .GE. 500))GOTO 23604 CALL BADERR (ST01EZ) GOTO 23605 23604 CONTINUE BP = BP + 1 BUF (BP) = C 23605 CONTINUE RETURN END SUBROUTINE PUTCHR (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE ST01FZ(26) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01FZ(1)/101/,ST01FZ(2)/118/,ST01FZ(3)/97/,ST01FZ(4)/108/, *ST01FZ(5)/117/,ST01FZ(6)/97/,ST01FZ(7)/116/,ST01FZ(8)/105/,ST01FZ( *9)/111/,ST01FZ(10)/110/,ST01FZ(11)/32/,ST01FZ(12)/115/,ST01FZ(13)/ *116/,ST01FZ(14)/97/,ST01FZ(15)/99/,ST01FZ(16)/107/,ST01FZ(17)/32/, *ST01FZ(18)/111/,ST01FZ(19)/118/,ST01FZ(20)/101/,ST01FZ(21)/114/, *ST01FZ(22)/102/,ST01FZ(23)/108/,ST01FZ(24)/111/,ST01FZ(25)/119/, *ST01FZ(26)/0/ IF (.NOT.(EP .GT. 500))GOTO 23606 CALL BADERR (ST01FZ) 23606 CONTINUE EVALST (EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK (STR) BYTE STR (120) INTEGER I I = 1 23608 IF (.NOT.(STR (I) .NE. 0))GOTO 23610 CALL PUTCHR (STR (I)) 23609 I = I + 1 GOTO 23608 23610 CONTINUE RETURN END INTEGER FUNCTION QSTFIX(STR) BYTE STR(100) INTEGER LAST, N, I INTEGER LENGTH LAST = LENGTH(STR) N = 1 I = 2 23611 IF (.NOT.(I .LT. LAST))GOTO 23613 STR(N) = STR(I) N = N + 1 23612 I = I + 1 GOTO 23611 23613 CONTINUE STR(N) = 0 QSTFIX=(N-1) RETURN END SUBROUTINE RELATE (TOKEN, LAST) BYTE TOKEN (100) INTEGER LAST BYTE NGETCH INTEGER LENGTH IF (.NOT.(NGETCH (TOKEN (2)) .NE. 61))GOTO 23614 CALL PUTBAK (TOKEN (2)) TOKEN (3) = 116 GOTO 23615 23614 CONTINUE TOKEN (3) = 101 23615 CONTINUE TOKEN (4) = 46 TOKEN (5) = 0 TOKEN (6) = 0 IF (.NOT.(TOKEN (1) .EQ. 62))GOTO 23616 TOKEN (2) = 103 GOTO 23617 23616 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 60))GOTO 23618 TOKEN (2) = 108 GOTO 23619 23618 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 33 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) *.EQ. 126 .OR. TOKEN(1) .EQ. 94))GOTO 23620 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23622 TOKEN (3) = 111 TOKEN (4) = 116 TOKEN (5) = 46 23622 CONTINUE TOKEN (2) = 110 GOTO 23621 23620 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 61))GOTO 23624 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23626 TOKEN (2) = 0 LAST = 1 RETURN 23626 CONTINUE TOKEN (2) = 101 TOKEN (3) = 113 GOTO 23625 23624 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 38))GOTO 23628 TOKEN (2) = 97 TOKEN (3) = 110 TOKEN (4) = 100 TOKEN (5) = 46 GOTO 23629 23628 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 124))GOTO 23630 TOKEN (2) = 111 TOKEN (3) = 114 GOTO 23631 23630 CONTINUE TOKEN (2) = 0 23631 CONTINUE 23629 CONTINUE 23625 CONTINUE 23621 CONTINUE 23619 CONTINUE 23617 CONTINUE TOKEN (1) = 46 LAST = LENGTH (TOKEN) RETURN END SUBROUTINE REPCOD (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (3) CALL OUTCON (LAB) LAB = LAB + 1 RETURN END SUBROUTINE RETCOD INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE T BYTE GNBTOK BYTE SRET(7) BYTE ST01GZ(50) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA ST01GZ(1)/99/,ST01GZ(2)/97/,ST01GZ(3)/110/,ST01GZ(4)/39/, *ST01GZ(5)/116/,ST01GZ(6)/32/,ST01GZ(7)/103/,ST01GZ(8)/105/,ST01GZ( *9)/118/,ST01GZ(10)/101/,ST01GZ(11)/32/,ST01GZ(12)/39/,ST01GZ(13)/1 *14/,ST01GZ(14)/101/,ST01GZ(15)/116/,ST01GZ(16)/117/,ST01GZ(17)/114 */,ST01GZ(18)/110/,ST01GZ(19)/39/,ST01GZ(20)/32/,ST01GZ(21)/97/, *ST01GZ(22)/110/,ST01GZ(23)/32/,ST01GZ(24)/97/,ST01GZ(25)/114/, *ST01GZ(26)/103/,ST01GZ(27)/117/,ST01GZ(28)/109/,ST01GZ(29)/101/, *ST01GZ(30)/110/,ST01GZ(31)/116/,ST01GZ(32)/32/,ST01GZ(33)/102/, *ST01GZ(34)/114/,ST01GZ(35)/111/,ST01GZ(36)/109/,ST01GZ(37)/32/, *ST01GZ(38)/97/,ST01GZ(39)/32/,ST01GZ(40)/115/,ST01GZ(41)/117/, *ST01GZ(42)/98/,ST01GZ(43)/114/,ST01GZ(44)/111/,ST01GZ(45)/117/, *ST01GZ(46)/116/,ST01GZ(47)/105/,ST01GZ(48)/110/,ST01GZ(49)/101/, *ST01GZ(50)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23632 CALL PBSTR (SCRTOK) IF (.NOT.( FCNAME(1) .EQ. 0 ))GOTO 23634 CALL SYNERR(ST01GZ) CALL EATUP RETURN 23634 CONTINUE CALL OUTTAB CALL SCOPY (FCNAME, 1, SCRTOK, 1) CALL OUTSTR (SCRTOK) CALL OUTCH (61) CALL EATUP CALL OUTDON GOTO 23633 23632 CONTINUE IF (.NOT.(T .EQ. 125))GOTO 23636 CALL PBSTR (SCRTOK) 23636 CONTINUE 23633 CONTINUE CALL OUTTAB CALL OUTSTR (SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE SKPBLK INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE C BYTE NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23638 CONTINUE C = NGETCH (C) 23639 IF (.NOT.(C .NE. 32 .AND. C .NE. 9))GOTO 23638 23640 CONTINUE CALL PUTBAK (C) RETURN END SUBROUTINE STRDCL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE T, DCHAR (120) INTEGER I, J, K, N, LEN BYTE GNBTOK, ESC INTEGER LENGTH, CTOI, LEX, ELENTH BYTE CHAR(10) BYTE DAT(6) BYTE EOSS(4) BYTE ST01HZ(21) BYTE ST01IZ(20) BYTE ST01JZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ DATA ST01HZ(1)/109/,ST01HZ(2)/105/,ST01HZ(3)/115/,ST01HZ(4)/115/, *ST01HZ(5)/105/,ST01HZ(6)/110/,ST01HZ(7)/103/,ST01HZ(8)/32/,ST01HZ( *9)/115/,ST01HZ(10)/116/,ST01HZ(11)/114/,ST01HZ(12)/105/,ST01HZ(13) */110/,ST01HZ(14)/103/,ST01HZ(15)/32/,ST01HZ(16)/116/,ST01HZ(17)/11 *1/,ST01HZ(18)/107/,ST01HZ(19)/101/,ST01HZ(20)/110/,ST01HZ(21)/0/ DATA ST01IZ(1)/105/,ST01IZ(2)/110/,ST01IZ(3)/118/,ST01IZ(4)/97/, *ST01IZ(5)/108/,ST01IZ(6)/105/,ST01IZ(7)/100/,ST01IZ(8)/32/,ST01IZ( *9)/115/,ST01IZ(10)/116/,ST01IZ(11)/114/,ST01IZ(12)/105/,ST01IZ(13) */110/,ST01IZ(14)/103/,ST01IZ(15)/32/,ST01IZ(16)/115/,ST01IZ(17)/10 *5/,ST01IZ(18)/122/,ST01IZ(19)/101/,ST01IZ(20)/0/ DATA ST01JZ(1)/109/,ST01JZ(2)/105/,ST01JZ(3)/115/,ST01JZ(4)/115/, *ST01JZ(5)/105/,ST01JZ(6)/110/,ST01JZ(7)/103/,ST01JZ(8)/32/,ST01JZ( *9)/114/,ST01JZ(10)/105/,ST01JZ(11)/103/,ST01JZ(12)/104/,ST01JZ(13) */116/,ST01JZ(14)/32/,ST01JZ(15)/112/,ST01JZ(16)/97/,ST01JZ(17)/114 */,ST01JZ(18)/101/,ST01JZ(19)/110/,ST01JZ(20)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. -9))GOTO 23641 CALL SYNERR (ST01HZ) 23641 CONTINUE IF (.NOT.(GNBTOK(DCHAR, 120) .EQ. 40))GOTO 23643 CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 2))GOTO 23645 CALL SYNERR(ST01IZ) 23645 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 41))GOTO 23647 CALL SYNERR(ST01JZ) 23647 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) T = GNBTOK(DCHAR, 120) 23643 CONTINUE CALL INSDCL(SCRTOK, DCHAR, 34) RETURN END SUBROUTINE STROUT(STR, IFUP) BYTE STR(100), C INTEGER IFUP, I BYTE CUPPER INTEGER LENGTH INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.( (LENGTH(STR) + OUTP) .GT. 72 ))GOTO 23649 CALL CONTLN 23649 CONTINUE I = 1 23651 IF (.NOT.(STR(I) .NE. 0))GOTO 23653 C = STR(I) IF (.NOT.(IFUP .EQ. 1))GOTO 23654 C = CUPPER(C) 23654 CONTINUE CALL OUTCH(C) 23652 I = I + 1 GOTO 23651 23653 CONTINUE RETURN END SUBROUTINE SYNERR (MSG) BYTE MSG (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE LC (20) INTEGER I, JUNK INTEGER ITOC BYTE IN(5) BYTE ERRMSG(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/, *ERRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9 *)/32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/1 *01/,ERRMSG(14)/32/,ERRMSG(15)/0/ IF (.NOT.(CURCND .NE. 1))GOTO 23656 RETURN 23656 CONTINUE CALL PUTLIN (ERRMSG, 3) IF (.NOT.(LEVEL .GE. 1))GOTO 23658 I = LEVEL GOTO 23659 23658 CONTINUE I = 1 23659 CONTINUE JUNK = ITOC (LINECT (I), LC, 20) CALL PUTLIN (LC, 3) I = FNAMP - 1 23660 IF (.NOT.(I .GT. 1))GOTO 23662 IF (.NOT.(FNAMES (I - 1) .EQ. 0))GOTO 23663 CALL PUTLIN (IN, 3) CALL PUTLIN (FNAMES (I), 3) GOTO 23662 23663 CONTINUE 23661 I = I - 1 GOTO 23660 23662 CONTINUE CALL PUTCH (58, 3) CALL PUTCH (32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE ULSTAL (NAME, VAL) BYTE NAME (100), DEFN (2), VAL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DEFN (1) = VAL DEFN (2) = 0 CALL ENTDEF (NAME, DEFN, DEFTBL) CALL UPPER (NAME) CALL ENTDEF (NAME, DEFN, DEFTBL) RETURN END SUBROUTINE UNSTAK (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN 23665 IF (.NOT.(SP .GT. 1))GOTO 23667 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23668 GOTO 23667 23668 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23670 GOTO 23667 23670 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23672 CALL OUTCON (LABVAL (SP)) GOTO 23673 23672 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -11))GOTO 23674 IF (.NOT.(SP .GT. 2))GOTO 23676 SP = SP - 1 23676 CONTINUE CALL OUTCON (LABVAL (SP) + 1) GOTO 23675 23674 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -10))GOTO 23678 CALL DOSTAT (LABVAL (SP)) GOTO 23679 23678 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -15))GOTO 23680 CALL WHILES (LABVAL (SP)) GOTO 23681 23680 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -16))GOTO 23682 CALL FORS (LABVAL (SP)) GOTO 23683 23682 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -17))GOTO 23684 CALL UNTILS (LABVAL (SP), TOKEN) 23684 CONTINUE 23683 CONTINUE 23681 CONTINUE 23679 CONTINUE 23675 CONTINUE 23673 CONTINUE 23666 SP = SP - 1 GOTO 23665 23667 CONTINUE RETURN END SUBROUTINE UNTILS (LAB, TOKEN) INTEGER LAB, TOKEN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(8500) BYTE PTOKEN (120) INTEGER JUNK INTEGER LEX COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) IF (.NOT.(TOKEN .EQ. -18))GOTO 23686 JUNK = LEX (PTOKEN) CALL IFGO (LAB - 1) GOTO 23687 23686 CONTINUE CALL OUTGO (LAB - 1) 23687 CONTINUE CALL OUTCON (LAB + 1) RETURN END SUBROUTINE WHILEC (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (2) CALL OUTNUM (LAB) CALL IFGO (LAB + 1) RETURN END SUBROUTINE WHILES (LAB) INTEGER LAB CALL OUTGO (LAB) CALL OUTCON (LAB + 1) RETURN END #-t- ratp1b2ch.f ascii 01/09/84 15:54 #-h- ratp1b4ch.f ascii 01/09/84 15:54 CALL INITST CALL RATFOR CALL ENDST(0) END SUBROUTINE RATFOR INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER I, N INTEGER GETARG, OPEN BYTE ARG (36) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL INITKW INFILE (1) = 1 CALL PARSE RETURN END SUBROUTINE BADERR (MSG) BYTE MSG (100) CALL SYNERR (MSG) CALL ENDST(-3) RETURN END SUBROUTINE BALPAR BYTE T, TOKEN (120) BYTE GETTOK, GNBTOK INTEGER NLPAR BYTE ST001Z(19) BYTE ST002Z(33) DATA ST001Z(1)/109/,ST001Z(2)/105/,ST001Z(3)/115/,ST001Z(4)/115/, *ST001Z(5)/105/,ST001Z(6)/110/,ST001Z(7)/103/,ST001Z(8)/32/,ST001Z( *9)/108/,ST001Z(10)/101/,ST001Z(11)/102/,ST001Z(12)/116/,ST001Z(13) */32/,ST001Z(14)/112/,ST001Z(15)/97/,ST001Z(16)/114/,ST001Z(17)/101 */,ST001Z(18)/110/,ST001Z(19)/0/ DATA ST002Z(1)/109/,ST002Z(2)/105/,ST002Z(3)/115/,ST002Z(4)/115/, *ST002Z(5)/105/,ST002Z(6)/110/,ST002Z(7)/103/,ST002Z(8)/32/,ST002Z( *9)/112/,ST002Z(10)/97/,ST002Z(11)/114/,ST002Z(12)/101/,ST002Z(13)/ *110/,ST002Z(14)/116/,ST002Z(15)/104/,ST002Z(16)/101/,ST002Z(17)/11 *5/,ST002Z(18)/105/,ST002Z(19)/115/,ST002Z(20)/32/,ST002Z(21)/105/, *ST002Z(22)/110/,ST002Z(23)/32/,ST002Z(24)/99/,ST002Z(25)/111/, *ST002Z(26)/110/,ST002Z(27)/100/,ST002Z(28)/105/,ST002Z(29)/116/, *ST002Z(30)/105/,ST002Z(31)/111/,ST002Z(32)/110/,ST002Z(33)/0/ IF (.NOT.(GNBTOK (TOKEN, 120) .NE. 40))GOTO 23000 CALL SYNERR (ST001Z) RETURN 23000 CONTINUE CALL OUTSTR (TOKEN) NLPAR = 1 23002 CONTINUE T = GETTOK (TOKEN, 120) 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) = 0 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 CALL OUTSTR (TOKEN) 23003 IF (.NOT.(NLPAR .LE. 0))GOTO 23002 23004 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23013 CALL SYNERR (ST002Z) 23013 CONTINUE RETURN END SUBROUTINE BRKNXT (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN INTEGER I, N BYTE T INTEGER ALLDIG, CTOI BYTE GNBTOK INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE ST003Z(14) BYTE ST004Z(13) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST003Z(1)/105/,ST003Z(2)/108/,ST003Z(3)/108/,ST003Z(4)/101/, *ST003Z(5)/103/,ST003Z(6)/97/,ST003Z(7)/108/,ST003Z(8)/32/,ST003Z(9 *)/98/,ST003Z(10)/114/,ST003Z(11)/101/,ST003Z(12)/97/,ST003Z(13)/10 *7/,ST003Z(14)/0/ DATA ST004Z(1)/105/,ST004Z(2)/108/,ST004Z(3)/108/,ST004Z(4)/101/, *ST004Z(5)/103/,ST004Z(6)/97/,ST004Z(7)/108/,ST004Z(8)/32/,ST004Z(9 *)/110/,ST004Z(10)/101/,ST004Z(11)/120/,ST004Z(12)/116/,ST004Z(13)/ *0/ N = 0 T = GNBTOK (SCRTOK, 120) IF (.NOT.(ALLDIG (SCRTOK) .EQ. 1))GOTO 23015 I = 1 N = CTOI (SCRTOK, I) - 1 GOTO 23016 23015 CONTINUE IF (.NOT.(T .NE. 59))GOTO 23017 CALL PBSTR (SCRTOK) 23017 CONTINUE 23016 CONTINUE I = SP 23019 IF (.NOT.(I .GT. 0))GOTO 23021 IF (.NOT.(LEXTYP (I) .EQ. -15 .OR. LEXTYP (I) .EQ. -10 .OR. LEXTYP * (I) .EQ. -16 .OR. LEXTYP (I) .EQ. -17))GOTO 23022 IF (.NOT.(N .GT. 0))GOTO 23024 N = N - 1 GOTO 23020 23024 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23026 CALL OUTGO (LABVAL (I) + 1) GOTO 23027 23026 CONTINUE CALL OUTGO (LABVAL (I)) 23027 CONTINUE 23025 CONTINUE XFER = 1 RETURN 23022 CONTINUE 23020 I = I - 1 GOTO 23019 23021 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23028 CALL SYNERR (ST003Z) GOTO 23029 23028 CONTINUE CALL SYNERR (ST004Z) 23029 CONTINUE RETURN END SUBROUTINE CONTLN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE BLSTAR(7) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BLSTAR(1)/32/,BLSTAR(2)/32/,BLSTAR(3)/32/,BLSTAR(4)/32/, *BLSTAR(5)/32/,BLSTAR(6)/42/,BLSTAR(7)/0/ CALL OUTDON CALL SCOPY(BLSTAR, 1, OUTBUF, 1) OUTP = 6 RETURN END BYTE FUNCTION DEFTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE T, C, DEFN (250) INTEGER AP, ARGSTK (100), CALLST (50), NLB, PLEV (50), IFL INTEGER LUDEF, PUSH, IFPARM, ENTER BYTE GCTOK BYTE BALP(3) BYTE ST005Z(20) BYTE ST006Z(14) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ DATA ST005Z(1)/99/,ST005Z(2)/97/,ST005Z(3)/108/,ST005Z(4)/108/, *ST005Z(5)/32/,ST005Z(6)/115/,ST005Z(7)/116/,ST005Z(8)/97/,ST005Z(9 *)/99/,ST005Z(10)/107/,ST005Z(11)/32/,ST005Z(12)/111/,ST005Z(13)/11 *8/,ST005Z(14)/101/,ST005Z(15)/114/,ST005Z(16)/102/,ST005Z(17)/108/ *,ST005Z(18)/111/,ST005Z(19)/119/,ST005Z(20)/0/ DATA ST006Z(1)/69/,ST006Z(2)/79/,ST006Z(3)/70/,ST006Z(4)/32/, *ST006Z(5)/105/,ST006Z(6)/110/,ST006Z(7)/32/,ST006Z(8)/115/,ST006Z( *9)/116/,ST006Z(10)/114/,ST006Z(11)/105/,ST006Z(12)/110/,ST006Z(13) */103/,ST006Z(14)/0/ CP = 0 AP = 1 EP = 1 23030 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -1))GOTO 23033 GOTO 23032 23033 CONTINUE IF (.NOT.(T .EQ. -9))GOTO 23035 IF (.NOT.(LUDEF (TOKEN, DEFN, DEFTBL) .EQ. 0))GOTO 23037 IF (.NOT.(CP .EQ. 0))GOTO 23039 GOTO 23032 23039 CONTINUE CALL PUTTOK (TOKEN) 23040 CONTINUE GOTO 23038 23037 CONTINUE IF (.NOT.(DEFN (1) .EQ. -4))GOTO 23041 CALL GETDEF (TOKEN, TOKSIZ, DEFN, 250) CALL ENTDEF (TOKEN, DEFN, DEFTBL) GOTO 23042 23041 CONTINUE IF (.NOT.(DEFN (1) .EQ. -21))GOTO 23043 CALL GETUND (TOKEN) CALL RMDEF (TOKEN, DEFTBL) GOTO 23044 23043 CONTINUE CP = CP + 1 IF (.NOT.(CP .GT. 50))GOTO 23045 CALL BADERR (ST005Z) 23045 CONTINUE CALLST (CP) = AP AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (DEFN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (TOKEN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. 32))GOTO 23047 T = GCTOK (TOKEN, TOKSIZ) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. 40))GOTO 23049 CALL PUTBAK (32) 23049 CONTINUE GOTO 23048 23047 CONTINUE CALL PBSTR (TOKEN) 23048 CONTINUE IF (.NOT.(T .NE. 40))GOTO 23051 CALL PBSTR (BALP) GOTO 23052 23051 CONTINUE IF (.NOT.(IFPARM (DEFN) .EQ. 0))GOTO 23053 CALL PBSTR (BALP) 23053 CONTINUE 23052 CONTINUE PLEV (CP) = 0 23044 CONTINUE 23042 CONTINUE 23038 CONTINUE GOTO 23036 23035 CONTINUE IF (.NOT.(T .EQ. -10))GOTO 23055 NLB = 1 23057 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -10))GOTO 23060 NLB = NLB + 1 GOTO 23061 23060 CONTINUE IF (.NOT.(T .EQ. -11))GOTO 23062 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0))GOTO 23064 GOTO 23059 23064 CONTINUE GOTO 23063 23062 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23066 CALL BADERR (ST006Z) 23066 CONTINUE 23063 CONTINUE 23061 CONTINUE CALL PUTTOK (TOKEN) 23058 GOTO 23057 23059 CONTINUE GOTO 23056 23055 CONTINUE IF (.NOT.(CP .EQ. 0))GOTO 23068 GOTO 23032 23068 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23070 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23072 CALL PUTTOK (TOKEN) 23072 CONTINUE PLEV (CP) = PLEV (CP) + 1 GOTO 23071 23070 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23074 PLEV (CP) = PLEV (CP) - 1 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23076 CALL PUTTOK (TOKEN) GOTO 23077 23076 CONTINUE CALL PUTCHR (0) CALL EVALR (ARGSTK, CALLST (CP), AP - 1) AP = CALLST (CP) EP = ARGSTK (AP) CP = CP - 1 23077 CONTINUE GOTO 23075 23074 CONTINUE IF (.NOT.(T .EQ. 44 .AND. PLEV (CP) .EQ. 1))GOTO 23078 CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) GOTO 23079 23078 CONTINUE CALL PUTTOK (TOKEN) 23079 CONTINUE 23075 CONTINUE 23071 CONTINUE 23069 CONTINUE 23056 CONTINUE 23036 CONTINUE 23031 GOTO 23030 23032 CONTINUE DEFTOK = T RETURN END SUBROUTINE DMPDCL(TOKEN) BYTE TOKEN(100) INTEGER I, J, N BYTE C INTEGER INDEX BYTE ESC INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE CHAR(10) BYTE COMSTR(7) BYTE DATS(6) BYTE EOSS(4) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA COMSTR(1)/99/,COMSTR(2)/32/,COMSTR(3)/32/,COMSTR(4)/32/, *COMSTR(5)/32/,COMSTR(6)/32/,COMSTR(7)/0/ DATA DATS(1)/100/,DATS(2)/97/,DATS(3)/116/,DATS(4)/97/,DATS(5)/32/ *,DATS(6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ IF (.NOT.(SBP .GT. 1))GOTO 23080 I = 1 23082 IF (.NOT.(I .LT. SBP))GOTO 23084 CALL OUTTAB CALL OUTDEF(CHAR, TOKEN) CALL OUTCH(32) C = SBUF(I) J = 1 I = I + 1 23085 IF (.NOT.(SBUF(I) .NE. 0))GOTO 23087 TOKEN(J) = SBUF(I) J = J + 1 23086 I = I + 1 GOTO 23085 23087 CONTINUE TOKEN(J) = 0 I = I + 1 CALL OUTSTR(TOKEN) CALL OUTDON J = INDEX(TOKEN, 40) IF (.NOT.(J .GT. 0))GOTO 23088 TOKEN(J) = 0 23088 CONTINUE J = 1 23090 CONTINUE IF (.NOT.(SBUF(I) .EQ. 0 .AND. C .EQ. 39))GOTO 23093 GOTO 23092 23093 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23095 CALL OUTTAB CALL OUTSTR(DATS) GOTO 23096 23095 CONTINUE CALL OUTCH(44) 23096 CONTINUE CALL OUTSTR(TOKEN) IF (.NOT.(C .EQ. 34))GOTO 23097 CALL OUTCH(40) CALL OUTNUM(J) CALL OUTCH(41) 23097 CONTINUE CALL OUTCH(47) IF (.NOT.(SBUF(I) .EQ. 0))GOTO 23099 CALL OUTDEF(EOSS, TOKEN) CALL OUTCH(47) GOTO 23092 23099 CONTINUE N = ESC(SBUF, I) CALL OUTNUM(N) CALL OUTCH(47) 23100 CONTINUE J = J + 1 I = I + 1 23091 GOTO 23090 23092 CONTINUE CALL OUTDON 23083 I = I + 1 GOTO 23082 23084 CONTINUE SBP = 1 23080 CONTINUE RETURN END SUBROUTINE DOARTH (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER K, L, ANS, FIRST, SECOND BYTE OP INTEGER CTOI BYTE ST007Z(12) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST007Z(1)/97/,ST007Z(2)/114/,ST007Z(3)/105/,ST007Z(4)/116/, *ST007Z(5)/104/,ST007Z(6)/32/,ST007Z(7)/101/,ST007Z(8)/114/,ST007Z( *9)/114/,ST007Z(10)/111/,ST007Z(11)/114/,ST007Z(12)/0/ K = ARGSTK (I + 2) FIRST = CTOI(EVALST, K) L = ARGSTK (I + 4) SECOND = CTOI(EVALST, L) OP = EVALST (ARGSTK (I + 3)) IF (.NOT.(OP .EQ. 43))GOTO 23101 CALL PBNUM (FIRST + SECOND) GOTO 23102 23101 CONTINUE IF (.NOT.(OP .EQ. 45))GOTO 23103 CALL PBNUM (FIRST - SECOND) GOTO 23104 23103 CONTINUE IF (.NOT.(OP .EQ. 42 ))GOTO 23105 IF (.NOT.(EVALST(ARGSTK(I+3) + 1) .EQ. 42))GOTO 23107 ANS = 1 23109 IF (.NOT.(SECOND .GT. 0))GOTO 23111 ANS = ANS * FIRST 23110 SECOND = SECOND - 1 GOTO 23109 23111 CONTINUE CALL PBNUM(ANS) GOTO 23108 23107 CONTINUE CALL PBNUM (FIRST * SECOND) 23108 CONTINUE GOTO 23106 23105 CONTINUE IF (.NOT.(OP .EQ. 47 ))GOTO 23112 CALL PBNUM (FIRST / SECOND) GOTO 23113 23112 CONTINUE CALL SYNERR (ST007Z) 23113 CONTINUE 23106 CONTINUE 23104 CONTINUE 23102 CONTINUE RETURN END SUBROUTINE DOCODE (LAB) INTEGER LAB INTEGER LABGEN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE GNBTOK BYTE SDO(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR (SDO) CALL OUTCH (32) LAB = LABGEN (2) IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 2))GOTO 23114 CALL OUTSTR (SCRTOK) GOTO 23115 23114 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) 23115 CONTINUE CALL OUTCH (32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOIF (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER A2, A3, A4, A5 INTEGER EQUAL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 5))GOTO 23116 RETURN 23116 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 23118 CALL PBSTR (EVALST (A4)) GOTO 23119 23118 CONTINUE CALL PBSTR (EVALST (A5)) 23119 CONTINUE RETURN END SUBROUTINE DOINCR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER K INTEGER CTOI COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK (I + 2) CALL PBNUM (CTOI (EVALST, K) + 1) RETURN END SUBROUTINE DOLENT(ARGSTK, I, J) INTEGER ARGSTK(100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER K INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK(I + 2) CALL PBNUM(LENGTH(EVALST(K))) RETURN END SUBROUTINE DOMAC (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER A2, A3 BYTE TYPE BYTE ST008Z(34) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST008Z(1)/73/,ST008Z(2)/108/,ST008Z(3)/108/,ST008Z(4)/101/, *ST008Z(5)/103/,ST008Z(6)/97/,ST008Z(7)/108/,ST008Z(8)/32/,ST008Z(9 *)/102/,ST008Z(10)/105/,ST008Z(11)/114/,ST008Z(12)/115/,ST008Z(13)/ *116/,ST008Z(14)/32/,ST008Z(15)/97/,ST008Z(16)/114/,ST008Z(17)/103/ *,ST008Z(18)/117/,ST008Z(19)/109/,ST008Z(20)/101/,ST008Z(21)/110/, *ST008Z(22)/116/,ST008Z(23)/32/,ST008Z(24)/116/,ST008Z(25)/111/, *ST008Z(26)/32/,ST008Z(27)/109/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/101/, *ST008Z(34)/0/ IF (.NOT.(J - I .GT. 2))GOTO 23120 A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) IF (.NOT.(TYPE(EVALST(A2)) .NE. 1))GOTO 23122 CALL SYNERR(ST008Z) GOTO 23123 23122 CONTINUE CALL ENTDEF (EVALST (A2), EVALST (A3), DEFTBL) 23123 CONTINUE 23120 CONTINUE RETURN END SUBROUTINE DOSTAT (LAB) INTEGER LAB CALL OUTCON (LAB) CALL OUTCON (LAB + 1) RETURN END SUBROUTINE DOSUB (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER AP, FC, K, NC INTEGER CTOI, LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 3))GOTO 23124 RETURN 23124 CONTINUE IF (.NOT.(J - I .LT. 4))GOTO 23126 NC = 120 GOTO 23127 23126 CONTINUE K = ARGSTK (I + 4) NC = CTOI (EVALST, K) 23127 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 23128 K = FC + MIN0(NC, LENGTH (EVALST (FC))) - 1 23130 IF (.NOT.(K .GE. FC))GOTO 23132 CALL PUTBAK (EVALST (K)) 23131 K = K - 1 GOTO 23130 23132 CONTINUE 23128 CONTINUE RETURN END BYTE FUNCTION DOTHER(TOKEN) BYTE TOKEN(120), T INTEGER NLPAR BYTE GETTOK BYTE ST009Z(15) DATA ST009Z(1)/117/,ST009Z(2)/110/,ST009Z(3)/101/,ST009Z(4)/120/, *ST009Z(5)/112/,ST009Z(6)/101/,ST009Z(7)/99/,ST009Z(8)/116/,ST009Z( *9)/101/,ST009Z(10)/100/,ST009Z(11)/32/,ST009Z(12)/69/,ST009Z(13)/7 *9/,ST009Z(14)/70/,ST009Z(15)/0/ CALL OUTTAB NLPAR = 0 23133 CONTINUE T = GETTOK(TOKEN, 120) IF (.NOT.(T .EQ. 40))GOTO 23136 NLPAR = NLPAR + 1 GOTO 23137 23136 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23138 NLPAR = NLPAR - 1 23138 CONTINUE 23137 CONTINUE IF (.NOT.(T .EQ. 59 .OR. (T .EQ. 44 .AND. NLPAR .EQ. 0)))GOTO 2314 *0 GOTO 23135 23140 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23142 CALL SYNERR(ST009Z) CALL PBSTR(TOKEN) GOTO 23135 23142 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23144 CALL OUTSTR(TOKEN) 23144 CONTINUE 23134 GOTO 23133 23135 CONTINUE CALL OUTDON DOTHER=(T) RETURN END SUBROUTINE EATUP BYTE PTOKEN (120), T, TOKEN (120) INTEGER NLPAR BYTE GETTOK BYTE ST00AZ(15) BYTE ST00BZ(23) DATA ST00AZ(1)/117/,ST00AZ(2)/110/,ST00AZ(3)/101/,ST00AZ(4)/120/, *ST00AZ(5)/112/,ST00AZ(6)/101/,ST00AZ(7)/99/,ST00AZ(8)/116/,ST00AZ( *9)/101/,ST00AZ(10)/100/,ST00AZ(11)/32/,ST00AZ(12)/69/,ST00AZ(13)/7 *9/,ST00AZ(14)/70/,ST00AZ(15)/0/ DATA ST00BZ(1)/117/,ST00BZ(2)/110/,ST00BZ(3)/98/,ST00BZ(4)/97/, *ST00BZ(5)/108/,ST00BZ(6)/97/,ST00BZ(7)/110/,ST00BZ(8)/99/,ST00BZ(9 *)/101/,ST00BZ(10)/100/,ST00BZ(11)/32/,ST00BZ(12)/112/,ST00BZ(13)/9 *7/,ST00BZ(14)/114/,ST00BZ(15)/101/,ST00BZ(16)/110/,ST00BZ(17)/116/ *,ST00BZ(18)/104/,ST00BZ(19)/101/,ST00BZ(20)/115/,ST00BZ(21)/101/, *ST00BZ(22)/115/,ST00BZ(23)/0/ NLPAR = 0 23146 CONTINUE T = GETTOK (TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23149 GOTO 23148 23149 CONTINUE IF (.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23151 CALL PBSTR (TOKEN) GOTO 23148 23151 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23153 CALL SYNERR (ST00AZ) CALL PBSTR (TOKEN) GOTO 23148 23153 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 *.OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. *T .EQ. 33 .OR. T .EQ. 126 .OR. T .EQ. 94 .OR. T .EQ. 61))GOTO 2315 *5 23157 IF (.NOT.(GETTOK (PTOKEN, 120) .EQ. 10))GOTO 23158 GOTO 23157 23158 CONTINUE CALL PBSTR (PTOKEN) 23155 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23159 NLPAR = NLPAR + 1 GOTO 23160 23159 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23161 NLPAR = NLPAR - 1 23161 CONTINUE 23160 CONTINUE CALL OUTSTR (TOKEN) 23147 IF (.NOT.(NLPAR .LT. 0))GOTO 23146 23148 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23163 CALL SYNERR (ST00BZ) 23163 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) BYTE BUF(100), C INTEGER I, N BYTE ESC N = 0 I=1 23165 IF (.NOT.(BUF(I) .NE. 0))GOTO 23167 C = ESC(BUF, I) N = N + 1 23166 I=I+1 GOTO 23165 23167 CONTINUE ELENTH = N RETURN END SUBROUTINE ELSEIF (LAB) INTEGER LAB CALL OUTGO (LAB+1) CALL OUTCON (LAB) RETURN END SUBROUTINE ENTDKW BYTE DEFNAM(7) BYTE MACNAM(8) BYTE INCNAM(5) BYTE SUBNAM(7) BYTE IFNAM(7) BYTE ARNAM(6) BYTE UNDEFN(9) BYTE LINKNM(8) BYTE LENTNM(7) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/, *DEFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/0/ DATA MACNAM(1)/109/,MACNAM(2)/100/,MACNAM(3)/101/,MACNAM(4)/102/, *MACNAM(5)/105/,MACNAM(6)/110/,MACNAM(7)/101/,MACNAM(8)/0/ DATA INCNAM(1)/105/,INCNAM(2)/110/,INCNAM(3)/99/,INCNAM(4)/114/, *INCNAM(5)/0/ DATA SUBNAM(1)/115/,SUBNAM(2)/117/,SUBNAM(3)/98/,SUBNAM(4)/115/, *SUBNAM(5)/116/,SUBNAM(6)/114/,SUBNAM(7)/0/ DATA IFNAM(1)/105/,IFNAM(2)/102/,IFNAM(3)/101/,IFNAM(4)/108/,IFNAM *(5)/115/,IFNAM(6)/101/,IFNAM(7)/0/ DATA ARNAM(1)/97/,ARNAM(2)/114/,ARNAM(3)/105/,ARNAM(4)/116/,ARNAM( *5)/104/,ARNAM(6)/0/ DATA UNDEFN(1)/117/,UNDEFN(2)/110/,UNDEFN(3)/100/,UNDEFN(4)/101/, *UNDEFN(5)/102/,UNDEFN(6)/105/,UNDEFN(7)/110/,UNDEFN(8)/101/,UNDEFN *(9)/0/ DATA LINKNM(1)/108/,LINKNM(2)/105/,LINKNM(3)/110/,LINKNM(4)/107/, *LINKNM(5)/97/,LINKNM(6)/103/,LINKNM(7)/101/,LINKNM(8)/0/ DATA LENTNM(1)/108/,LENTNM(2)/101/,LENTNM(3)/110/,LENTNM(4)/116/, *LENTNM(5)/111/,LENTNM(6)/107/,LENTNM(7)/0/ CALL ULSTAL (DEFNAM, -4) CALL ULSTAL (MACNAM, -10) CALL ULSTAL (INCNAM, -12) CALL ULSTAL (SUBNAM, -13) CALL ULSTAL (IFNAM, -11) CALL ULSTAL (ARNAM, -14) CALL ULSTAL (UNDEFN, -21) CALL ULSTAL(LINKNM, -4) CALL ULSTAL(LENTNM, -23) RETURN END SUBROUTINE ENTRKW INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER JUNK INTEGER ENTER BYTE SIF(3) BYTE SELSE(5) BYTE SWHILE(6) BYTE SDO(3) BYTE SBREAK(6) BYTE SNEXT(5) BYTE SFOR(4) BYTE SREPT(7) BYTE SUNTIL(6) BYTE SRET(7) BYTE SSTR(7) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/0/ DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE *(5)/0/ DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/, *SWHILE(5)/101/,SWHILE(6)/0/ DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/, *SBREAK(5)/107/,SBREAK(6)/0/ DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT *(5)/0/ DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/0/ DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT *(5)/97/,SREPT(6)/116/,SREPT(7)/0/ DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/, *SUNTIL(5)/108/,SUNTIL(6)/0/ DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1 *10/,SSTR(6)/103/,SSTR(7)/0/ JUNK = ENTER (SIF, -19, RKWTBL) JUNK = ENTER (SELSE, -11, RKWTBL) JUNK = ENTER (SWHILE, -15, RKWTBL) JUNK = ENTER (SDO, -10, RKWTBL) JUNK = ENTER (SBREAK, -8, RKWTBL) JUNK = ENTER (SNEXT, -13, RKWTBL) JUNK = ENTER (SFOR, -16, RKWTBL) JUNK = ENTER (SREPT, -17, RKWTBL) JUNK = ENTER (SUNTIL, -18, RKWTBL) JUNK = ENTER (SRET, -20, RKWTBL) JUNK = ENTER (SSTR, -23, RKWTBL) RETURN END SUBROUTINE EVALR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER ARGNO, K, M, N, T, TD INTEGER INDEX, LENGTH BYTE DIGITS(11) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ T = ARGSTK (I) TD = EVALST (T) IF (.NOT.(TD .EQ. -10))GOTO 23168 CALL DOMAC (ARGSTK, I, J) GOTO 23169 23168 CONTINUE IF (.NOT.(TD .EQ. -12))GOTO 23170 CALL DOINCR (ARGSTK, I, J) GOTO 23171 23170 CONTINUE IF (.NOT.(TD .EQ. -13))GOTO 23172 CALL DOSUB (ARGSTK, I, J) GOTO 23173 23172 CONTINUE IF (.NOT.(TD .EQ. -11))GOTO 23174 CALL DOIF (ARGSTK, I, J) GOTO 23175 23174 CONTINUE IF (.NOT.(TD .EQ. -14))GOTO 23176 CALL DOARTH (ARGSTK, I, J) GOTO 23177 23176 CONTINUE IF (.NOT.(TD .EQ. -23))GOTO 23178 CALL DOLENT (ARGSTK, I, J) GOTO 23179 23178 CONTINUE K = T + LENGTH (EVALST (T)) - 1 23180 IF (.NOT.(K .GT. T))GOTO 23182 IF (.NOT.(EVALST (K - 1) .NE. 36))GOTO 23183 CALL PUTBAK (EVALST (K)) GOTO 23184 23183 CONTINUE ARGNO = INDEX (DIGITS, EVALST (K)) - 1 IF (.NOT.(ARGNO .GE. 0))GOTO 23185 IF (.NOT.(ARGNO .LT. J - I))GOTO 23187 N = I + ARGNO + 1 M = ARGSTK (N) CALL PBSTR (EVALST (M)) 23187 CONTINUE K = K - 1 GOTO 23186 23185 CONTINUE CALL PUTBAK (EVALST (K)) 23186 CONTINUE 23184 CONTINUE 23181 K = K - 1 GOTO 23180 23182 CONTINUE IF (.NOT.(K .EQ. T))GOTO 23189 CALL PUTBAK (EVALST (K)) 23189 CONTINUE 23179 CONTINUE 23177 CONTINUE 23175 CONTINUE 23173 CONTINUE 23171 CONTINUE 23169 CONTINUE RETURN END SUBROUTINE FCLAUS BYTE TOKEN(120), T BYTE GNBTOK, DOTHER 23191 CONTINUE T = GNBTOK(TOKEN, 120) CALL PBSTR(TOKEN) T = DOTHER(TOKEN) 23192 IF (.NOT.(T .EQ. 59 .OR. T .EQ. -1))GOTO 23191 23193 CONTINUE RETURN END SUBROUTINE FINIT INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTP = 0 LEVEL = 1 LINECT (1) = 1 SBP = 1 FNAMP = 2 FNAMES (1) = 0 BP = 0 FORDEP = 0 FCNAME (1) = 0 CSP = 0 CURCND = 1 RETURN END SUBROUTINE FORCOD (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE T INTEGER I, J, NLPAR, LEN BYTE GETTOK, GNBTOK INTEGER LENGTH, LABGEN BYTE IFNOT(10) BYTE SEMI(2) BYTE ST00CZ(19) BYTE ST00DZ(19) BYTE ST00EZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ DATA SEMI(1)/59/,SEMI(2)/0/ DATA ST00CZ(1)/109/,ST00CZ(2)/105/,ST00CZ(3)/115/,ST00CZ(4)/115/, *ST00CZ(5)/105/,ST00CZ(6)/110/,ST00CZ(7)/103/,ST00CZ(8)/32/,ST00CZ( *9)/108/,ST00CZ(10)/101/,ST00CZ(11)/102/,ST00CZ(12)/116/,ST00CZ(13) */32/,ST00CZ(14)/112/,ST00CZ(15)/97/,ST00CZ(16)/114/,ST00CZ(17)/101 */,ST00CZ(18)/110/,ST00CZ(19)/0/ DATA ST00DZ(1)/105/,ST00DZ(2)/110/,ST00DZ(3)/118/,ST00DZ(4)/97/, *ST00DZ(5)/108/,ST00DZ(6)/105/,ST00DZ(7)/100/,ST00DZ(8)/32/,ST00DZ( *9)/102/,ST00DZ(10)/111/,ST00DZ(11)/114/,ST00DZ(12)/32/,ST00DZ(13)/ *99/,ST00DZ(14)/108/,ST00DZ(15)/97/,ST00DZ(16)/117/,ST00DZ(17)/115/ *,ST00DZ(18)/101/,ST00DZ(19)/0/ DATA ST00EZ(1)/102/,ST00EZ(2)/111/,ST00EZ(3)/114/,ST00EZ(4)/32/, *ST00EZ(5)/99/,ST00EZ(6)/108/,ST00EZ(7)/97/,ST00EZ(8)/117/,ST00EZ(9 *)/115/,ST00EZ(10)/101/,ST00EZ(11)/32/,ST00EZ(12)/116/,ST00EZ(13)/1 *11/,ST00EZ(14)/111/,ST00EZ(15)/32/,ST00EZ(16)/108/,ST00EZ(17)/111/ *,ST00EZ(18)/110/,ST00EZ(19)/103/,ST00EZ(20)/0/ LAB = LABGEN (3) CALL OUTCON (0) IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 40))GOTO 23194 CALL SYNERR (ST00CZ) RETURN 23194 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 59))GOTO 23196 CALL PBSTR (SCRTOK) CALL FCLAUS 23196 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 59))GOTO 23198 CALL OUTCON (LAB) GOTO 23199 23198 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) CALL OUTTAB CALL OUTSTR (IFNOT) CALL OUTCH (40) NLPAR = 0 23200 IF (.NOT.(NLPAR .GE. 0))GOTO 23201 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 59))GOTO 23202 GOTO 23201 23202 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23204 NLPAR = NLPAR + 1 GOTO 23205 23204 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23206 NLPAR = NLPAR - 1 23206 CONTINUE 23205 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23208 CALL PBSTR (SCRTOK) RETURN 23208 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23210 CALL OUTSTR (SCRTOK) 23210 CONTINUE GOTO 23200 23201 CONTINUE CALL OUTCH (41) CALL OUTCH (41) CALL OUTGO (LAB+2) IF (.NOT.(NLPAR .LT. 0))GOTO 23212 CALL SYNERR (ST00DZ) 23212 CONTINUE 23199 CONTINUE FORDEP = FORDEP + 1 LEN = 0 J = 1 I = 1 23214 IF (.NOT.(I .LT. FORDEP))GOTO 23216 J = J + LENGTH (FORSTK (J)) + 1 23215 I = I + 1 GOTO 23214 23216 CONTINUE FORSTK (J) = 0 NLPAR = 0 T = GNBTOK (SCRTOK, 120) CALL PBSTR (SCRTOK) 23217 IF (.NOT.(NLPAR .GE. 0))GOTO 23218 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 40))GOTO 23219 NLPAR = NLPAR + 1 GOTO 23220 23219 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23221 NLPAR = NLPAR - 1 23221 CONTINUE 23220 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23223 CALL PBSTR (SCRTOK) GOTO 23218 23223 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10))GOTO 23225 IF (.NOT.(J + LENGTH (SCRTOK) .GE. 300))GOTO 23227 CALL BADERR (ST00EZ) 23227 CONTINUE CALL SCOPY (SCRTOK, 1, FORSTK, J) J = J + LENGTH (SCRTOK) LEN = LEN + LENGTH (SCRTOK) 23225 CONTINUE GOTO 23217 23218 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER I, J INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) J = 1 I = 1 23229 IF (.NOT.(I .LT. FORDEP))GOTO 23231 J = J + LENGTH (FORSTK (J)) + 1 23230 I = I + 1 GOTO 23229 23231 CONTINUE IF (.NOT.(LENGTH (FORSTK (J)) .GT. 0))GOTO 23232 CALL PUTBAK (59) CALL PBSTR (FORSTK (J)) CALL FCLAUS 23232 CONTINUE CALL OUTGO (LAB - 1) CALL OUTCON (LAB + 1) FORDEP = FORDEP - 1 RETURN END BYTE FUNCTION GCTOK(TOKEN, TOKSIZ) BYTE TOKEN(120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE TEMP(9) INTEGER CTYPE, I, N, J, CNDVAL(4), NEWCND, VALUE BYTE GTOK INTEGER EQUAL, LOOKUP BYTE LETTS(5) BYTE CNDTBL(31) BYTE ST00FZ(27) BYTE ST00GZ(31) BYTE ST00HZ(27) BYTE ST00IZ(26) BYTE ST00JZ(27) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA LETTS(1)/101/,LETTS(2)/69/,LETTS(3)/105/,LETTS(4)/73/,LETTS(5 *)/0/ DATA CNDTBL(1)/105/,CNDTBL(2)/102/,CNDTBL(3)/100/,CNDTBL(4)/101/, *CNDTBL(5)/102/,CNDTBL(6)/47/,CNDTBL(7)/105/,CNDTBL(8)/102/,CNDTBL( *9)/110/,CNDTBL(10)/111/,CNDTBL(11)/116/,CNDTBL(12)/100/,CNDTBL(13) */101/,CNDTBL(14)/102/,CNDTBL(15)/47/,CNDTBL(16)/101/,CNDTBL(17)/10 *8/,CNDTBL(18)/115/,CNDTBL(19)/101/,CNDTBL(20)/100/,CNDTBL(21)/101/ *,CNDTBL(22)/102/,CNDTBL(23)/47/,CNDTBL(24)/101/,CNDTBL(25)/110/, *CNDTBL(26)/100/,CNDTBL(27)/100/,CNDTBL(28)/101/,CNDTBL(29)/102/, *CNDTBL(30)/47/,CNDTBL(31)/0/ DATA CNDVAL(1)/-15/, CNDVAL(2)/-16/, CNDVAL(3)/-17/, CNDVAL(4)/-18 */ DATA ST00FZ(1)/73/,ST00FZ(2)/108/,ST00FZ(3)/108/,ST00FZ(4)/101/, *ST00FZ(5)/103/,ST00FZ(6)/97/,ST00FZ(7)/108/,ST00FZ(8)/32/,ST00FZ(9 *)/101/,ST00FZ(10)/110/,ST00FZ(11)/100/,ST00FZ(12)/100/,ST00FZ(13)/ *101/,ST00FZ(14)/102/,ST00FZ(15)/32/,ST00FZ(16)/101/,ST00FZ(17)/110 */,ST00FZ(18)/99/,ST00FZ(19)/111/,ST00FZ(20)/117/,ST00FZ(21)/110/, *ST00FZ(22)/116/,ST00FZ(23)/101/,ST00FZ(24)/114/,ST00FZ(25)/101/, *ST00FZ(26)/100/,ST00FZ(27)/0/ DATA ST00GZ(1)/67/,ST00GZ(2)/111/,ST00GZ(3)/110/,ST00GZ(4)/100/, *ST00GZ(5)/105/,ST00GZ(6)/116/,ST00GZ(7)/105/,ST00GZ(8)/111/,ST00GZ *(9)/110/,ST00GZ(10)/97/,ST00GZ(11)/108/,ST00GZ(12)/115/,ST00GZ(13) */32/,ST00GZ(14)/110/,ST00GZ(15)/101/,ST00GZ(16)/115/,ST00GZ(17)/11 *6/,ST00GZ(18)/101/,ST00GZ(19)/100/,ST00GZ(20)/32/,ST00GZ(21)/116/, *ST00GZ(22)/111/,ST00GZ(23)/111/,ST00GZ(24)/32/,ST00GZ(25)/100/, *ST00GZ(26)/101/,ST00GZ(27)/101/,ST00GZ(28)/112/,ST00GZ(29)/108/, *ST00GZ(30)/121/,ST00GZ(31)/0/ DATA ST00HZ(1)/109/,ST00HZ(2)/105/,ST00HZ(3)/115/,ST00HZ(4)/115/, *ST00HZ(5)/105/,ST00HZ(6)/110/,ST00HZ(7)/103/,ST00HZ(8)/32/,ST00HZ( *9)/96/,ST00HZ(10)/40/,ST00HZ(11)/39/,ST00HZ(12)/32/,ST00HZ(13)/105 */,ST00HZ(14)/110/,ST00HZ(15)/32/,ST00HZ(16)/99/,ST00HZ(17)/111/, *ST00HZ(18)/110/,ST00HZ(19)/100/,ST00HZ(20)/105/,ST00HZ(21)/116/, *ST00HZ(22)/105/,ST00HZ(23)/111/,ST00HZ(24)/110/,ST00HZ(25)/97/, *ST00HZ(26)/108/,ST00HZ(27)/0/ DATA ST00IZ(1)/105/,ST00IZ(2)/110/,ST00IZ(3)/118/,ST00IZ(4)/97/, *ST00IZ(5)/108/,ST00IZ(6)/105/,ST00IZ(7)/100/,ST00IZ(8)/32/,ST00IZ( *9)/99/,ST00IZ(10)/111/,ST00IZ(11)/110/,ST00IZ(12)/100/,ST00IZ(13)/ *105/,ST00IZ(14)/116/,ST00IZ(15)/105/,ST00IZ(16)/111/,ST00IZ(17)/11 *0/,ST00IZ(18)/97/,ST00IZ(19)/108/,ST00IZ(20)/32/,ST00IZ(21)/116/, *ST00IZ(22)/111/,ST00IZ(23)/107/,ST00IZ(24)/101/,ST00IZ(25)/110/, *ST00IZ(26)/0/ DATA ST00JZ(1)/109/,ST00JZ(2)/105/,ST00JZ(3)/115/,ST00JZ(4)/115/, *ST00JZ(5)/105/,ST00JZ(6)/110/,ST00JZ(7)/103/,ST00JZ(8)/32/,ST00JZ( *9)/96/,ST00JZ(10)/41/,ST00JZ(11)/39/,ST00JZ(12)/32/,ST00JZ(13)/105 */,ST00JZ(14)/110/,ST00JZ(15)/32/,ST00JZ(16)/99/,ST00JZ(17)/111/, *ST00JZ(18)/110/,ST00JZ(19)/100/,ST00JZ(20)/105/,ST00JZ(21)/116/, *ST00JZ(22)/105/,ST00JZ(23)/111/,ST00JZ(24)/110/,ST00JZ(25)/97/, *ST00JZ(26)/108/,ST00JZ(27)/0/ 23234 CONTINUE GCTOK = GTOK (TOKEN, TOKSIZ) IF (.NOT.(GCTOK .EQ. -1))GOTO 23237 GOTO 23236 23237 CONTINUE CTYPE = -19 I = 1 23239 IF (.NOT.(LETTS(I) .NE. 0))GOTO 23241 IF (.NOT.(LETTS(I) .EQ. TOKEN(1)))GOTO 23242 GOTO 23241 23242 CONTINUE 23240 I = I + 1 GOTO 23239 23241 CONTINUE IF (.NOT.(LETTS(I) .NE. 0))GOTO 23244 N = 1 I = 1 23246 IF (.NOT.(CNDTBL(I) .NE. 0))GOTO 23248 J = 1 23249 IF (.NOT.(CNDTBL(I) .NE. 47))GOTO 23251 TEMP(J) = CNDTBL(I) I = I + 1 23250 J = J + 1 GOTO 23249 23251 CONTINUE TEMP(J) = 0 J = EQUAL(TOKEN, TEMP) IF (.NOT.(J .EQ. 0))GOTO 23252 CALL UPPER(TEMP) J = EQUAL(TOKEN, TEMP) 23252 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23254 CTYPE = CNDVAL(N) GOTO 23248 23254 CONTINUE N = N + 1 23247 I = I + 1 GOTO 23246 23248 CONTINUE 23244 CONTINUE IF (.NOT.(CTYPE .EQ. -19))GOTO 23256 IF (.NOT.(CURCND .EQ. 1))GOTO 23258 GOTO 23236 23258 CONTINUE GOTO 23257 23256 CONTINUE IF (.NOT.(CTYPE .EQ. -18))GOTO 23260 IF (.NOT.(CSP .LE. 0))GOTO 23262 CALL BADERR(ST00FZ) 23262 CONTINUE CURCND = CNDSTK(CSP) CSP = CSP - 1 GOTO 23261 23260 CONTINUE IF (.NOT.(CTYPE .EQ. -17))GOTO 23264 NEWCND = - CURCND GOTO 23265 23264 CONTINUE IF (.NOT.(CSP .GE. 10))GOTO 23266 CALL BADERR(ST00GZ) 23266 CONTINUE CSP = CSP + 1 CNDSTK(CSP) = CURCND CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 40))GOTO 23268 CALL BADERR(ST00HZ) 23268 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. -9))GOTO 23270 CALL BADERR(ST00IZ) 23270 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 41))GOTO 23272 CALL BADERR(ST00JZ) 23272 CONTINUE IF (.NOT.(LOOKUP(TOKEN, VALUE, DEFTBL) .EQ. 1))GOTO 23274 NEWCND = 1 GOTO 23275 23274 CONTINUE NEWCND = - 1 23275 CONTINUE IF (.NOT.(CTYPE .EQ. -16))GOTO 23276 NEWCND = - NEWCND 23276 CONTINUE 23265 CONTINUE CURCND = MIN0(NEWCND, CNDSTK (CSP) ) 23261 CONTINUE 23257 CONTINUE 23235 GOTO 23234 23236 CONTINUE RETURN END INTEGER FUNCTION GENNAM(ROOT, COUNTR, BUF) BYTE ROOT(100), BUF(7), TEMP(4) INTEGER COUNTR, X, I, D, J BYTE DIGITS(31) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/0/ X = COUNTR COUNTR = COUNTR + 1 IF (.NOT.(COUNTR .GT. 27000))GOTO 23278 COUNTR = 1 23278 CONTINUE I = 1 23280 IF (.NOT.(X .GT. 0))GOTO 23282 D = MOD(X, 30) + 1 TEMP(I) = DIGITS(D) X = X / 30 23281 I = I + 1 GOTO 23280 23282 CONTINUE TEMP(I) = 0 J = 1 CALL INSSTR(ROOT, BUF, J, 6) X = 4 - I 23283 IF (.NOT.(X .GT. 0))GOTO 23285 CALL INSCHR(48, BUF, J, 6) 23284 X = X - 1 GOTO 23283 23285 CONTINUE I = I - 1 23286 IF (.NOT.(I .GT. 0))GOTO 23288 CALL INSCHR(TEMP(I), BUF, J, 6) 23287 I = I - 1 GOTO 23286 23288 CONTINUE CALL INSCHR(122, BUF, J, 6) BUF(J) = 0 GENNAM=(J-1) RETURN END SUBROUTINE GETDEF (TOKEN, TOKSIZ, DEFN, DEFSIZ) BYTE TOKEN (120), DEFN (250) INTEGER TOKSIZ, DEFSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE C, T, PTOKEN (120) INTEGER I, NLPAR BYTE GCTOK, NGETCH BYTE ST00KZ(22) BYTE ST00LZ(20) BYTE ST00MZ(24) BYTE ST00NZ(20) BYTE ST00OZ(20) BYTE ST00PZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST00KZ(1)/110/,ST00KZ(2)/111/,ST00KZ(3)/110/,ST00KZ(4)/45/, *ST00KZ(5)/97/,ST00KZ(6)/108/,ST00KZ(7)/112/,ST00KZ(8)/104/,ST00KZ( *9)/97/,ST00KZ(10)/110/,ST00KZ(11)/117/,ST00KZ(12)/109/,ST00KZ(13)/ *101/,ST00KZ(14)/114/,ST00KZ(15)/105/,ST00KZ(16)/99/,ST00KZ(17)/32/ *,ST00KZ(18)/110/,ST00KZ(19)/97/,ST00KZ(20)/109/,ST00KZ(21)/101/, *ST00KZ(22)/0/ DATA ST00LZ(1)/100/,ST00LZ(2)/101/,ST00LZ(3)/102/,ST00LZ(4)/105/, *ST00LZ(5)/110/,ST00LZ(6)/105/,ST00LZ(7)/116/,ST00LZ(8)/105/,ST00LZ *(9)/111/,ST00LZ(10)/110/,ST00LZ(11)/32/,ST00LZ(12)/116/,ST00LZ(13) */111/,ST00LZ(14)/111/,ST00LZ(15)/32/,ST00LZ(16)/108/,ST00LZ(17)/11 *1/,ST00LZ(18)/110/,ST00LZ(19)/103/,ST00LZ(20)/0/ DATA ST00MZ(1)/109/,ST00MZ(2)/105/,ST00MZ(3)/115/,ST00MZ(4)/115/, *ST00MZ(5)/105/,ST00MZ(6)/110/,ST00MZ(7)/103/,ST00MZ(8)/32/,ST00MZ( *9)/99/,ST00MZ(10)/111/,ST00MZ(11)/109/,ST00MZ(12)/109/,ST00MZ(13)/ *97/,ST00MZ(14)/32/,ST00MZ(15)/105/,ST00MZ(16)/110/,ST00MZ(17)/32/, *ST00MZ(18)/100/,ST00MZ(19)/101/,ST00MZ(20)/102/,ST00MZ(21)/105/, *ST00MZ(22)/110/,ST00MZ(23)/101/,ST00MZ(24)/0/ DATA ST00NZ(1)/100/,ST00NZ(2)/101/,ST00NZ(3)/102/,ST00NZ(4)/105/, *ST00NZ(5)/110/,ST00NZ(6)/105/,ST00NZ(7)/116/,ST00NZ(8)/105/,ST00NZ *(9)/111/,ST00NZ(10)/110/,ST00NZ(11)/32/,ST00NZ(12)/116/,ST00NZ(13) */111/,ST00NZ(14)/111/,ST00NZ(15)/32/,ST00NZ(16)/108/,ST00NZ(17)/11 *1/,ST00NZ(18)/110/,ST00NZ(19)/103/,ST00NZ(20)/0/ DATA ST00OZ(1)/109/,ST00OZ(2)/105/,ST00OZ(3)/115/,ST00OZ(4)/115/, *ST00OZ(5)/105/,ST00OZ(6)/110/,ST00OZ(7)/103/,ST00OZ(8)/32/,ST00OZ( *9)/114/,ST00OZ(10)/105/,ST00OZ(11)/103/,ST00OZ(12)/104/,ST00OZ(13) */116/,ST00OZ(14)/32/,ST00OZ(15)/112/,ST00OZ(16)/97/,ST00OZ(17)/114 */,ST00OZ(18)/101/,ST00OZ(19)/110/,ST00OZ(20)/0/ DATA ST00PZ(1)/103/,ST00PZ(2)/101/,ST00PZ(3)/116/,ST00PZ(4)/100/, *ST00PZ(5)/101/,ST00PZ(6)/102/,ST00PZ(7)/32/,ST00PZ(8)/105/,ST00PZ( *9)/115/,ST00PZ(10)/32/,ST00PZ(11)/99/,ST00PZ(12)/111/,ST00PZ(13)/1 *10/,ST00PZ(14)/102/,ST00PZ(15)/117/,ST00PZ(16)/115/,ST00PZ(17)/101 */,ST00PZ(18)/100/,ST00PZ(19)/0/ CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(C .EQ. 40))GOTO 23289 T = 40 GOTO 23290 23289 CONTINUE T = 32 CALL PBSTR (PTOKEN) 23290 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK (TOKEN, TOKSIZ) .NE. -9))GOTO 23291 CALL BADERR (ST00KZ) 23291 CONTINUE CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(T .EQ. 32))GOTO 23293 CALL PBSTR (PTOKEN) I = 1 23295 CONTINUE C = NGETCH (C) IF (.NOT.(I .GT. DEFSIZ))GOTO 23298 CALL BADERR (ST00LZ) 23298 CONTINUE DEFN (I) = C I = I + 1 23296 IF (.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23295 23297 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23300 CALL PUTBAK (C) 23300 CONTINUE GOTO 23294 23293 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23302 IF (.NOT.(C .NE. 44))GOTO 23304 CALL BADERR (ST00MZ) 23304 CONTINUE NLPAR = 0 I = 1 23306 IF (.NOT.(NLPAR .GE. 0))GOTO 23308 IF (.NOT.(I .GT. DEFSIZ))GOTO 23309 CALL BADERR (ST00NZ) GOTO 23310 23309 CONTINUE IF (.NOT.(NGETCH (DEFN (I)) .EQ. -1))GOTO 23311 CALL BADERR (ST00OZ) GOTO 23312 23311 CONTINUE IF (.NOT.(DEFN (I) .EQ. 40))GOTO 23313 NLPAR = NLPAR + 1 GOTO 23314 23313 CONTINUE IF (.NOT.(DEFN (I) .EQ. 41))GOTO 23315 NLPAR = NLPAR - 1 23315 CONTINUE 23314 CONTINUE 23312 CONTINUE 23310 CONTINUE 23307 I = I + 1 GOTO 23306 23308 CONTINUE GOTO 23303 23302 CONTINUE CALL BADERR (ST00PZ) 23303 CONTINUE 23294 CONTINUE DEFN (I - 1) = 0 RETURN END BYTE FUNCTION GETTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER I, LEN BYTE NAME (36), T, TBUF(9) INTEGER EQUAL, OPEN, LENGTH BYTE DEFTOK BYTE FNCN(9) BYTE INCL(8) BYTE ST00QZ(22) BYTE ST00RZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11 *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/0/ DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11 *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/0/ DATA ST00QZ(1)/109/,ST00QZ(2)/105/,ST00QZ(3)/115/,ST00QZ(4)/115/, *ST00QZ(5)/105/,ST00QZ(6)/110/,ST00QZ(7)/103/,ST00QZ(8)/32/,ST00QZ( *9)/102/,ST00QZ(10)/117/,ST00QZ(11)/110/,ST00QZ(12)/99/,ST00QZ(13)/ *116/,ST00QZ(14)/105/,ST00QZ(15)/111/,ST00QZ(16)/110/,ST00QZ(17)/32 */,ST00QZ(18)/110/,ST00QZ(19)/97/,ST00QZ(20)/109/,ST00QZ(21)/101/, *ST00QZ(22)/0/ DATA ST00RZ(1)/99/,ST00RZ(2)/97/,ST00RZ(3)/110/,ST00RZ(4)/39/, *ST00RZ(5)/116/,ST00RZ(6)/32/,ST00RZ(7)/111/,ST00RZ(8)/112/,ST00RZ( *9)/101/,ST00RZ(10)/110/,ST00RZ(11)/32/,ST00RZ(12)/105/,ST00RZ(13)/ *110/,ST00RZ(14)/99/,ST00RZ(15)/108/,ST00RZ(16)/117/,ST00RZ(17)/100 */,ST00RZ(18)/101/,ST00RZ(19)/0/ 23317 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ) IF (.NOT.(GETTOK .EQ. -1))GOTO 23320 GOTO 23319 23320 CONTINUE IF (.NOT.(GETTOK .NE. -9))GOTO 23322 RETURN 23322 CONTINUE 23321 CONTINUE I = 1 23324 IF (.NOT.(I .LE. 9))GOTO 23326 T = TOKEN(I) TBUF(I) = T IF (.NOT.(T .EQ. 0))GOTO 23327 GOTO 23326 23327 CONTINUE 23325 I = I + 1 GOTO 23324 23326 CONTINUE IF (.NOT.(I .LT. 8 .OR. T .NE. 0))GOTO 23329 RETURN 23329 CONTINUE CALL FOLD(TBUF) IF (.NOT.(EQUAL (TBUF, FNCN) .EQ. 1))GOTO 23331 CALL SKPBLK T = DEFTOK (FCNAME, 36) CALL PBSTR (FCNAME) IF (.NOT.(T .NE. -9))GOTO 23333 CALL SYNERR (ST00QZ) 23333 CONTINUE CALL PUTBAK (32) RETURN 23331 CONTINUE IF (.NOT.(EQUAL (TBUF, INCL) .EQ. 0))GOTO 23335 RETURN 23335 CONTINUE 23332 CONTINUE CALL SKPBLK T = DEFTOK (NAME, 36) IF (.NOT.(T .EQ. 34))GOTO 23337 LEN = LENGTH (NAME) - 1 I = 1 23339 IF (.NOT.(I .LT. LEN))GOTO 23341 NAME (I) = NAME (I + 1) 23340 I = I + 1 GOTO 23339 23341 CONTINUE NAME (I) = 0 23337 CONTINUE I = LENGTH (NAME) + 1 CALL SYNERR (ST00RZ) 23318 GOTO 23317 23319 CONTINUE TOKEN (1) = -1 TOKEN (2) = 0 GETTOK = -1 RETURN END SUBROUTINE GETUND(TOKEN) BYTE TOKEN(120), TEMP(4) BYTE GCTOK BYTE ST00SZ(24) BYTE ST00TZ(22) BYTE ST010Z(24) DATA ST00SZ(1)/109/,ST00SZ(2)/105/,ST00SZ(3)/115/,ST00SZ(4)/115/, *ST00SZ(5)/105/,ST00SZ(6)/110/,ST00SZ(7)/103/,ST00SZ(8)/32/,ST00SZ( *9)/96/,ST00SZ(10)/40/,ST00SZ(11)/39/,ST00SZ(12)/32/,ST00SZ(13)/105 */,ST00SZ(14)/110/,ST00SZ(15)/32/,ST00SZ(16)/117/,ST00SZ(17)/110/, *ST00SZ(18)/100/,ST00SZ(19)/101/,ST00SZ(20)/102/,ST00SZ(21)/105/, *ST00SZ(22)/110/,ST00SZ(23)/101/,ST00SZ(24)/0/ DATA ST00TZ(1)/110/,ST00TZ(2)/111/,ST00TZ(3)/110/,ST00TZ(4)/45/, *ST00TZ(5)/97/,ST00TZ(6)/108/,ST00TZ(7)/112/,ST00TZ(8)/104/,ST00TZ( *9)/97/,ST00TZ(10)/110/,ST00TZ(11)/117/,ST00TZ(12)/109/,ST00TZ(13)/ *101/,ST00TZ(14)/114/,ST00TZ(15)/105/,ST00TZ(16)/99/,ST00TZ(17)/32/ *,ST00TZ(18)/110/,ST00TZ(19)/97/,ST00TZ(20)/109/,ST00TZ(21)/101/, *ST00TZ(22)/0/ DATA ST010Z(1)/109/,ST010Z(2)/105/,ST010Z(3)/115/,ST010Z(4)/115/, *ST010Z(5)/105/,ST010Z(6)/110/,ST010Z(7)/103/,ST010Z(8)/32/,ST010Z( *9)/96/,ST010Z(10)/41/,ST010Z(11)/39/,ST010Z(12)/32/,ST010Z(13)/105 */,ST010Z(14)/110/,ST010Z(15)/32/,ST010Z(16)/117/,ST010Z(17)/110/, *ST010Z(18)/100/,ST010Z(19)/101/,ST010Z(20)/102/,ST010Z(21)/105/, *ST010Z(22)/110/,ST010Z(23)/101/,ST010Z(24)/0/ CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. 40))GOTO 23342 CALL BADERR(ST00SZ) 23342 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. -9))GOTO 23344 CALL BADERR(ST00TZ) 23344 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TEMP, 4) .NE. 41))GOTO 23346 CALL BADERR(ST010Z) 23346 CONTINUE RETURN END BYTE FUNCTION GNBTOK (TOKEN, TOKSIZ) BYTE TOKEN (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE GETTOK COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23348 CONTINUE CALL SKPBLK GNBTOK = GETTOK (TOKEN, TOKSIZ) 23349 IF (.NOT.(GNBTOK .NE. 32))GOTO 23348 23350 CONTINUE RETURN END BYTE FUNCTION GTOK (LEXSTR, TOKSIZ) BYTE LEXSTR (120) INTEGER TOKSIZ INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE C INTEGER I, B, N, D BYTE NGETCH, CLOWER, ESC INTEGER ITOC, INDEX, CTOI BYTE CTYPE BYTE TYPE BYTE DIGITS(37) BYTE ALFCHR(2) BYTE ST011Z(14) BYTE ST012Z(40) BYTE ST013Z(22) BYTE ST014Z(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/117/,DIGITS(32)/118/,DIGITS(33)/119/, *DIGITS(34)/120/,DIGITS(35)/121/,DIGITS(36)/122/,DIGITS(37)/0/ DATA ALFCHR(1)/95/,ALFCHR(2)/0/ DATA ST011Z(1)/109/,ST011Z(2)/105/,ST011Z(3)/115/,ST011Z(4)/115/, *ST011Z(5)/105/,ST011Z(6)/110/,ST011Z(7)/103/,ST011Z(8)/32/,ST011Z( *9)/113/,ST011Z(10)/117/,ST011Z(11)/111/,ST011Z(12)/116/,ST011Z(13) */101/,ST011Z(14)/0/ DATA ST012Z(1)/109/,ST012Z(2)/105/,ST012Z(3)/115/,ST012Z(4)/115/, *ST012Z(5)/105/,ST012Z(6)/110/,ST012Z(7)/103/,ST012Z(8)/32/,ST012Z( *9)/97/,ST012Z(10)/112/,ST012Z(11)/111/,ST012Z(12)/115/,ST012Z(13)/ *116/,ST012Z(14)/114/,ST012Z(15)/111/,ST012Z(16)/112/,ST012Z(17)/10 *4/,ST012Z(18)/101/,ST012Z(19)/32/,ST012Z(20)/105/,ST012Z(21)/110/, *ST012Z(22)/32/,ST012Z(23)/99/,ST012Z(24)/104/,ST012Z(25)/97/, *ST012Z(26)/114/,ST012Z(27)/97/,ST012Z(28)/99/,ST012Z(29)/116/, *ST012Z(30)/101/,ST012Z(31)/114/,ST012Z(32)/32/,ST012Z(33)/108/, *ST012Z(34)/105/,ST012Z(35)/116/,ST012Z(36)/101/,ST012Z(37)/114/, *ST012Z(38)/97/,ST012Z(39)/108/,ST012Z(40)/0/ DATA ST013Z(1)/109/,ST013Z(2)/105/,ST013Z(3)/115/,ST013Z(4)/115/, *ST013Z(5)/105/,ST013Z(6)/110/,ST013Z(7)/103/,ST013Z(8)/32/,ST013Z( *9)/108/,ST013Z(10)/105/,ST013Z(11)/116/,ST013Z(12)/101/,ST013Z(13) */114/,ST013Z(14)/97/,ST013Z(15)/108/,ST013Z(16)/32/,ST013Z(17)/113 */,ST013Z(18)/117/,ST013Z(19)/111/,ST013Z(20)/116/,ST013Z(21)/101/, *ST013Z(22)/0/ DATA ST014Z(1)/116/,ST014Z(2)/111/,ST014Z(3)/107/,ST014Z(4)/101/, *ST014Z(5)/110/,ST014Z(6)/32/,ST014Z(7)/116/,ST014Z(8)/111/,ST014Z( *9)/111/,ST014Z(10)/32/,ST014Z(11)/108/,ST014Z(12)/111/,ST014Z(13)/ *110/,ST014Z(14)/103/,ST014Z(15)/0/ 23351 CONTINUE C = NGETCH (LEXSTR (1)) IF (.NOT.(C .EQ. 95))GOTO 23354 IF (.NOT.(NGETCH(C) .NE. 10))GOTO 23356 CALL PUTBAK(C) C = 95 GOTO 23353 23356 CONTINUE 23354 CONTINUE 23352 IF (.NOT.(LEXSTR(1) .NE. 95))GOTO 23351 23353 CONTINUE IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23358 LEXSTR (1) = 32 23360 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23361 C = NGETCH (C) GOTO 23360 23361 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23362 23364 IF (.NOT.(NGETCH (C) .NE. 10))GOTO 23365 GOTO 23364 23365 CONTINUE 23362 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23366 CALL PUTBAK (C) GOTO 23367 23366 CONTINUE LEXSTR (1) = 10 23367 CONTINUE LEXSTR (2) = 0 GTOK = LEXSTR (1) RETURN 23358 CONTINUE I = 1 IF (.NOT.(TYPE(C) .EQ. 1))GOTO 23368 I = 1 23370 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23372 C = NGETCH (LEXSTR (I + 1)) CTYPE = TYPE(C) IF (.NOT.(CTYPE .NE. 1 .AND. CTYPE .NE. 2 .AND. INDEX(ALFCHR, C) *.EQ. 0))GOTO 23373 GOTO 23372 23373 CONTINUE 23371 I = I + 1 GOTO 23370 23372 CONTINUE CALL PUTBAK (C) GTOK = -9 GOTO 23369 23368 CONTINUE IF (.NOT.(TYPE(C) .EQ. 2))GOTO 23375 I = 1 23377 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23379 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(TYPE(C) .NE. 2))GOTO 23380 GOTO 23379 23380 CONTINUE 23378 I = I + 1 GOTO 23377 23379 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23382 LEXSTR(I + 1) = 0 N = 1 B = CTOI(LEXSTR, N) 23382 CONTINUE IF (.NOT.(C .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO 23384 N = 0 23386 CONTINUE D = INDEX (DIGITS, CLOWER (NGETCH (C))) - 1 IF (.NOT.(D .LT. 0))GOTO 23389 GOTO 23388 23389 CONTINUE N = B * N + D 23387 GOTO 23386 23388 CONTINUE CALL PUTBAK (C) I = ITOC (N, LEXSTR, TOKSIZ) GOTO 23385 23384 CONTINUE CALL PUTBAK (C) 23385 CONTINUE GTOK = 2 GOTO 23376 23375 CONTINUE IF (.NOT.(C .EQ. 91))GOTO 23391 LEXSTR (1) = 123 GTOK = 123 GOTO 23392 23391 CONTINUE IF (.NOT.(C .EQ. 93))GOTO 23393 LEXSTR (1) = 125 GTOK = 125 GOTO 23394 23393 CONTINUE IF (.NOT.(C .EQ. 36))GOTO 23395 IF (.NOT.(NGETCH (LEXSTR (2)) .EQ. 40))GOTO 23397 I = 2 GTOK = -10 GOTO 23398 23397 CONTINUE IF (.NOT.(LEXSTR (2) .EQ. 41))GOTO 23399 I = 2 GTOK = -11 GOTO 23400 23399 CONTINUE CALL PUTBAK (LEXSTR (2)) GTOK = 36 23400 CONTINUE 23398 CONTINUE GOTO 23396 23395 CONTINUE IF (.NOT.(C .EQ. 34 .OR. C .EQ. 39))GOTO 23401 GTOK = C I = 2 23403 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23405 LEXSTR(I) = C IF (.NOT.(LEXSTR(I) .EQ. 95))GOTO 23406 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23408 23410 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23411 C = NGETCH(C) GOTO 23410 23411 CONTINUE LEXSTR(I) = C GOTO 23409 23408 CONTINUE CALL PUTBAK(C) 23409 CONTINUE C = LEXSTR(I) 23406 CONTINUE IF (.NOT.(C .EQ. 64))GOTO 23412 IF (.NOT.(NGETCH(C) .EQ. -1))GOTO 23414 CALL PUTBAK(C) GOTO 23415 23414 CONTINUE I = I + 1 IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23416 I = TOKSIZ - 1 23416 CONTINUE LEXSTR(I) = C 23415 CONTINUE C = 64 23412 CONTINUE IF (.NOT.(C .EQ. LEXSTR(1)))GOTO 23418 GOTO 23405 23418 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23420 CALL SYNERR (ST011Z) LEXSTR(I) = LEXSTR(1) CALL PUTBAK(10) GOTO 23405 23420 CONTINUE 23404 I = I + 1 GOTO 23403 23405 CONTINUE IF (.NOT.(LEXSTR(1) .EQ. 39))GOTO 23422 N = 2 C = ESC(LEXSTR, N) IF (.NOT.(LEXSTR(N + 1) .NE. 39))GOTO 23424 CALL SYNERR(ST012Z) 23424 CONTINUE N = C I = ITOC(N, LEXSTR, TOKSIZ) GTOK = 2 23422 CONTINUE GOTO 23402 23401 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23426 IF (.NOT.(NGETCH(LEXSTR(2)) .NE. 40))GOTO 23428 CALL PUTBAK(LEXSTR(2)) GTOK = 37 GOTO 23429 23428 CONTINUE GTOK = 34 LEXSTR(1) = -12 I = 2 23430 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23432 LEXSTR(I) = C IF (.NOT.(C .EQ. 95))GOTO 23433 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23435 23437 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23438 C = NGETCH(C) GOTO 23437 23438 CONTINUE LEXSTR(I) = C GOTO 23436 23435 CONTINUE CALL PUTBAK(C) 23436 CONTINUE C = LEXSTR(I) 23433 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23439 IF (.NOT.(NGETCH(C) .EQ. 41))GOTO 23441 LEXSTR(I) = -12 GOTO 23432 23441 CONTINUE CALL PUTBAK(C) 23442 CONTINUE 23439 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23443 CALL SYNERR(ST013Z) LEXSTR(I) = -12 CALL PUTBAK(10) GOTO 23432 23443 CONTINUE 23431 I = I + 1 GOTO 23430 23432 CONTINUE 23429 CONTINUE GOTO 23427 23426 CONTINUE IF (.NOT.(C .EQ. -12))GOTO 23445 GTOK = 34 I = 2 23447 IF (.NOT.(NGETCH(LEXSTR(I)) .NE. -12))GOTO 23449 23448 I = I + 1 GOTO 23447 23449 CONTINUE GOTO 23446 23445 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23450 23452 IF (.NOT.(NGETCH (LEXSTR (1)) .NE. 10))GOTO 23453 GOTO 23452 23453 CONTINUE GTOK = 10 GOTO 23451 23450 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 38 . *OR. C .EQ. 124 .OR. C .EQ. 61 .OR. C .EQ. 33 .OR. C .EQ. 126 .OR. *C .EQ. 94))GOTO 23454 CALL RELATE (LEXSTR, I) GTOK = C GOTO 23455 23454 CONTINUE GTOK = C 23455 CONTINUE 23451 CONTINUE 23446 CONTINUE 23427 CONTINUE 23402 CONTINUE 23396 CONTINUE 23394 CONTINUE 23392 CONTINUE 23376 CONTINUE 23369 CONTINUE IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23456 CALL SYNERR (ST014Z) 23456 CONTINUE LEXSTR (I + 1) = 0 RETURN END SUBROUTINE IFCODE (LAB) INTEGER LAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER LABGEN COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 LAB = LABGEN (2) CALL IFGO (LAB) RETURN END SUBROUTINE IFGO (LAB) INTEGER LAB BYTE IFNOT(10) 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)/0/ CALL OUTTAB CALL OUTSTR (IFNOT) CALL BALPAR CALL OUTCH (41) CALL OUTGO (LAB) RETURN END INTEGER FUNCTION IFPARM (STRNG) BYTE STRNG (100) BYTE C INTEGER I INTEGER INDEX BYTE 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 .OR. C .EQ. -23))GOTO 23458 IFPARM = 1 GOTO 23459 23458 CONTINUE IFPARM = 0 I = 1 23460 IF (.NOT.(INDEX (STRNG (I), 36) .GT. 0))GOTO 23462 I = I + INDEX (STRNG (I), 36) IF (.NOT.(TYPE (STRNG (I)) .EQ. 2))GOTO 23463 IF (.NOT.(TYPE (STRNG (I + 1)) .NE. 2))GOTO 23465 IFPARM = 1 GOTO 23462 23465 CONTINUE 23463 CONTINUE 23461 GOTO 23460 23462 CONTINUE 23459 CONTINUE RETURN END SUBROUTINE INITKW INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER MKTABL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT (4250) DEFTBL = MKTABL (1) CALL ENTDKW RKWTBL = MKTABL (1) CALL ENTRKW LABEL = 23000 STRCNT = 1 RETURN END SUBROUTINE INSCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ BYTE C, BUF(100) BYTE ST015Z(16) DATA ST015Z(1)/98/,ST015Z(2)/117/,ST015Z(3)/102/,ST015Z(4)/102/, *ST015Z(5)/101/,ST015Z(6)/114/,ST015Z(7)/32/,ST015Z(8)/111/,ST015Z( *9)/118/,ST015Z(10)/101/,ST015Z(11)/114/,ST015Z(12)/102/,ST015Z(13) */108/,ST015Z(14)/111/,ST015Z(15)/119/,ST015Z(16)/0/ IF (.NOT.(BP .GT. MAXSIZ))GOTO 23467 CALL BADERR(ST015Z) 23467 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END SUBROUTINE INSDCL(NAME, VALUE, C) BYTE NAME(100), VALUE(100), C BYTE TEMP(10) INTEGER STRIP, DOSIZE, LEN, JUNK, FIRST, LAST, I INTEGER INDEX, ELENTH, ITOC, LENGTH INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(VALUE(1) .EQ. C))GOTO 23469 STRIP = 1 GOTO 23470 23469 CONTINUE STRIP = 0 23470 CONTINUE DOSIZE = 1 IF (.NOT.(INDEX(NAME, 40) .GT. 0 .OR. C .EQ. 39))GOTO 23471 DOSIZE = 0 23471 CONTINUE CALL INSCHR(C, SBUF, SBP, 600) CALL INSSTR(NAME, SBUF, SBP, 600) IF (.NOT.(DOSIZE .EQ. 1))GOTO 23473 LEN = ELENTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23475 LEN = LEN - 2 23475 CONTINUE IF (.NOT.(C .EQ. 34))GOTO 23477 LEN = LEN + 1 23477 CONTINUE CALL INSCHR(40, SBUF, SBP, 600) JUNK = ITOC(LEN, TEMP, 10) CALL INSSTR(TEMP, SBUF, SBP, 600) CALL INSCHR(41, SBUF, SBP, 600) 23473 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) FIRST = 1 LAST = LENGTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23479 FIRST = FIRST + 1 LAST = LAST -1 23479 CONTINUE I = FIRST 23481 IF (.NOT.(I .LE. LAST))GOTO 23483 CALL INSCHR(VALUE(I), SBUF, SBP, 600) 23482 I = I + 1 GOTO 23481 23483 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) RETURN END SUBROUTINE INSSTR(S, BUF, BP, MAXSIZ) BYTE S(100), BUF(100) INTEGER BP, MAXSIZ INTEGER I I = 1 23484 IF (.NOT.(S(I) .NE. 0))GOTO 23486 CALL INSCHR(S(I), BUF, BP, MAXSIZ) 23485 I=I+1 GOTO 23484 23486 CONTINUE RETURN END SUBROUTINE LABELC (LEXSTR) BYTE LEXSTR (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER LENGTH BYTE ST016Z(33) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST016Z(1)/119/,ST016Z(2)/97/,ST016Z(3)/114/,ST016Z(4)/110/, *ST016Z(5)/105/,ST016Z(6)/110/,ST016Z(7)/103/,ST016Z(8)/58/,ST016Z( *9)/32/,ST016Z(10)/112/,ST016Z(11)/111/,ST016Z(12)/115/,ST016Z(13)/ *115/,ST016Z(14)/105/,ST016Z(15)/98/,ST016Z(16)/108/,ST016Z(17)/101 */,ST016Z(18)/32/,ST016Z(19)/108/,ST016Z(20)/97/,ST016Z(21)/98/, *ST016Z(22)/101/,ST016Z(23)/108/,ST016Z(24)/32/,ST016Z(25)/99/, *ST016Z(26)/111/,ST016Z(27)/110/,ST016Z(28)/102/,ST016Z(29)/108/, *ST016Z(30)/105/,ST016Z(31)/99/,ST016Z(32)/116/,ST016Z(33)/0/ XFER = 0 IF (.NOT.(LENGTH (LEXSTR) .EQ. 5))GOTO 23487 IF (.NOT.(LEXSTR (1) .EQ. 50 .AND. LEXSTR (2) .EQ. 51))GOTO 23489 CALL SYNERR (ST016Z) 23489 CONTINUE 23487 CONTINUE CALL OUTSTR (LEXSTR) CALL OUTTAB RETURN END INTEGER FUNCTION LABGEN (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) LABGEN = LABEL LABEL = LABEL + N RETURN END INTEGER FUNCTION LEX (LEXSTR) BYTE LEXSTR (120) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE GNBTOK INTEGER LOOKUP COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23491 CONTINUE LEX = GNBTOK (LEXSTR, 120) IF (.NOT.(LEX .NE. 10))GOTO 23494 GOTO 23493 23494 CONTINUE 23492 GOTO 23491 23493 CONTINUE IF (.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX *.EQ. 125))GOTO 23496 RETURN 23496 CONTINUE IF (.NOT.(LEX .EQ. 2))GOTO 23498 LEX = -9 GOTO 23499 23498 CONTINUE IF (.NOT.(LEX .EQ. 37))GOTO 23500 LEX = -27 GOTO 23501 23500 CONTINUE CALL SCOPY(LEXSTR, 1, SCRTOK, 1) CALL FOLD(SCRTOK) IF (.NOT.(LOOKUP (SCRTOK, LEX, RKWTBL) .EQ. 0))GOTO 23502 LEX = -14 23502 CONTINUE 23501 CONTINUE 23499 CONTINUE RETURN END SUBROUTINE LITRAL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GT. 0))GOTO 23504 CALL OUTDON 23504 CONTINUE OUTP = 1 23506 IF (.NOT.(NGETCH (OUTBUF (OUTP)) .NE. 10))GOTO 23508 23507 OUTP = OUTP + 1 GOTO 23506 23508 CONTINUE OUTP = OUTP - 1 CALL OUTDON RETURN END BYTE FUNCTION NGETCH (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE GETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(BP .GT. 0))GOTO 23509 C = BUF(BP) BP = BP - 1 GOTO 23510 23509 CONTINUE C = GETCH(C, INFILE (LEVEL) ) IF (.NOT.(C .EQ. 10))GOTO 23511 LINECT (LEVEL) = LINECT (LEVEL) + 1 23511 CONTINUE 23510 CONTINUE NGETCH=(C) RETURN END SUBROUTINE OTHERC (LEXSTR) BYTE LEXSTR (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE TYPE COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTTAB CALL OUTSTR (LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GE. 72))GOTO 23513 CALL CONTLN 23513 CONTINUE OUTP = OUTP + 1 OUTBUF (OUTP) = C RETURN END SUBROUTINE OUTCON (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE CONTIN(9) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/, *CONTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN *(9)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23515 RETURN 23515 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23517 CALL OUTNUM (N) 23517 CONTINUE CALL OUTTAB CALL OUTSTR (CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDEF(STR, TOK) BYTE STR(100), TOK(120), T BYTE GNBTOK CALL PUTBAK(47) CALL PBSTR(STR) 23519 CONTINUE T = GNBTOK(TOK, 120) IF (.NOT.(T .EQ. 47))GOTO 23522 GOTO 23521 23522 CONTINUE CALL OUTSTR(TOK) 23520 GOTO 23519 23521 CONTINUE RETURN END SUBROUTINE OUTDON INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTBUF (OUTP + 1) = 10 OUTBUF (OUTP + 2) = 0 CALL PUTLIN (OUTBUF, 2) OUTP = 0 RETURN END SUBROUTINE OUTGO (N) INTEGER N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE SGOTO(6) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/0/ IF (.NOT.(XFER .EQ. 1))GOTO 23524 RETURN 23524 CONTINUE CALL OUTTAB CALL OUTSTR (SGOTO) CALL OUTNUM (N) CALL OUTDON RETURN END SUBROUTINE OUTNUM (N) INTEGER N BYTE CHARS (20) INTEGER I, M M = IABS (N) I = 0 23526 CONTINUE I = I + 1 CHARS (I) = MOD (M, 10) + 48 M = M / 10 23527 IF (.NOT.(M .EQ. 0 .OR. I .GE. 20))GOTO 23526 23528 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23529 CALL OUTCH (45) 23529 CONTINUE 23531 IF (.NOT.(I .GT. 0))GOTO 23533 CALL OUTCH (CHARS (I)) 23532 I = I - 1 GOTO 23531 23533 CONTINUE RETURN END SUBROUTINE OUTSTR (STR) BYTE STR (100) BYTE VARBUF(7) INTEGER I, N INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) INTEGER QSTFIX INTEGER GENNAM BYTE STROOT(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA STROOT(1)/115/,STROOT(2)/116/,STROOT(3)/0/ IF (.NOT.(STR(1) .EQ. -12))GOTO 23534 I = 2 23536 IF (.NOT.(STR(I) .NE. -12))GOTO 23538 CALL OUTCH(STR(I)) 23537 I = I + 1 GOTO 23536 23538 CONTINUE GOTO 23535 23534 CONTINUE IF (.NOT.(STR(1) .NE. 34))GOTO 23539 CALL STROUT(STR, 1) GOTO 23540 23539 CONTINUE N = QSTFIX(STR) I = GENNAM(STROOT, STRCNT, VARBUF) CALL INSDCL(VARBUF, STR, 34) CALL STROUT(VARBUF, 1) 23540 CONTINUE 23535 CONTINUE RETURN END SUBROUTINE OUTTAB INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23541 IF (.NOT.(OUTP .LT. 6))GOTO 23542 CALL OUTCH (32) GOTO 23541 23542 CONTINUE RETURN END SUBROUTINE PARSE INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE LEXSTR (120) INTEGER LAB, LABVAL (100), LEXTYP (100), SP, TOKEN, I INTEGER LEX BYTE ST017Z(13) BYTE ST018Z(25) BYTE ST019Z(20) BYTE ST01AZ(15) BYTE ST01BZ(43) BYTE ST01CZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST017Z(1)/105/,ST017Z(2)/108/,ST017Z(3)/108/,ST017Z(4)/101/, *ST017Z(5)/103/,ST017Z(6)/97/,ST017Z(7)/108/,ST017Z(8)/32/,ST017Z(9 *)/101/,ST017Z(10)/108/,ST017Z(11)/115/,ST017Z(12)/101/,ST017Z(13)/ *0/ DATA ST018Z(1)/115/,ST018Z(2)/116/,ST018Z(3)/97/,ST018Z(4)/99/, *ST018Z(5)/107/,ST018Z(6)/32/,ST018Z(7)/111/,ST018Z(8)/118/,ST018Z( *9)/101/,ST018Z(10)/114/,ST018Z(11)/102/,ST018Z(12)/108/,ST018Z(13) */111/,ST018Z(14)/119/,ST018Z(15)/32/,ST018Z(16)/105/,ST018Z(17)/11 *0/,ST018Z(18)/32/,ST018Z(19)/112/,ST018Z(20)/97/,ST018Z(21)/114/, *ST018Z(22)/115/,ST018Z(23)/101/,ST018Z(24)/114/,ST018Z(25)/0/ DATA ST019Z(1)/105/,ST019Z(2)/108/,ST019Z(3)/108/,ST019Z(4)/101/, *ST019Z(5)/103/,ST019Z(6)/97/,ST019Z(7)/108/,ST019Z(8)/32/,ST019Z(9 *)/114/,ST019Z(10)/105/,ST019Z(11)/103/,ST019Z(12)/104/,ST019Z(13)/ *116/,ST019Z(14)/32/,ST019Z(15)/98/,ST019Z(16)/114/,ST019Z(17)/97/, *ST019Z(18)/99/,ST019Z(19)/101/,ST019Z(20)/0/ DATA ST01AZ(1)/117/,ST01AZ(2)/110/,ST01AZ(3)/101/,ST01AZ(4)/120/, *ST01AZ(5)/112/,ST01AZ(6)/101/,ST01AZ(7)/99/,ST01AZ(8)/116/,ST01AZ( *9)/101/,ST01AZ(10)/100/,ST01AZ(11)/32/,ST01AZ(12)/69/,ST01AZ(13)/7 *9/,ST01AZ(14)/70/,ST01AZ(15)/0/ DATA ST01BZ(1)/99/,ST01BZ(2)/111/,ST01BZ(3)/110/,ST01BZ(4)/100/, *ST01BZ(5)/105/,ST01BZ(6)/116/,ST01BZ(7)/105/,ST01BZ(8)/111/,ST01BZ *(9)/110/,ST01BZ(10)/97/,ST01BZ(11)/108/,ST01BZ(12)/32/,ST01BZ(13)/ *112/,ST01BZ(14)/114/,ST01BZ(15)/111/,ST01BZ(16)/99/,ST01BZ(17)/101 */,ST01BZ(18)/115/,ST01BZ(19)/115/,ST01BZ(20)/105/,ST01BZ(21)/110/, *ST01BZ(22)/103/,ST01BZ(23)/32/,ST01BZ(24)/115/,ST01BZ(25)/116/, *ST01BZ(26)/105/,ST01BZ(27)/108/,ST01BZ(28)/108/,ST01BZ(29)/32/, *ST01BZ(30)/97/,ST01BZ(31)/99/,ST01BZ(32)/116/,ST01BZ(33)/105/, *ST01BZ(34)/118/,ST01BZ(35)/101/,ST01BZ(36)/32/,ST01BZ(37)/97/, *ST01BZ(38)/116/,ST01BZ(39)/32/,ST01BZ(40)/69/,ST01BZ(41)/79/, *ST01BZ(42)/70/,ST01BZ(43)/0/ DATA ST01CZ(1)/65/,ST01CZ(2)/99/,ST01CZ(3)/99/,ST01CZ(4)/117/, *ST01CZ(5)/109/,ST01CZ(6)/117/,ST01CZ(7)/108/,ST01CZ(8)/97/,ST01CZ( *9)/116/,ST01CZ(10)/101/,ST01CZ(11)/100/,ST01CZ(12)/32/,ST01CZ(13)/ *100/,ST01CZ(14)/101/,ST01CZ(15)/99/,ST01CZ(16)/108/,ST01CZ(17)/97/ *,ST01CZ(18)/114/,ST01CZ(19)/97/,ST01CZ(20)/116/,ST01CZ(21)/105/, *ST01CZ(22)/111/,ST01CZ(23)/110/,ST01CZ(24)/115/,ST01CZ(25)/32/, *ST01CZ(26)/97/,ST01CZ(27)/116/,ST01CZ(28)/32/,ST01CZ(29)/69/, *ST01CZ(30)/79/,ST01CZ(31)/70/,ST01CZ(32)/0/ CALL FINIT SP = 1 LEXTYP (1) = -1 23543 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23546 CALL DMPDCL(LEXSTR) 23546 CONTINUE TOKEN = LEX (LEXSTR) IF (.NOT.(TOKEN .EQ. -1))GOTO 23548 GOTO 23545 23548 CONTINUE IF (.NOT.(TOKEN .EQ. -19))GOTO 23550 CALL IFCODE (LAB) GOTO 23551 23550 CONTINUE IF (.NOT.(TOKEN .EQ. -10))GOTO 23552 CALL DOCODE (LAB) GOTO 23553 23552 CONTINUE IF (.NOT.(TOKEN .EQ. -15))GOTO 23554 CALL WHILEC (LAB) GOTO 23555 23554 CONTINUE IF (.NOT.(TOKEN .EQ. -16))GOTO 23556 CALL FORCOD (LAB) GOTO 23557 23556 CONTINUE IF (.NOT.(TOKEN .EQ. -17))GOTO 23558 CALL REPCOD (LAB) GOTO 23559 23558 CONTINUE IF (.NOT.(TOKEN .EQ. -9))GOTO 23560 CALL LABELC (LEXSTR) GOTO 23561 23560 CONTINUE IF (.NOT.(TOKEN .EQ. -11))GOTO 23562 IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23564 CALL ELSEIF (LABVAL (SP)) GOTO 23565 23564 CONTINUE CALL SYNERR (ST017Z) 23565 CONTINUE GOTO 23563 23562 CONTINUE IF (.NOT.(TOKEN .EQ. -27))GOTO 23566 CALL LITRAL 23566 CONTINUE 23563 CONTINUE 23561 CONTINUE 23559 CONTINUE 23557 CONTINUE 23555 CONTINUE 23553 CONTINUE 23551 CONTINUE IF (.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 *.OR. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -10 .OR. *TOKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23568 SP = SP + 1 IF (.NOT.(SP .GT. 100))GOTO 23570 CALL BADERR (ST018Z) 23570 CONTINUE LEXTYP (SP) = TOKEN LABVAL (SP) = LAB GOTO 23569 23568 CONTINUE IF (.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23572 IF (.NOT.(TOKEN .EQ. 125))GOTO 23574 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23576 SP = SP - 1 GOTO 23577 23576 CONTINUE CALL SYNERR (ST019Z) 23577 CONTINUE GOTO 23575 23574 CONTINUE IF (.NOT.(TOKEN .EQ. -14))GOTO 23578 CALL OTHERC (LEXSTR) GOTO 23579 23578 CONTINUE IF (.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23580 CALL BRKNXT (SP, LEXTYP, LABVAL, TOKEN) GOTO 23581 23580 CONTINUE IF (.NOT.(TOKEN .EQ. -20))GOTO 23582 CALL RETCOD GOTO 23583 23582 CONTINUE IF (.NOT.(TOKEN .EQ. -23))GOTO 23584 CALL STRDCL 23584 CONTINUE 23583 CONTINUE 23581 CONTINUE 23579 CONTINUE 23575 CONTINUE TOKEN = LEX (LEXSTR) CALL PBSTR (LEXSTR) CALL UNSTAK (SP, LEXTYP, LABVAL, TOKEN) IF (.NOT.(TOKEN .EQ. -1))GOTO 23586 GOTO 23545 23586 CONTINUE 23572 CONTINUE 23569 CONTINUE 23544 GOTO 23543 23545 CONTINUE IF (.NOT.(SP .NE. 1))GOTO 23588 CALL SYNERR (ST01AZ) 23588 CONTINUE IF (.NOT.(CSP .GT. 0))GOTO 23590 CALL SYNERR(ST01BZ) 23590 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23592 CALL SYNERR(ST01CZ) 23592 CONTINUE RETURN END SUBROUTINE PBNUM (N) INTEGER N INTEGER M, NUM BYTE 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)/0/ NUM = IABS(N) 23594 CONTINUE M = MOD (NUM, 10) CALL PUTBAK (DIGITS (M + 1)) NUM = NUM / 10 23595 IF (.NOT.(NUM .EQ. 0))GOTO 23594 23596 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23597 CALL PUTBAK(45) 23597 CONTINUE RETURN END SUBROUTINE PBSTR (IN) BYTE IN (100) INTEGER I INTEGER LENGTH I = LENGTH (IN) 23599 IF (.NOT.(I .GT. 0))GOTO 23601 CALL PUTBAK (IN (I)) 23600 I = I - 1 GOTO 23599 23601 CONTINUE RETURN END INTEGER FUNCTION PUSH (EP, ARGSTK, AP) INTEGER AP, ARGSTK (100), EP BYTE ST01DZ(19) DATA ST01DZ(1)/97/,ST01DZ(2)/114/,ST01DZ(3)/103/,ST01DZ(4)/32/, *ST01DZ(5)/115/,ST01DZ(6)/116/,ST01DZ(7)/97/,ST01DZ(8)/99/,ST01DZ(9 *)/107/,ST01DZ(10)/32/,ST01DZ(11)/111/,ST01DZ(12)/118/,ST01DZ(13)/1 *01/,ST01DZ(14)/114/,ST01DZ(15)/102/,ST01DZ(16)/108/,ST01DZ(17)/111 */,ST01DZ(18)/119/,ST01DZ(19)/0/ IF (.NOT.(AP .GT. 100))GOTO 23602 CALL BADERR (ST01DZ) 23602 CONTINUE ARGSTK (AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTBAK (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE ST01EZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01EZ(1)/116/,ST01EZ(2)/111/,ST01EZ(3)/111/,ST01EZ(4)/32/, *ST01EZ(5)/109/,ST01EZ(6)/97/,ST01EZ(7)/110/,ST01EZ(8)/121/,ST01EZ( *9)/32/,ST01EZ(10)/99/,ST01EZ(11)/104/,ST01EZ(12)/97/,ST01EZ(13)/11 *4/,ST01EZ(14)/97/,ST01EZ(15)/99/,ST01EZ(16)/116/,ST01EZ(17)/101/, *ST01EZ(18)/114/,ST01EZ(19)/115/,ST01EZ(20)/32/,ST01EZ(21)/112/, *ST01EZ(22)/117/,ST01EZ(23)/115/,ST01EZ(24)/104/,ST01EZ(25)/101/, *ST01EZ(26)/100/,ST01EZ(27)/32/,ST01EZ(28)/98/,ST01EZ(29)/97/, *ST01EZ(30)/99/,ST01EZ(31)/107/,ST01EZ(32)/0/ IF (.NOT.(BP .GE. 500))GOTO 23604 CALL BADERR (ST01EZ) GOTO 23605 23604 CONTINUE BP = BP + 1 BUF (BP) = C 23605 CONTINUE RETURN END SUBROUTINE PUTCHR (C) BYTE C INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE ST01FZ(26) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01FZ(1)/101/,ST01FZ(2)/118/,ST01FZ(3)/97/,ST01FZ(4)/108/, *ST01FZ(5)/117/,ST01FZ(6)/97/,ST01FZ(7)/116/,ST01FZ(8)/105/,ST01FZ( *9)/111/,ST01FZ(10)/110/,ST01FZ(11)/32/,ST01FZ(12)/115/,ST01FZ(13)/ *116/,ST01FZ(14)/97/,ST01FZ(15)/99/,ST01FZ(16)/107/,ST01FZ(17)/32/, *ST01FZ(18)/111/,ST01FZ(19)/118/,ST01FZ(20)/101/,ST01FZ(21)/114/, *ST01FZ(22)/102/,ST01FZ(23)/108/,ST01FZ(24)/111/,ST01FZ(25)/119/, *ST01FZ(26)/0/ IF (.NOT.(EP .GT. 500))GOTO 23606 CALL BADERR (ST01FZ) 23606 CONTINUE EVALST (EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK (STR) BYTE STR (120) INTEGER I I = 1 23608 IF (.NOT.(STR (I) .NE. 0))GOTO 23610 CALL PUTCHR (STR (I)) 23609 I = I + 1 GOTO 23608 23610 CONTINUE RETURN END INTEGER FUNCTION QSTFIX(STR) BYTE STR(100) INTEGER LAST, N, I INTEGER LENGTH LAST = LENGTH(STR) N = 1 I = 2 23611 IF (.NOT.(I .LT. LAST))GOTO 23613 STR(N) = STR(I) N = N + 1 23612 I = I + 1 GOTO 23611 23613 CONTINUE STR(N) = 0 QSTFIX=(N-1) RETURN END SUBROUTINE RELATE (TOKEN, LAST) BYTE TOKEN (100) INTEGER LAST BYTE NGETCH INTEGER LENGTH IF (.NOT.(NGETCH (TOKEN (2)) .NE. 61))GOTO 23614 CALL PUTBAK (TOKEN (2)) TOKEN (3) = 116 GOTO 23615 23614 CONTINUE TOKEN (3) = 101 23615 CONTINUE TOKEN (4) = 46 TOKEN (5) = 0 TOKEN (6) = 0 IF (.NOT.(TOKEN (1) .EQ. 62))GOTO 23616 TOKEN (2) = 103 GOTO 23617 23616 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 60))GOTO 23618 TOKEN (2) = 108 GOTO 23619 23618 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 33 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) *.EQ. 126 .OR. TOKEN(1) .EQ. 94))GOTO 23620 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23622 TOKEN (3) = 111 TOKEN (4) = 116 TOKEN (5) = 46 23622 CONTINUE TOKEN (2) = 110 GOTO 23621 23620 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 61))GOTO 23624 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23626 TOKEN (2) = 0 LAST = 1 RETURN 23626 CONTINUE TOKEN (2) = 101 TOKEN (3) = 113 GOTO 23625 23624 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 38))GOTO 23628 TOKEN (2) = 97 TOKEN (3) = 110 TOKEN (4) = 100 TOKEN (5) = 46 GOTO 23629 23628 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 124))GOTO 23630 TOKEN (2) = 111 TOKEN (3) = 114 GOTO 23631 23630 CONTINUE TOKEN (2) = 0 23631 CONTINUE 23629 CONTINUE 23625 CONTINUE 23621 CONTINUE 23619 CONTINUE 23617 CONTINUE TOKEN (1) = 46 LAST = LENGTH (TOKEN) RETURN END SUBROUTINE REPCOD (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (3) CALL OUTCON (LAB) LAB = LAB + 1 RETURN END SUBROUTINE RETCOD INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE T BYTE GNBTOK BYTE SRET(7) BYTE ST01GZ(50) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA ST01GZ(1)/99/,ST01GZ(2)/97/,ST01GZ(3)/110/,ST01GZ(4)/39/, *ST01GZ(5)/116/,ST01GZ(6)/32/,ST01GZ(7)/103/,ST01GZ(8)/105/,ST01GZ( *9)/118/,ST01GZ(10)/101/,ST01GZ(11)/32/,ST01GZ(12)/39/,ST01GZ(13)/1 *14/,ST01GZ(14)/101/,ST01GZ(15)/116/,ST01GZ(16)/117/,ST01GZ(17)/114 */,ST01GZ(18)/110/,ST01GZ(19)/39/,ST01GZ(20)/32/,ST01GZ(21)/97/, *ST01GZ(22)/110/,ST01GZ(23)/32/,ST01GZ(24)/97/,ST01GZ(25)/114/, *ST01GZ(26)/103/,ST01GZ(27)/117/,ST01GZ(28)/109/,ST01GZ(29)/101/, *ST01GZ(30)/110/,ST01GZ(31)/116/,ST01GZ(32)/32/,ST01GZ(33)/102/, *ST01GZ(34)/114/,ST01GZ(35)/111/,ST01GZ(36)/109/,ST01GZ(37)/32/, *ST01GZ(38)/97/,ST01GZ(39)/32/,ST01GZ(40)/115/,ST01GZ(41)/117/, *ST01GZ(42)/98/,ST01GZ(43)/114/,ST01GZ(44)/111/,ST01GZ(45)/117/, *ST01GZ(46)/116/,ST01GZ(47)/105/,ST01GZ(48)/110/,ST01GZ(49)/101/, *ST01GZ(50)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23632 CALL PBSTR (SCRTOK) IF (.NOT.( FCNAME(1) .EQ. 0 ))GOTO 23634 CALL SYNERR(ST01GZ) CALL EATUP RETURN 23634 CONTINUE CALL OUTTAB CALL SCOPY (FCNAME, 1, SCRTOK, 1) CALL OUTSTR (SCRTOK) CALL OUTCH (61) CALL EATUP CALL OUTDON GOTO 23633 23632 CONTINUE IF (.NOT.(T .EQ. 125))GOTO 23636 CALL PBSTR (SCRTOK) 23636 CONTINUE 23633 CONTINUE CALL OUTTAB CALL OUTSTR (SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE SKPBLK INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE C BYTE NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23638 CONTINUE C = NGETCH (C) 23639 IF (.NOT.(C .NE. 32 .AND. C .NE. 9))GOTO 23638 23640 CONTINUE CALL PUTBAK (C) RETURN END SUBROUTINE STRDCL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE T, DCHAR (120) INTEGER I, J, K, N, LEN BYTE GNBTOK, ESC INTEGER LENGTH, CTOI, LEX, ELENTH BYTE CHAR(10) BYTE DAT(6) BYTE EOSS(4) BYTE ST01HZ(21) BYTE ST01IZ(20) BYTE ST01JZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ DATA ST01HZ(1)/109/,ST01HZ(2)/105/,ST01HZ(3)/115/,ST01HZ(4)/115/, *ST01HZ(5)/105/,ST01HZ(6)/110/,ST01HZ(7)/103/,ST01HZ(8)/32/,ST01HZ( *9)/115/,ST01HZ(10)/116/,ST01HZ(11)/114/,ST01HZ(12)/105/,ST01HZ(13) */110/,ST01HZ(14)/103/,ST01HZ(15)/32/,ST01HZ(16)/116/,ST01HZ(17)/11 *1/,ST01HZ(18)/107/,ST01HZ(19)/101/,ST01HZ(20)/110/,ST01HZ(21)/0/ DATA ST01IZ(1)/105/,ST01IZ(2)/110/,ST01IZ(3)/118/,ST01IZ(4)/97/, *ST01IZ(5)/108/,ST01IZ(6)/105/,ST01IZ(7)/100/,ST01IZ(8)/32/,ST01IZ( *9)/115/,ST01IZ(10)/116/,ST01IZ(11)/114/,ST01IZ(12)/105/,ST01IZ(13) */110/,ST01IZ(14)/103/,ST01IZ(15)/32/,ST01IZ(16)/115/,ST01IZ(17)/10 *5/,ST01IZ(18)/122/,ST01IZ(19)/101/,ST01IZ(20)/0/ DATA ST01JZ(1)/109/,ST01JZ(2)/105/,ST01JZ(3)/115/,ST01JZ(4)/115/, *ST01JZ(5)/105/,ST01JZ(6)/110/,ST01JZ(7)/103/,ST01JZ(8)/32/,ST01JZ( *9)/114/,ST01JZ(10)/105/,ST01JZ(11)/103/,ST01JZ(12)/104/,ST01JZ(13) */116/,ST01JZ(14)/32/,ST01JZ(15)/112/,ST01JZ(16)/97/,ST01JZ(17)/114 */,ST01JZ(18)/101/,ST01JZ(19)/110/,ST01JZ(20)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. -9))GOTO 23641 CALL SYNERR (ST01HZ) 23641 CONTINUE IF (.NOT.(GNBTOK(DCHAR, 120) .EQ. 40))GOTO 23643 CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 2))GOTO 23645 CALL SYNERR(ST01IZ) 23645 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 41))GOTO 23647 CALL SYNERR(ST01JZ) 23647 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) T = GNBTOK(DCHAR, 120) 23643 CONTINUE CALL INSDCL(SCRTOK, DCHAR, 34) RETURN END SUBROUTINE STROUT(STR, IFUP) BYTE STR(100), C INTEGER IFUP, I BYTE CUPPER INTEGER LENGTH INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.( (LENGTH(STR) + OUTP) .GT. 72 ))GOTO 23649 CALL CONTLN 23649 CONTINUE I = 1 23651 IF (.NOT.(STR(I) .NE. 0))GOTO 23653 C = STR(I) IF (.NOT.(IFUP .EQ. 1))GOTO 23654 C = CUPPER(C) 23654 CONTINUE CALL OUTCH(C) 23652 I = I + 1 GOTO 23651 23653 CONTINUE RETURN END SUBROUTINE SYNERR (MSG) BYTE MSG (100) INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE LC (20) INTEGER I, JUNK INTEGER ITOC BYTE IN(5) BYTE ERRMSG(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/, *ERRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9 *)/32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/1 *01/,ERRMSG(14)/32/,ERRMSG(15)/0/ IF (.NOT.(CURCND .NE. 1))GOTO 23656 RETURN 23656 CONTINUE CALL PUTLIN (ERRMSG, 3) IF (.NOT.(LEVEL .GE. 1))GOTO 23658 I = LEVEL GOTO 23659 23658 CONTINUE I = 1 23659 CONTINUE JUNK = ITOC (LINECT (I), LC, 20) CALL PUTLIN (LC, 3) I = FNAMP - 1 23660 IF (.NOT.(I .GT. 1))GOTO 23662 IF (.NOT.(FNAMES (I - 1) .EQ. 0))GOTO 23663 CALL PUTLIN (IN, 3) CALL PUTLIN (FNAMES (I), 3) GOTO 23662 23663 CONTINUE 23661 I = I - 1 GOTO 23660 23662 CONTINUE CALL PUTCH (58, 3) CALL PUTCH (32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE ULSTAL (NAME, VAL) BYTE NAME (100), DEFN (2), VAL INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DEFN (1) = VAL DEFN (2) = 0 CALL ENTDEF (NAME, DEFN, DEFTBL) CALL UPPER (NAME) CALL ENTDEF (NAME, DEFN, DEFTBL) RETURN END SUBROUTINE UNSTAK (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN 23665 IF (.NOT.(SP .GT. 1))GOTO 23667 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23668 GOTO 23667 23668 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23670 GOTO 23667 23670 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23672 CALL OUTCON (LABVAL (SP)) GOTO 23673 23672 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -11))GOTO 23674 IF (.NOT.(SP .GT. 2))GOTO 23676 SP = SP - 1 23676 CONTINUE CALL OUTCON (LABVAL (SP) + 1) GOTO 23675 23674 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -10))GOTO 23678 CALL DOSTAT (LABVAL (SP)) GOTO 23679 23678 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -15))GOTO 23680 CALL WHILES (LABVAL (SP)) GOTO 23681 23680 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -16))GOTO 23682 CALL FORS (LABVAL (SP)) GOTO 23683 23682 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -17))GOTO 23684 CALL UNTILS (LABVAL (SP), TOKEN) 23684 CONTINUE 23683 CONTINUE 23681 CONTINUE 23679 CONTINUE 23675 CONTINUE 23673 CONTINUE 23666 SP = SP - 1 GOTO 23665 23667 CONTINUE RETURN END SUBROUTINE UNTILS (LAB, TOKEN) INTEGER LAB, TOKEN INTEGER BP BYTE BUF BYTE FCNAME INTEGER FORDEP BYTE FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP BYTE FNAMES INTEGER CP INTEGER EP BYTE EVALST INTEGER DEFTBL INTEGER OUTP BYTE OUTBUF INTEGER SBP BYTE SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK BYTE SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) BYTE CMEM(17000) BYTE PTOKEN (120) INTEGER JUNK INTEGER LEX COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) IF (.NOT.(TOKEN .EQ. -18))GOTO 23686 JUNK = LEX (PTOKEN) CALL IFGO (LAB - 1) GOTO 23687 23686 CONTINUE CALL OUTGO (LAB - 1) 23687 CONTINUE CALL OUTCON (LAB + 1) RETURN END SUBROUTINE WHILEC (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (2) CALL OUTNUM (LAB) CALL IFGO (LAB + 1) RETURN END SUBROUTINE WHILES (LAB) INTEGER LAB CALL OUTGO (LAB) CALL OUTCON (LAB + 1) RETURN END #-t- ratp1b4ch.f ascii 01/09/84 15:54 #-h- ratp1bint.f ascii 01/09/84 15:54 CALL INITST CALL RATFOR CALL ENDST(0) END SUBROUTINE RATFOR INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER I, N INTEGER GETARG, OPEN INTEGER ARG (36) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL INITKW INFILE (1) = 1 CALL PARSE RETURN END SUBROUTINE BADERR (MSG) INTEGER MSG (100) CALL SYNERR (MSG) CALL ENDST(-3) RETURN END SUBROUTINE BALPAR INTEGER T, TOKEN (120) INTEGER GETTOK, GNBTOK INTEGER NLPAR INTEGER ST001Z(19) INTEGER ST002Z(33) DATA ST001Z(1)/109/,ST001Z(2)/105/,ST001Z(3)/115/,ST001Z(4)/115/, *ST001Z(5)/105/,ST001Z(6)/110/,ST001Z(7)/103/,ST001Z(8)/32/,ST001Z( *9)/108/,ST001Z(10)/101/,ST001Z(11)/102/,ST001Z(12)/116/,ST001Z(13) */32/,ST001Z(14)/112/,ST001Z(15)/97/,ST001Z(16)/114/,ST001Z(17)/101 */,ST001Z(18)/110/,ST001Z(19)/0/ DATA ST002Z(1)/109/,ST002Z(2)/105/,ST002Z(3)/115/,ST002Z(4)/115/, *ST002Z(5)/105/,ST002Z(6)/110/,ST002Z(7)/103/,ST002Z(8)/32/,ST002Z( *9)/112/,ST002Z(10)/97/,ST002Z(11)/114/,ST002Z(12)/101/,ST002Z(13)/ *110/,ST002Z(14)/116/,ST002Z(15)/104/,ST002Z(16)/101/,ST002Z(17)/11 *5/,ST002Z(18)/105/,ST002Z(19)/115/,ST002Z(20)/32/,ST002Z(21)/105/, *ST002Z(22)/110/,ST002Z(23)/32/,ST002Z(24)/99/,ST002Z(25)/111/, *ST002Z(26)/110/,ST002Z(27)/100/,ST002Z(28)/105/,ST002Z(29)/116/, *ST002Z(30)/105/,ST002Z(31)/111/,ST002Z(32)/110/,ST002Z(33)/0/ IF (.NOT.(GNBTOK (TOKEN, 120) .NE. 40))GOTO 23000 CALL SYNERR (ST001Z) RETURN 23000 CONTINUE CALL OUTSTR (TOKEN) NLPAR = 1 23002 CONTINUE T = GETTOK (TOKEN, 120) 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) = 0 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 CALL OUTSTR (TOKEN) 23003 IF (.NOT.(NLPAR .LE. 0))GOTO 23002 23004 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23013 CALL SYNERR (ST002Z) 23013 CONTINUE RETURN END SUBROUTINE BRKNXT (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN INTEGER I, N INTEGER T INTEGER ALLDIG, CTOI INTEGER GNBTOK INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER ST003Z(14) INTEGER ST004Z(13) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST003Z(1)/105/,ST003Z(2)/108/,ST003Z(3)/108/,ST003Z(4)/101/, *ST003Z(5)/103/,ST003Z(6)/97/,ST003Z(7)/108/,ST003Z(8)/32/,ST003Z(9 *)/98/,ST003Z(10)/114/,ST003Z(11)/101/,ST003Z(12)/97/,ST003Z(13)/10 *7/,ST003Z(14)/0/ DATA ST004Z(1)/105/,ST004Z(2)/108/,ST004Z(3)/108/,ST004Z(4)/101/, *ST004Z(5)/103/,ST004Z(6)/97/,ST004Z(7)/108/,ST004Z(8)/32/,ST004Z(9 *)/110/,ST004Z(10)/101/,ST004Z(11)/120/,ST004Z(12)/116/,ST004Z(13)/ *0/ N = 0 T = GNBTOK (SCRTOK, 120) IF (.NOT.(ALLDIG (SCRTOK) .EQ. 1))GOTO 23015 I = 1 N = CTOI (SCRTOK, I) - 1 GOTO 23016 23015 CONTINUE IF (.NOT.(T .NE. 59))GOTO 23017 CALL PBSTR (SCRTOK) 23017 CONTINUE 23016 CONTINUE I = SP 23019 IF (.NOT.(I .GT. 0))GOTO 23021 IF (.NOT.(LEXTYP (I) .EQ. -15 .OR. LEXTYP (I) .EQ. -10 .OR. LEXTYP * (I) .EQ. -16 .OR. LEXTYP (I) .EQ. -17))GOTO 23022 IF (.NOT.(N .GT. 0))GOTO 23024 N = N - 1 GOTO 23020 23024 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23026 CALL OUTGO (LABVAL (I) + 1) GOTO 23027 23026 CONTINUE CALL OUTGO (LABVAL (I)) 23027 CONTINUE 23025 CONTINUE XFER = 1 RETURN 23022 CONTINUE 23020 I = I - 1 GOTO 23019 23021 CONTINUE IF (.NOT.(TOKEN .EQ. -8))GOTO 23028 CALL SYNERR (ST003Z) GOTO 23029 23028 CONTINUE CALL SYNERR (ST004Z) 23029 CONTINUE RETURN END SUBROUTINE CONTLN INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER BLSTAR(7) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BLSTAR(1)/32/,BLSTAR(2)/32/,BLSTAR(3)/32/,BLSTAR(4)/32/, *BLSTAR(5)/32/,BLSTAR(6)/42/,BLSTAR(7)/0/ CALL OUTDON CALL SCOPY(BLSTAR, 1, OUTBUF, 1) OUTP = 6 RETURN END INTEGER FUNCTION DEFTOK (TOKEN, TOKSIZ) INTEGER TOKEN (120) INTEGER TOKSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER T, C, DEFN (250) INTEGER AP, ARGSTK (100), CALLST (50), NLB, PLEV (50), IFL INTEGER LUDEF, PUSH, IFPARM, ENTER INTEGER GCTOK INTEGER BALP(3) INTEGER ST005Z(20) INTEGER ST006Z(14) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA BALP(1)/40/,BALP(2)/41/,BALP(3)/0/ DATA ST005Z(1)/99/,ST005Z(2)/97/,ST005Z(3)/108/,ST005Z(4)/108/, *ST005Z(5)/32/,ST005Z(6)/115/,ST005Z(7)/116/,ST005Z(8)/97/,ST005Z(9 *)/99/,ST005Z(10)/107/,ST005Z(11)/32/,ST005Z(12)/111/,ST005Z(13)/11 *8/,ST005Z(14)/101/,ST005Z(15)/114/,ST005Z(16)/102/,ST005Z(17)/108/ *,ST005Z(18)/111/,ST005Z(19)/119/,ST005Z(20)/0/ DATA ST006Z(1)/69/,ST006Z(2)/79/,ST006Z(3)/70/,ST006Z(4)/32/, *ST006Z(5)/105/,ST006Z(6)/110/,ST006Z(7)/32/,ST006Z(8)/115/,ST006Z( *9)/116/,ST006Z(10)/114/,ST006Z(11)/105/,ST006Z(12)/110/,ST006Z(13) */103/,ST006Z(14)/0/ CP = 0 AP = 1 EP = 1 23030 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -1))GOTO 23033 GOTO 23032 23033 CONTINUE IF (.NOT.(T .EQ. -9))GOTO 23035 IF (.NOT.(LUDEF (TOKEN, DEFN, DEFTBL) .EQ. 0))GOTO 23037 IF (.NOT.(CP .EQ. 0))GOTO 23039 GOTO 23032 23039 CONTINUE CALL PUTTOK (TOKEN) 23040 CONTINUE GOTO 23038 23037 CONTINUE IF (.NOT.(DEFN (1) .EQ. -4))GOTO 23041 CALL GETDEF (TOKEN, TOKSIZ, DEFN, 250) CALL ENTDEF (TOKEN, DEFN, DEFTBL) GOTO 23042 23041 CONTINUE IF (.NOT.(DEFN (1) .EQ. -21))GOTO 23043 CALL GETUND (TOKEN) CALL RMDEF (TOKEN, DEFTBL) GOTO 23044 23043 CONTINUE CP = CP + 1 IF (.NOT.(CP .GT. 50))GOTO 23045 CALL BADERR (ST005Z) 23045 CONTINUE CALLST (CP) = AP AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (DEFN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) CALL PUTTOK (TOKEN) CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. 32))GOTO 23047 T = GCTOK (TOKEN, TOKSIZ) CALL PBSTR (TOKEN) IF (.NOT.(T .NE. 40))GOTO 23049 CALL PUTBAK (32) 23049 CONTINUE GOTO 23048 23047 CONTINUE CALL PBSTR (TOKEN) 23048 CONTINUE IF (.NOT.(T .NE. 40))GOTO 23051 CALL PBSTR (BALP) GOTO 23052 23051 CONTINUE IF (.NOT.(IFPARM (DEFN) .EQ. 0))GOTO 23053 CALL PBSTR (BALP) 23053 CONTINUE 23052 CONTINUE PLEV (CP) = 0 23044 CONTINUE 23042 CONTINUE 23038 CONTINUE GOTO 23036 23035 CONTINUE IF (.NOT.(T .EQ. -10))GOTO 23055 NLB = 1 23057 CONTINUE T = GCTOK (TOKEN, TOKSIZ) IF (.NOT.(T .EQ. -10))GOTO 23060 NLB = NLB + 1 GOTO 23061 23060 CONTINUE IF (.NOT.(T .EQ. -11))GOTO 23062 NLB = NLB - 1 IF (.NOT.(NLB .EQ. 0))GOTO 23064 GOTO 23059 23064 CONTINUE GOTO 23063 23062 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23066 CALL BADERR (ST006Z) 23066 CONTINUE 23063 CONTINUE 23061 CONTINUE CALL PUTTOK (TOKEN) 23058 GOTO 23057 23059 CONTINUE GOTO 23056 23055 CONTINUE IF (.NOT.(CP .EQ. 0))GOTO 23068 GOTO 23032 23068 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23070 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23072 CALL PUTTOK (TOKEN) 23072 CONTINUE PLEV (CP) = PLEV (CP) + 1 GOTO 23071 23070 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23074 PLEV (CP) = PLEV (CP) - 1 IF (.NOT.(PLEV (CP) .GT. 0))GOTO 23076 CALL PUTTOK (TOKEN) GOTO 23077 23076 CONTINUE CALL PUTCHR (0) CALL EVALR (ARGSTK, CALLST (CP), AP - 1) AP = CALLST (CP) EP = ARGSTK (AP) CP = CP - 1 23077 CONTINUE GOTO 23075 23074 CONTINUE IF (.NOT.(T .EQ. 44 .AND. PLEV (CP) .EQ. 1))GOTO 23078 CALL PUTCHR (0) AP = PUSH (EP, ARGSTK, AP) GOTO 23079 23078 CONTINUE CALL PUTTOK (TOKEN) 23079 CONTINUE 23075 CONTINUE 23071 CONTINUE 23069 CONTINUE 23056 CONTINUE 23036 CONTINUE 23031 GOTO 23030 23032 CONTINUE DEFTOK = T RETURN END SUBROUTINE DMPDCL(TOKEN) INTEGER TOKEN(100) INTEGER I, J, N INTEGER C INTEGER INDEX INTEGER ESC INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER CHAR(10) INTEGER COMSTR(7) INTEGER DATS(6) INTEGER EOSS(4) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA COMSTR(1)/99/,COMSTR(2)/32/,COMSTR(3)/32/,COMSTR(4)/32/, *COMSTR(5)/32/,COMSTR(6)/32/,COMSTR(7)/0/ DATA DATS(1)/100/,DATS(2)/97/,DATS(3)/116/,DATS(4)/97/,DATS(5)/32/ *,DATS(6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ IF (.NOT.(SBP .GT. 1))GOTO 23080 I = 1 23082 IF (.NOT.(I .LT. SBP))GOTO 23084 CALL OUTTAB CALL OUTDEF(CHAR, TOKEN) CALL OUTCH(32) C = SBUF(I) J = 1 I = I + 1 23085 IF (.NOT.(SBUF(I) .NE. 0))GOTO 23087 TOKEN(J) = SBUF(I) J = J + 1 23086 I = I + 1 GOTO 23085 23087 CONTINUE TOKEN(J) = 0 I = I + 1 CALL OUTSTR(TOKEN) CALL OUTDON J = INDEX(TOKEN, 40) IF (.NOT.(J .GT. 0))GOTO 23088 TOKEN(J) = 0 23088 CONTINUE J = 1 23090 CONTINUE IF (.NOT.(SBUF(I) .EQ. 0 .AND. C .EQ. 39))GOTO 23093 GOTO 23092 23093 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23095 CALL OUTTAB CALL OUTSTR(DATS) GOTO 23096 23095 CONTINUE CALL OUTCH(44) 23096 CONTINUE CALL OUTSTR(TOKEN) IF (.NOT.(C .EQ. 34))GOTO 23097 CALL OUTCH(40) CALL OUTNUM(J) CALL OUTCH(41) 23097 CONTINUE CALL OUTCH(47) IF (.NOT.(SBUF(I) .EQ. 0))GOTO 23099 CALL OUTDEF(EOSS, TOKEN) CALL OUTCH(47) GOTO 23092 23099 CONTINUE N = ESC(SBUF, I) CALL OUTNUM(N) CALL OUTCH(47) 23100 CONTINUE J = J + 1 I = I + 1 23091 GOTO 23090 23092 CONTINUE CALL OUTDON 23083 I = I + 1 GOTO 23082 23084 CONTINUE SBP = 1 23080 CONTINUE RETURN END SUBROUTINE DOARTH (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER K, L, ANS, FIRST, SECOND INTEGER OP INTEGER CTOI INTEGER ST007Z(12) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST007Z(1)/97/,ST007Z(2)/114/,ST007Z(3)/105/,ST007Z(4)/116/, *ST007Z(5)/104/,ST007Z(6)/32/,ST007Z(7)/101/,ST007Z(8)/114/,ST007Z( *9)/114/,ST007Z(10)/111/,ST007Z(11)/114/,ST007Z(12)/0/ K = ARGSTK (I + 2) FIRST = CTOI(EVALST, K) L = ARGSTK (I + 4) SECOND = CTOI(EVALST, L) OP = EVALST (ARGSTK (I + 3)) IF (.NOT.(OP .EQ. 43))GOTO 23101 CALL PBNUM (FIRST + SECOND) GOTO 23102 23101 CONTINUE IF (.NOT.(OP .EQ. 45))GOTO 23103 CALL PBNUM (FIRST - SECOND) GOTO 23104 23103 CONTINUE IF (.NOT.(OP .EQ. 42 ))GOTO 23105 IF (.NOT.(EVALST(ARGSTK(I+3) + 1) .EQ. 42))GOTO 23107 ANS = 1 23109 IF (.NOT.(SECOND .GT. 0))GOTO 23111 ANS = ANS * FIRST 23110 SECOND = SECOND - 1 GOTO 23109 23111 CONTINUE CALL PBNUM(ANS) GOTO 23108 23107 CONTINUE CALL PBNUM (FIRST * SECOND) 23108 CONTINUE GOTO 23106 23105 CONTINUE IF (.NOT.(OP .EQ. 47 ))GOTO 23112 CALL PBNUM (FIRST / SECOND) GOTO 23113 23112 CONTINUE CALL SYNERR (ST007Z) 23113 CONTINUE 23106 CONTINUE 23104 CONTINUE 23102 CONTINUE RETURN END SUBROUTINE DOCODE (LAB) INTEGER LAB INTEGER LABGEN INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER GNBTOK INTEGER SDO(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ XFER = 0 CALL OUTTAB CALL OUTSTR (SDO) CALL OUTCH (32) LAB = LABGEN (2) IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 2))GOTO 23114 CALL OUTSTR (SCRTOK) GOTO 23115 23114 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) 23115 CONTINUE CALL OUTCH (32) CALL EATUP CALL OUTDON RETURN END SUBROUTINE DOIF (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER A2, A3, A4, A5 INTEGER EQUAL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 5))GOTO 23116 RETURN 23116 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 23118 CALL PBSTR (EVALST (A4)) GOTO 23119 23118 CONTINUE CALL PBSTR (EVALST (A5)) 23119 CONTINUE RETURN END SUBROUTINE DOINCR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER K INTEGER CTOI COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK (I + 2) CALL PBNUM (CTOI (EVALST, K) + 1) RETURN END SUBROUTINE DOLENT(ARGSTK, I, J) INTEGER ARGSTK(100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER K INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) K = ARGSTK(I + 2) CALL PBNUM(LENGTH(EVALST(K))) RETURN END SUBROUTINE DOMAC (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER A2, A3 INTEGER TYPE INTEGER ST008Z(34) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST008Z(1)/73/,ST008Z(2)/108/,ST008Z(3)/108/,ST008Z(4)/101/, *ST008Z(5)/103/,ST008Z(6)/97/,ST008Z(7)/108/,ST008Z(8)/32/,ST008Z(9 *)/102/,ST008Z(10)/105/,ST008Z(11)/114/,ST008Z(12)/115/,ST008Z(13)/ *116/,ST008Z(14)/32/,ST008Z(15)/97/,ST008Z(16)/114/,ST008Z(17)/103/ *,ST008Z(18)/117/,ST008Z(19)/109/,ST008Z(20)/101/,ST008Z(21)/110/, *ST008Z(22)/116/,ST008Z(23)/32/,ST008Z(24)/116/,ST008Z(25)/111/, *ST008Z(26)/32/,ST008Z(27)/109/,ST008Z(28)/100/,ST008Z(29)/101/, *ST008Z(30)/102/,ST008Z(31)/105/,ST008Z(32)/110/,ST008Z(33)/101/, *ST008Z(34)/0/ IF (.NOT.(J - I .GT. 2))GOTO 23120 A2 = ARGSTK (I + 2) A3 = ARGSTK (I + 3) IF (.NOT.(TYPE(EVALST(A2)) .NE. 1))GOTO 23122 CALL SYNERR(ST008Z) GOTO 23123 23122 CONTINUE CALL ENTDEF (EVALST (A2), EVALST (A3), DEFTBL) 23123 CONTINUE 23120 CONTINUE RETURN END SUBROUTINE DOSTAT (LAB) INTEGER LAB CALL OUTCON (LAB) CALL OUTCON (LAB + 1) RETURN END SUBROUTINE DOSUB (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER AP, FC, K, NC INTEGER CTOI, LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(J - I .LT. 3))GOTO 23124 RETURN 23124 CONTINUE IF (.NOT.(J - I .LT. 4))GOTO 23126 NC = 120 GOTO 23127 23126 CONTINUE K = ARGSTK (I + 4) NC = CTOI (EVALST, K) 23127 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 23128 K = FC + MIN0(NC, LENGTH (EVALST (FC))) - 1 23130 IF (.NOT.(K .GE. FC))GOTO 23132 CALL PUTBAK (EVALST (K)) 23131 K = K - 1 GOTO 23130 23132 CONTINUE 23128 CONTINUE RETURN END INTEGER FUNCTION DOTHER(TOKEN) INTEGER TOKEN(120), T INTEGER NLPAR INTEGER GETTOK INTEGER ST009Z(15) DATA ST009Z(1)/117/,ST009Z(2)/110/,ST009Z(3)/101/,ST009Z(4)/120/, *ST009Z(5)/112/,ST009Z(6)/101/,ST009Z(7)/99/,ST009Z(8)/116/,ST009Z( *9)/101/,ST009Z(10)/100/,ST009Z(11)/32/,ST009Z(12)/69/,ST009Z(13)/7 *9/,ST009Z(14)/70/,ST009Z(15)/0/ CALL OUTTAB NLPAR = 0 23133 CONTINUE T = GETTOK(TOKEN, 120) IF (.NOT.(T .EQ. 40))GOTO 23136 NLPAR = NLPAR + 1 GOTO 23137 23136 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23138 NLPAR = NLPAR - 1 23138 CONTINUE 23137 CONTINUE IF (.NOT.(T .EQ. 59 .OR. (T .EQ. 44 .AND. NLPAR .EQ. 0)))GOTO 2314 *0 GOTO 23135 23140 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23142 CALL SYNERR(ST009Z) CALL PBSTR(TOKEN) GOTO 23135 23142 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23144 CALL OUTSTR(TOKEN) 23144 CONTINUE 23134 GOTO 23133 23135 CONTINUE CALL OUTDON DOTHER=(T) RETURN END SUBROUTINE EATUP INTEGER PTOKEN (120), T, TOKEN (120) INTEGER NLPAR INTEGER GETTOK INTEGER ST00AZ(15) INTEGER ST00BZ(23) DATA ST00AZ(1)/117/,ST00AZ(2)/110/,ST00AZ(3)/101/,ST00AZ(4)/120/, *ST00AZ(5)/112/,ST00AZ(6)/101/,ST00AZ(7)/99/,ST00AZ(8)/116/,ST00AZ( *9)/101/,ST00AZ(10)/100/,ST00AZ(11)/32/,ST00AZ(12)/69/,ST00AZ(13)/7 *9/,ST00AZ(14)/70/,ST00AZ(15)/0/ DATA ST00BZ(1)/117/,ST00BZ(2)/110/,ST00BZ(3)/98/,ST00BZ(4)/97/, *ST00BZ(5)/108/,ST00BZ(6)/97/,ST00BZ(7)/110/,ST00BZ(8)/99/,ST00BZ(9 *)/101/,ST00BZ(10)/100/,ST00BZ(11)/32/,ST00BZ(12)/112/,ST00BZ(13)/9 *7/,ST00BZ(14)/114/,ST00BZ(15)/101/,ST00BZ(16)/110/,ST00BZ(17)/116/ *,ST00BZ(18)/104/,ST00BZ(19)/101/,ST00BZ(20)/115/,ST00BZ(21)/101/, *ST00BZ(22)/115/,ST00BZ(23)/0/ NLPAR = 0 23146 CONTINUE T = GETTOK (TOKEN, 120) IF (.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23149 GOTO 23148 23149 CONTINUE IF (.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23151 CALL PBSTR (TOKEN) GOTO 23148 23151 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23153 CALL SYNERR (ST00AZ) CALL PBSTR (TOKEN) GOTO 23148 23153 CONTINUE IF (.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 *.OR. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. *T .EQ. 33 .OR. T .EQ. 126 .OR. T .EQ. 94 .OR. T .EQ. 61))GOTO 2315 *5 23157 IF (.NOT.(GETTOK (PTOKEN, 120) .EQ. 10))GOTO 23158 GOTO 23157 23158 CONTINUE CALL PBSTR (PTOKEN) 23155 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23159 NLPAR = NLPAR + 1 GOTO 23160 23159 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23161 NLPAR = NLPAR - 1 23161 CONTINUE 23160 CONTINUE CALL OUTSTR (TOKEN) 23147 IF (.NOT.(NLPAR .LT. 0))GOTO 23146 23148 CONTINUE IF (.NOT.(NLPAR .NE. 0))GOTO 23163 CALL SYNERR (ST00BZ) 23163 CONTINUE RETURN END INTEGER FUNCTION ELENTH(BUF) INTEGER BUF(100), C INTEGER I, N INTEGER ESC N = 0 I=1 23165 IF (.NOT.(BUF(I) .NE. 0))GOTO 23167 C = ESC(BUF, I) N = N + 1 23166 I=I+1 GOTO 23165 23167 CONTINUE ELENTH = N RETURN END SUBROUTINE ELSEIF (LAB) INTEGER LAB CALL OUTGO (LAB+1) CALL OUTCON (LAB) RETURN END SUBROUTINE ENTDKW INTEGER DEFNAM(7) INTEGER MACNAM(8) INTEGER INCNAM(5) INTEGER SUBNAM(7) INTEGER IFNAM(7) INTEGER ARNAM(6) INTEGER UNDEFN(9) INTEGER LINKNM(8) INTEGER LENTNM(7) DATA DEFNAM(1)/100/,DEFNAM(2)/101/,DEFNAM(3)/102/,DEFNAM(4)/105/, *DEFNAM(5)/110/,DEFNAM(6)/101/,DEFNAM(7)/0/ DATA MACNAM(1)/109/,MACNAM(2)/100/,MACNAM(3)/101/,MACNAM(4)/102/, *MACNAM(5)/105/,MACNAM(6)/110/,MACNAM(7)/101/,MACNAM(8)/0/ DATA INCNAM(1)/105/,INCNAM(2)/110/,INCNAM(3)/99/,INCNAM(4)/114/, *INCNAM(5)/0/ DATA SUBNAM(1)/115/,SUBNAM(2)/117/,SUBNAM(3)/98/,SUBNAM(4)/115/, *SUBNAM(5)/116/,SUBNAM(6)/114/,SUBNAM(7)/0/ DATA IFNAM(1)/105/,IFNAM(2)/102/,IFNAM(3)/101/,IFNAM(4)/108/,IFNAM *(5)/115/,IFNAM(6)/101/,IFNAM(7)/0/ DATA ARNAM(1)/97/,ARNAM(2)/114/,ARNAM(3)/105/,ARNAM(4)/116/,ARNAM( *5)/104/,ARNAM(6)/0/ DATA UNDEFN(1)/117/,UNDEFN(2)/110/,UNDEFN(3)/100/,UNDEFN(4)/101/, *UNDEFN(5)/102/,UNDEFN(6)/105/,UNDEFN(7)/110/,UNDEFN(8)/101/,UNDEFN *(9)/0/ DATA LINKNM(1)/108/,LINKNM(2)/105/,LINKNM(3)/110/,LINKNM(4)/107/, *LINKNM(5)/97/,LINKNM(6)/103/,LINKNM(7)/101/,LINKNM(8)/0/ DATA LENTNM(1)/108/,LENTNM(2)/101/,LENTNM(3)/110/,LENTNM(4)/116/, *LENTNM(5)/111/,LENTNM(6)/107/,LENTNM(7)/0/ CALL ULSTAL (DEFNAM, -4) CALL ULSTAL (MACNAM, -10) CALL ULSTAL (INCNAM, -12) CALL ULSTAL (SUBNAM, -13) CALL ULSTAL (IFNAM, -11) CALL ULSTAL (ARNAM, -14) CALL ULSTAL (UNDEFN, -21) CALL ULSTAL(LINKNM, -4) CALL ULSTAL(LENTNM, -23) RETURN END SUBROUTINE ENTRKW INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER JUNK INTEGER ENTER 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) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/0/ DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE *(5)/0/ DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/, *SWHILE(5)/101/,SWHILE(6)/0/ DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/0/ DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/, *SBREAK(5)/107/,SBREAK(6)/0/ DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT *(5)/0/ DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/0/ DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT *(5)/97/,SREPT(6)/116/,SREPT(7)/0/ DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/, *SUNTIL(5)/108/,SUNTIL(6)/0/ DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1 *10/,SSTR(6)/103/,SSTR(7)/0/ JUNK = ENTER (SIF, -19, RKWTBL) JUNK = ENTER (SELSE, -11, RKWTBL) JUNK = ENTER (SWHILE, -15, RKWTBL) JUNK = ENTER (SDO, -10, RKWTBL) JUNK = ENTER (SBREAK, -8, RKWTBL) JUNK = ENTER (SNEXT, -13, RKWTBL) JUNK = ENTER (SFOR, -16, RKWTBL) JUNK = ENTER (SREPT, -17, RKWTBL) JUNK = ENTER (SUNTIL, -18, RKWTBL) JUNK = ENTER (SRET, -20, RKWTBL) JUNK = ENTER (SSTR, -23, RKWTBL) RETURN END SUBROUTINE EVALR (ARGSTK, I, J) INTEGER ARGSTK (100), I, J INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER ARGNO, K, M, N, T, TD INTEGER INDEX, LENGTH INTEGER DIGITS(11) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ T = ARGSTK (I) TD = EVALST (T) IF (.NOT.(TD .EQ. -10))GOTO 23168 CALL DOMAC (ARGSTK, I, J) GOTO 23169 23168 CONTINUE IF (.NOT.(TD .EQ. -12))GOTO 23170 CALL DOINCR (ARGSTK, I, J) GOTO 23171 23170 CONTINUE IF (.NOT.(TD .EQ. -13))GOTO 23172 CALL DOSUB (ARGSTK, I, J) GOTO 23173 23172 CONTINUE IF (.NOT.(TD .EQ. -11))GOTO 23174 CALL DOIF (ARGSTK, I, J) GOTO 23175 23174 CONTINUE IF (.NOT.(TD .EQ. -14))GOTO 23176 CALL DOARTH (ARGSTK, I, J) GOTO 23177 23176 CONTINUE IF (.NOT.(TD .EQ. -23))GOTO 23178 CALL DOLENT (ARGSTK, I, J) GOTO 23179 23178 CONTINUE K = T + LENGTH (EVALST (T)) - 1 23180 IF (.NOT.(K .GT. T))GOTO 23182 IF (.NOT.(EVALST (K - 1) .NE. 36))GOTO 23183 CALL PUTBAK (EVALST (K)) GOTO 23184 23183 CONTINUE ARGNO = INDEX (DIGITS, EVALST (K)) - 1 IF (.NOT.(ARGNO .GE. 0))GOTO 23185 IF (.NOT.(ARGNO .LT. J - I))GOTO 23187 N = I + ARGNO + 1 M = ARGSTK (N) CALL PBSTR (EVALST (M)) 23187 CONTINUE K = K - 1 GOTO 23186 23185 CONTINUE CALL PUTBAK (EVALST (K)) 23186 CONTINUE 23184 CONTINUE 23181 K = K - 1 GOTO 23180 23182 CONTINUE IF (.NOT.(K .EQ. T))GOTO 23189 CALL PUTBAK (EVALST (K)) 23189 CONTINUE 23179 CONTINUE 23177 CONTINUE 23175 CONTINUE 23173 CONTINUE 23171 CONTINUE 23169 CONTINUE RETURN END SUBROUTINE FCLAUS INTEGER TOKEN(120), T INTEGER GNBTOK, DOTHER 23191 CONTINUE T = GNBTOK(TOKEN, 120) CALL PBSTR(TOKEN) T = DOTHER(TOKEN) 23192 IF (.NOT.(T .EQ. 59 .OR. T .EQ. -1))GOTO 23191 23193 CONTINUE RETURN END SUBROUTINE FINIT INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTP = 0 LEVEL = 1 LINECT (1) = 1 SBP = 1 FNAMP = 2 FNAMES (1) = 0 BP = 0 FORDEP = 0 FCNAME (1) = 0 CSP = 0 CURCND = 1 RETURN END SUBROUTINE FORCOD (LAB) INTEGER LAB INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER T INTEGER I, J, NLPAR, LEN INTEGER GETTOK, GNBTOK INTEGER LENGTH, LABGEN INTEGER IFNOT(10) INTEGER SEMI(2) INTEGER ST00CZ(19) INTEGER ST00DZ(19) INTEGER ST00EZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/0/ DATA SEMI(1)/59/,SEMI(2)/0/ DATA ST00CZ(1)/109/,ST00CZ(2)/105/,ST00CZ(3)/115/,ST00CZ(4)/115/, *ST00CZ(5)/105/,ST00CZ(6)/110/,ST00CZ(7)/103/,ST00CZ(8)/32/,ST00CZ( *9)/108/,ST00CZ(10)/101/,ST00CZ(11)/102/,ST00CZ(12)/116/,ST00CZ(13) */32/,ST00CZ(14)/112/,ST00CZ(15)/97/,ST00CZ(16)/114/,ST00CZ(17)/101 */,ST00CZ(18)/110/,ST00CZ(19)/0/ DATA ST00DZ(1)/105/,ST00DZ(2)/110/,ST00DZ(3)/118/,ST00DZ(4)/97/, *ST00DZ(5)/108/,ST00DZ(6)/105/,ST00DZ(7)/100/,ST00DZ(8)/32/,ST00DZ( *9)/102/,ST00DZ(10)/111/,ST00DZ(11)/114/,ST00DZ(12)/32/,ST00DZ(13)/ *99/,ST00DZ(14)/108/,ST00DZ(15)/97/,ST00DZ(16)/117/,ST00DZ(17)/115/ *,ST00DZ(18)/101/,ST00DZ(19)/0/ DATA ST00EZ(1)/102/,ST00EZ(2)/111/,ST00EZ(3)/114/,ST00EZ(4)/32/, *ST00EZ(5)/99/,ST00EZ(6)/108/,ST00EZ(7)/97/,ST00EZ(8)/117/,ST00EZ(9 *)/115/,ST00EZ(10)/101/,ST00EZ(11)/32/,ST00EZ(12)/116/,ST00EZ(13)/1 *11/,ST00EZ(14)/111/,ST00EZ(15)/32/,ST00EZ(16)/108/,ST00EZ(17)/111/ *,ST00EZ(18)/110/,ST00EZ(19)/103/,ST00EZ(20)/0/ LAB = LABGEN (3) CALL OUTCON (0) IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 40))GOTO 23194 CALL SYNERR (ST00CZ) RETURN 23194 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .NE. 59))GOTO 23196 CALL PBSTR (SCRTOK) CALL FCLAUS 23196 CONTINUE IF (.NOT.(GNBTOK (SCRTOK, 120) .EQ. 59))GOTO 23198 CALL OUTCON (LAB) GOTO 23199 23198 CONTINUE CALL PBSTR (SCRTOK) CALL OUTNUM (LAB) CALL OUTTAB CALL OUTSTR (IFNOT) CALL OUTCH (40) NLPAR = 0 23200 IF (.NOT.(NLPAR .GE. 0))GOTO 23201 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 59))GOTO 23202 GOTO 23201 23202 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23204 NLPAR = NLPAR + 1 GOTO 23205 23204 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23206 NLPAR = NLPAR - 1 23206 CONTINUE 23205 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23208 CALL PBSTR (SCRTOK) RETURN 23208 CONTINUE IF (.NOT.(T .NE. 10))GOTO 23210 CALL OUTSTR (SCRTOK) 23210 CONTINUE GOTO 23200 23201 CONTINUE CALL OUTCH (41) CALL OUTCH (41) CALL OUTGO (LAB+2) IF (.NOT.(NLPAR .LT. 0))GOTO 23212 CALL SYNERR (ST00DZ) 23212 CONTINUE 23199 CONTINUE FORDEP = FORDEP + 1 LEN = 0 J = 1 I = 1 23214 IF (.NOT.(I .LT. FORDEP))GOTO 23216 J = J + LENGTH (FORSTK (J)) + 1 23215 I = I + 1 GOTO 23214 23216 CONTINUE FORSTK (J) = 0 NLPAR = 0 T = GNBTOK (SCRTOK, 120) CALL PBSTR (SCRTOK) 23217 IF (.NOT.(NLPAR .GE. 0))GOTO 23218 T = GETTOK (SCRTOK, 120) IF (.NOT.(T .EQ. 40))GOTO 23219 NLPAR = NLPAR + 1 GOTO 23220 23219 CONTINUE IF (.NOT.(T .EQ. 41))GOTO 23221 NLPAR = NLPAR - 1 23221 CONTINUE 23220 CONTINUE IF (.NOT.(T .EQ. -1))GOTO 23223 CALL PBSTR (SCRTOK) GOTO 23218 23223 CONTINUE IF (.NOT.(NLPAR .GE. 0 .AND. T .NE. 10))GOTO 23225 IF (.NOT.(J + LENGTH (SCRTOK) .GE. 300))GOTO 23227 CALL BADERR (ST00EZ) 23227 CONTINUE CALL SCOPY (SCRTOK, 1, FORSTK, J) J = J + LENGTH (SCRTOK) LEN = LEN + LENGTH (SCRTOK) 23225 CONTINUE GOTO 23217 23218 CONTINUE LAB = LAB + 1 RETURN END SUBROUTINE FORS (LAB) INTEGER LAB INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER I, J INTEGER LENGTH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) J = 1 I = 1 23229 IF (.NOT.(I .LT. FORDEP))GOTO 23231 J = J + LENGTH (FORSTK (J)) + 1 23230 I = I + 1 GOTO 23229 23231 CONTINUE IF (.NOT.(LENGTH (FORSTK (J)) .GT. 0))GOTO 23232 CALL PUTBAK (59) CALL PBSTR (FORSTK (J)) CALL FCLAUS 23232 CONTINUE CALL OUTGO (LAB - 1) CALL OUTCON (LAB + 1) FORDEP = FORDEP - 1 RETURN END INTEGER FUNCTION GCTOK(TOKEN, TOKSIZ) INTEGER TOKEN(120) INTEGER TOKSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER TEMP(9) INTEGER CTYPE, I, N, J, CNDVAL(4), NEWCND, VALUE INTEGER GTOK INTEGER EQUAL, LOOKUP INTEGER LETTS(5) INTEGER CNDTBL(31) INTEGER ST00FZ(27) INTEGER ST00GZ(31) INTEGER ST00HZ(27) INTEGER ST00IZ(26) INTEGER ST00JZ(27) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA LETTS(1)/101/,LETTS(2)/69/,LETTS(3)/105/,LETTS(4)/73/,LETTS(5 *)/0/ DATA CNDTBL(1)/105/,CNDTBL(2)/102/,CNDTBL(3)/100/,CNDTBL(4)/101/, *CNDTBL(5)/102/,CNDTBL(6)/47/,CNDTBL(7)/105/,CNDTBL(8)/102/,CNDTBL( *9)/110/,CNDTBL(10)/111/,CNDTBL(11)/116/,CNDTBL(12)/100/,CNDTBL(13) */101/,CNDTBL(14)/102/,CNDTBL(15)/47/,CNDTBL(16)/101/,CNDTBL(17)/10 *8/,CNDTBL(18)/115/,CNDTBL(19)/101/,CNDTBL(20)/100/,CNDTBL(21)/101/ *,CNDTBL(22)/102/,CNDTBL(23)/47/,CNDTBL(24)/101/,CNDTBL(25)/110/, *CNDTBL(26)/100/,CNDTBL(27)/100/,CNDTBL(28)/101/,CNDTBL(29)/102/, *CNDTBL(30)/47/,CNDTBL(31)/0/ DATA CNDVAL(1)/-15/, CNDVAL(2)/-16/, CNDVAL(3)/-17/, CNDVAL(4)/-18 */ DATA ST00FZ(1)/73/,ST00FZ(2)/108/,ST00FZ(3)/108/,ST00FZ(4)/101/, *ST00FZ(5)/103/,ST00FZ(6)/97/,ST00FZ(7)/108/,ST00FZ(8)/32/,ST00FZ(9 *)/101/,ST00FZ(10)/110/,ST00FZ(11)/100/,ST00FZ(12)/100/,ST00FZ(13)/ *101/,ST00FZ(14)/102/,ST00FZ(15)/32/,ST00FZ(16)/101/,ST00FZ(17)/110 */,ST00FZ(18)/99/,ST00FZ(19)/111/,ST00FZ(20)/117/,ST00FZ(21)/110/, *ST00FZ(22)/116/,ST00FZ(23)/101/,ST00FZ(24)/114/,ST00FZ(25)/101/, *ST00FZ(26)/100/,ST00FZ(27)/0/ DATA ST00GZ(1)/67/,ST00GZ(2)/111/,ST00GZ(3)/110/,ST00GZ(4)/100/, *ST00GZ(5)/105/,ST00GZ(6)/116/,ST00GZ(7)/105/,ST00GZ(8)/111/,ST00GZ *(9)/110/,ST00GZ(10)/97/,ST00GZ(11)/108/,ST00GZ(12)/115/,ST00GZ(13) */32/,ST00GZ(14)/110/,ST00GZ(15)/101/,ST00GZ(16)/115/,ST00GZ(17)/11 *6/,ST00GZ(18)/101/,ST00GZ(19)/100/,ST00GZ(20)/32/,ST00GZ(21)/116/, *ST00GZ(22)/111/,ST00GZ(23)/111/,ST00GZ(24)/32/,ST00GZ(25)/100/, *ST00GZ(26)/101/,ST00GZ(27)/101/,ST00GZ(28)/112/,ST00GZ(29)/108/, *ST00GZ(30)/121/,ST00GZ(31)/0/ DATA ST00HZ(1)/109/,ST00HZ(2)/105/,ST00HZ(3)/115/,ST00HZ(4)/115/, *ST00HZ(5)/105/,ST00HZ(6)/110/,ST00HZ(7)/103/,ST00HZ(8)/32/,ST00HZ( *9)/96/,ST00HZ(10)/40/,ST00HZ(11)/39/,ST00HZ(12)/32/,ST00HZ(13)/105 */,ST00HZ(14)/110/,ST00HZ(15)/32/,ST00HZ(16)/99/,ST00HZ(17)/111/, *ST00HZ(18)/110/,ST00HZ(19)/100/,ST00HZ(20)/105/,ST00HZ(21)/116/, *ST00HZ(22)/105/,ST00HZ(23)/111/,ST00HZ(24)/110/,ST00HZ(25)/97/, *ST00HZ(26)/108/,ST00HZ(27)/0/ DATA ST00IZ(1)/105/,ST00IZ(2)/110/,ST00IZ(3)/118/,ST00IZ(4)/97/, *ST00IZ(5)/108/,ST00IZ(6)/105/,ST00IZ(7)/100/,ST00IZ(8)/32/,ST00IZ( *9)/99/,ST00IZ(10)/111/,ST00IZ(11)/110/,ST00IZ(12)/100/,ST00IZ(13)/ *105/,ST00IZ(14)/116/,ST00IZ(15)/105/,ST00IZ(16)/111/,ST00IZ(17)/11 *0/,ST00IZ(18)/97/,ST00IZ(19)/108/,ST00IZ(20)/32/,ST00IZ(21)/116/, *ST00IZ(22)/111/,ST00IZ(23)/107/,ST00IZ(24)/101/,ST00IZ(25)/110/, *ST00IZ(26)/0/ DATA ST00JZ(1)/109/,ST00JZ(2)/105/,ST00JZ(3)/115/,ST00JZ(4)/115/, *ST00JZ(5)/105/,ST00JZ(6)/110/,ST00JZ(7)/103/,ST00JZ(8)/32/,ST00JZ( *9)/96/,ST00JZ(10)/41/,ST00JZ(11)/39/,ST00JZ(12)/32/,ST00JZ(13)/105 */,ST00JZ(14)/110/,ST00JZ(15)/32/,ST00JZ(16)/99/,ST00JZ(17)/111/, *ST00JZ(18)/110/,ST00JZ(19)/100/,ST00JZ(20)/105/,ST00JZ(21)/116/, *ST00JZ(22)/105/,ST00JZ(23)/111/,ST00JZ(24)/110/,ST00JZ(25)/97/, *ST00JZ(26)/108/,ST00JZ(27)/0/ 23234 CONTINUE GCTOK = GTOK (TOKEN, TOKSIZ) IF (.NOT.(GCTOK .EQ. -1))GOTO 23237 GOTO 23236 23237 CONTINUE CTYPE = -19 I = 1 23239 IF (.NOT.(LETTS(I) .NE. 0))GOTO 23241 IF (.NOT.(LETTS(I) .EQ. TOKEN(1)))GOTO 23242 GOTO 23241 23242 CONTINUE 23240 I = I + 1 GOTO 23239 23241 CONTINUE IF (.NOT.(LETTS(I) .NE. 0))GOTO 23244 N = 1 I = 1 23246 IF (.NOT.(CNDTBL(I) .NE. 0))GOTO 23248 J = 1 23249 IF (.NOT.(CNDTBL(I) .NE. 47))GOTO 23251 TEMP(J) = CNDTBL(I) I = I + 1 23250 J = J + 1 GOTO 23249 23251 CONTINUE TEMP(J) = 0 J = EQUAL(TOKEN, TEMP) IF (.NOT.(J .EQ. 0))GOTO 23252 CALL UPPER(TEMP) J = EQUAL(TOKEN, TEMP) 23252 CONTINUE IF (.NOT.(J .EQ. 1))GOTO 23254 CTYPE = CNDVAL(N) GOTO 23248 23254 CONTINUE N = N + 1 23247 I = I + 1 GOTO 23246 23248 CONTINUE 23244 CONTINUE IF (.NOT.(CTYPE .EQ. -19))GOTO 23256 IF (.NOT.(CURCND .EQ. 1))GOTO 23258 GOTO 23236 23258 CONTINUE GOTO 23257 23256 CONTINUE IF (.NOT.(CTYPE .EQ. -18))GOTO 23260 IF (.NOT.(CSP .LE. 0))GOTO 23262 CALL BADERR(ST00FZ) 23262 CONTINUE CURCND = CNDSTK(CSP) CSP = CSP - 1 GOTO 23261 23260 CONTINUE IF (.NOT.(CTYPE .EQ. -17))GOTO 23264 NEWCND = - CURCND GOTO 23265 23264 CONTINUE IF (.NOT.(CSP .GE. 10))GOTO 23266 CALL BADERR(ST00GZ) 23266 CONTINUE CSP = CSP + 1 CNDSTK(CSP) = CURCND CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 40))GOTO 23268 CALL BADERR(ST00HZ) 23268 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TOKEN, TOKSIZ) .NE. -9))GOTO 23270 CALL BADERR(ST00IZ) 23270 CONTINUE CALL SKPBLK IF (.NOT.(GTOK(TEMP, 9) .NE. 41))GOTO 23272 CALL BADERR(ST00JZ) 23272 CONTINUE IF (.NOT.(LOOKUP(TOKEN, VALUE, DEFTBL) .EQ. 1))GOTO 23274 NEWCND = 1 GOTO 23275 23274 CONTINUE NEWCND = - 1 23275 CONTINUE IF (.NOT.(CTYPE .EQ. -16))GOTO 23276 NEWCND = - NEWCND 23276 CONTINUE 23265 CONTINUE CURCND = MIN0(NEWCND, CNDSTK (CSP) ) 23261 CONTINUE 23257 CONTINUE 23235 GOTO 23234 23236 CONTINUE RETURN END INTEGER FUNCTION GENNAM(ROOT, COUNTR, BUF) INTEGER ROOT(100), BUF(7), TEMP(4) INTEGER COUNTR, X, I, D, J INTEGER DIGITS(31) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/0/ X = COUNTR COUNTR = COUNTR + 1 IF (.NOT.(COUNTR .GT. 27000))GOTO 23278 COUNTR = 1 23278 CONTINUE I = 1 23280 IF (.NOT.(X .GT. 0))GOTO 23282 D = MOD(X, 30) + 1 TEMP(I) = DIGITS(D) X = X / 30 23281 I = I + 1 GOTO 23280 23282 CONTINUE TEMP(I) = 0 J = 1 CALL INSSTR(ROOT, BUF, J, 6) X = 4 - I 23283 IF (.NOT.(X .GT. 0))GOTO 23285 CALL INSCHR(48, BUF, J, 6) 23284 X = X - 1 GOTO 23283 23285 CONTINUE I = I - 1 23286 IF (.NOT.(I .GT. 0))GOTO 23288 CALL INSCHR(TEMP(I), BUF, J, 6) 23287 I = I - 1 GOTO 23286 23288 CONTINUE CALL INSCHR(122, BUF, J, 6) BUF(J) = 0 GENNAM=(J-1) RETURN END SUBROUTINE GETDEF (TOKEN, TOKSIZ, DEFN, DEFSIZ) INTEGER TOKEN (120), DEFN (250) INTEGER TOKSIZ, DEFSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER C, T, PTOKEN (120) INTEGER I, NLPAR INTEGER GCTOK, NGETCH INTEGER ST00KZ(22) INTEGER ST00LZ(20) INTEGER ST00MZ(24) INTEGER ST00NZ(20) INTEGER ST00OZ(20) INTEGER ST00PZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST00KZ(1)/110/,ST00KZ(2)/111/,ST00KZ(3)/110/,ST00KZ(4)/45/, *ST00KZ(5)/97/,ST00KZ(6)/108/,ST00KZ(7)/112/,ST00KZ(8)/104/,ST00KZ( *9)/97/,ST00KZ(10)/110/,ST00KZ(11)/117/,ST00KZ(12)/109/,ST00KZ(13)/ *101/,ST00KZ(14)/114/,ST00KZ(15)/105/,ST00KZ(16)/99/,ST00KZ(17)/32/ *,ST00KZ(18)/110/,ST00KZ(19)/97/,ST00KZ(20)/109/,ST00KZ(21)/101/, *ST00KZ(22)/0/ DATA ST00LZ(1)/100/,ST00LZ(2)/101/,ST00LZ(3)/102/,ST00LZ(4)/105/, *ST00LZ(5)/110/,ST00LZ(6)/105/,ST00LZ(7)/116/,ST00LZ(8)/105/,ST00LZ *(9)/111/,ST00LZ(10)/110/,ST00LZ(11)/32/,ST00LZ(12)/116/,ST00LZ(13) */111/,ST00LZ(14)/111/,ST00LZ(15)/32/,ST00LZ(16)/108/,ST00LZ(17)/11 *1/,ST00LZ(18)/110/,ST00LZ(19)/103/,ST00LZ(20)/0/ DATA ST00MZ(1)/109/,ST00MZ(2)/105/,ST00MZ(3)/115/,ST00MZ(4)/115/, *ST00MZ(5)/105/,ST00MZ(6)/110/,ST00MZ(7)/103/,ST00MZ(8)/32/,ST00MZ( *9)/99/,ST00MZ(10)/111/,ST00MZ(11)/109/,ST00MZ(12)/109/,ST00MZ(13)/ *97/,ST00MZ(14)/32/,ST00MZ(15)/105/,ST00MZ(16)/110/,ST00MZ(17)/32/, *ST00MZ(18)/100/,ST00MZ(19)/101/,ST00MZ(20)/102/,ST00MZ(21)/105/, *ST00MZ(22)/110/,ST00MZ(23)/101/,ST00MZ(24)/0/ DATA ST00NZ(1)/100/,ST00NZ(2)/101/,ST00NZ(3)/102/,ST00NZ(4)/105/, *ST00NZ(5)/110/,ST00NZ(6)/105/,ST00NZ(7)/116/,ST00NZ(8)/105/,ST00NZ *(9)/111/,ST00NZ(10)/110/,ST00NZ(11)/32/,ST00NZ(12)/116/,ST00NZ(13) */111/,ST00NZ(14)/111/,ST00NZ(15)/32/,ST00NZ(16)/108/,ST00NZ(17)/11 *1/,ST00NZ(18)/110/,ST00NZ(19)/103/,ST00NZ(20)/0/ DATA ST00OZ(1)/109/,ST00OZ(2)/105/,ST00OZ(3)/115/,ST00OZ(4)/115/, *ST00OZ(5)/105/,ST00OZ(6)/110/,ST00OZ(7)/103/,ST00OZ(8)/32/,ST00OZ( *9)/114/,ST00OZ(10)/105/,ST00OZ(11)/103/,ST00OZ(12)/104/,ST00OZ(13) */116/,ST00OZ(14)/32/,ST00OZ(15)/112/,ST00OZ(16)/97/,ST00OZ(17)/114 */,ST00OZ(18)/101/,ST00OZ(19)/110/,ST00OZ(20)/0/ DATA ST00PZ(1)/103/,ST00PZ(2)/101/,ST00PZ(3)/116/,ST00PZ(4)/100/, *ST00PZ(5)/101/,ST00PZ(6)/102/,ST00PZ(7)/32/,ST00PZ(8)/105/,ST00PZ( *9)/115/,ST00PZ(10)/32/,ST00PZ(11)/99/,ST00PZ(12)/111/,ST00PZ(13)/1 *10/,ST00PZ(14)/102/,ST00PZ(15)/117/,ST00PZ(16)/115/,ST00PZ(17)/101 */,ST00PZ(18)/100/,ST00PZ(19)/0/ CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(C .EQ. 40))GOTO 23289 T = 40 GOTO 23290 23289 CONTINUE T = 32 CALL PBSTR (PTOKEN) 23290 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK (TOKEN, TOKSIZ) .NE. -9))GOTO 23291 CALL BADERR (ST00KZ) 23291 CONTINUE CALL SKPBLK C = GCTOK (PTOKEN, 120) IF (.NOT.(T .EQ. 32))GOTO 23293 CALL PBSTR (PTOKEN) I = 1 23295 CONTINUE C = NGETCH (C) IF (.NOT.(I .GT. DEFSIZ))GOTO 23298 CALL BADERR (ST00LZ) 23298 CONTINUE DEFN (I) = C I = I + 1 23296 IF (.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. -1))GOTO 23295 23297 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23300 CALL PUTBAK (C) 23300 CONTINUE GOTO 23294 23293 CONTINUE IF (.NOT.(T .EQ. 40))GOTO 23302 IF (.NOT.(C .NE. 44))GOTO 23304 CALL BADERR (ST00MZ) 23304 CONTINUE NLPAR = 0 I = 1 23306 IF (.NOT.(NLPAR .GE. 0))GOTO 23308 IF (.NOT.(I .GT. DEFSIZ))GOTO 23309 CALL BADERR (ST00NZ) GOTO 23310 23309 CONTINUE IF (.NOT.(NGETCH (DEFN (I)) .EQ. -1))GOTO 23311 CALL BADERR (ST00OZ) GOTO 23312 23311 CONTINUE IF (.NOT.(DEFN (I) .EQ. 40))GOTO 23313 NLPAR = NLPAR + 1 GOTO 23314 23313 CONTINUE IF (.NOT.(DEFN (I) .EQ. 41))GOTO 23315 NLPAR = NLPAR - 1 23315 CONTINUE 23314 CONTINUE 23312 CONTINUE 23310 CONTINUE 23307 I = I + 1 GOTO 23306 23308 CONTINUE GOTO 23303 23302 CONTINUE CALL BADERR (ST00PZ) 23303 CONTINUE 23294 CONTINUE DEFN (I - 1) = 0 RETURN END INTEGER FUNCTION GETTOK (TOKEN, TOKSIZ) INTEGER TOKEN (120) INTEGER TOKSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER I, LEN INTEGER NAME (36), T, TBUF(9) INTEGER EQUAL, OPEN, LENGTH INTEGER DEFTOK INTEGER FNCN(9) INTEGER INCL(8) INTEGER ST00QZ(22) INTEGER ST00RZ(19) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11 *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/0/ DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11 *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/0/ DATA ST00QZ(1)/109/,ST00QZ(2)/105/,ST00QZ(3)/115/,ST00QZ(4)/115/, *ST00QZ(5)/105/,ST00QZ(6)/110/,ST00QZ(7)/103/,ST00QZ(8)/32/,ST00QZ( *9)/102/,ST00QZ(10)/117/,ST00QZ(11)/110/,ST00QZ(12)/99/,ST00QZ(13)/ *116/,ST00QZ(14)/105/,ST00QZ(15)/111/,ST00QZ(16)/110/,ST00QZ(17)/32 */,ST00QZ(18)/110/,ST00QZ(19)/97/,ST00QZ(20)/109/,ST00QZ(21)/101/, *ST00QZ(22)/0/ DATA ST00RZ(1)/99/,ST00RZ(2)/97/,ST00RZ(3)/110/,ST00RZ(4)/39/, *ST00RZ(5)/116/,ST00RZ(6)/32/,ST00RZ(7)/111/,ST00RZ(8)/112/,ST00RZ( *9)/101/,ST00RZ(10)/110/,ST00RZ(11)/32/,ST00RZ(12)/105/,ST00RZ(13)/ *110/,ST00RZ(14)/99/,ST00RZ(15)/108/,ST00RZ(16)/117/,ST00RZ(17)/100 */,ST00RZ(18)/101/,ST00RZ(19)/0/ 23317 CONTINUE GETTOK = DEFTOK(TOKEN, TOKSIZ) IF (.NOT.(GETTOK .EQ. -1))GOTO 23320 GOTO 23319 23320 CONTINUE IF (.NOT.(GETTOK .NE. -9))GOTO 23322 RETURN 23322 CONTINUE 23321 CONTINUE I = 1 23324 IF (.NOT.(I .LE. 9))GOTO 23326 T = TOKEN(I) TBUF(I) = T IF (.NOT.(T .EQ. 0))GOTO 23327 GOTO 23326 23327 CONTINUE 23325 I = I + 1 GOTO 23324 23326 CONTINUE IF (.NOT.(I .LT. 8 .OR. T .NE. 0))GOTO 23329 RETURN 23329 CONTINUE CALL FOLD(TBUF) IF (.NOT.(EQUAL (TBUF, FNCN) .EQ. 1))GOTO 23331 CALL SKPBLK T = DEFTOK (FCNAME, 36) CALL PBSTR (FCNAME) IF (.NOT.(T .NE. -9))GOTO 23333 CALL SYNERR (ST00QZ) 23333 CONTINUE CALL PUTBAK (32) RETURN 23331 CONTINUE IF (.NOT.(EQUAL (TBUF, INCL) .EQ. 0))GOTO 23335 RETURN 23335 CONTINUE 23332 CONTINUE CALL SKPBLK T = DEFTOK (NAME, 36) IF (.NOT.(T .EQ. 34))GOTO 23337 LEN = LENGTH (NAME) - 1 I = 1 23339 IF (.NOT.(I .LT. LEN))GOTO 23341 NAME (I) = NAME (I + 1) 23340 I = I + 1 GOTO 23339 23341 CONTINUE NAME (I) = 0 23337 CONTINUE I = LENGTH (NAME) + 1 CALL SYNERR (ST00RZ) 23318 GOTO 23317 23319 CONTINUE TOKEN (1) = -1 TOKEN (2) = 0 GETTOK = -1 RETURN END SUBROUTINE GETUND(TOKEN) INTEGER TOKEN(120), TEMP(4) INTEGER GCTOK INTEGER ST00SZ(24) INTEGER ST00TZ(22) INTEGER ST010Z(24) DATA ST00SZ(1)/109/,ST00SZ(2)/105/,ST00SZ(3)/115/,ST00SZ(4)/115/, *ST00SZ(5)/105/,ST00SZ(6)/110/,ST00SZ(7)/103/,ST00SZ(8)/32/,ST00SZ( *9)/96/,ST00SZ(10)/40/,ST00SZ(11)/39/,ST00SZ(12)/32/,ST00SZ(13)/105 */,ST00SZ(14)/110/,ST00SZ(15)/32/,ST00SZ(16)/117/,ST00SZ(17)/110/, *ST00SZ(18)/100/,ST00SZ(19)/101/,ST00SZ(20)/102/,ST00SZ(21)/105/, *ST00SZ(22)/110/,ST00SZ(23)/101/,ST00SZ(24)/0/ DATA ST00TZ(1)/110/,ST00TZ(2)/111/,ST00TZ(3)/110/,ST00TZ(4)/45/, *ST00TZ(5)/97/,ST00TZ(6)/108/,ST00TZ(7)/112/,ST00TZ(8)/104/,ST00TZ( *9)/97/,ST00TZ(10)/110/,ST00TZ(11)/117/,ST00TZ(12)/109/,ST00TZ(13)/ *101/,ST00TZ(14)/114/,ST00TZ(15)/105/,ST00TZ(16)/99/,ST00TZ(17)/32/ *,ST00TZ(18)/110/,ST00TZ(19)/97/,ST00TZ(20)/109/,ST00TZ(21)/101/, *ST00TZ(22)/0/ DATA ST010Z(1)/109/,ST010Z(2)/105/,ST010Z(3)/115/,ST010Z(4)/115/, *ST010Z(5)/105/,ST010Z(6)/110/,ST010Z(7)/103/,ST010Z(8)/32/,ST010Z( *9)/96/,ST010Z(10)/41/,ST010Z(11)/39/,ST010Z(12)/32/,ST010Z(13)/105 */,ST010Z(14)/110/,ST010Z(15)/32/,ST010Z(16)/117/,ST010Z(17)/110/, *ST010Z(18)/100/,ST010Z(19)/101/,ST010Z(20)/102/,ST010Z(21)/105/, *ST010Z(22)/110/,ST010Z(23)/101/,ST010Z(24)/0/ CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. 40))GOTO 23342 CALL BADERR(ST00SZ) 23342 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TOKEN, 120) .NE. -9))GOTO 23344 CALL BADERR(ST00TZ) 23344 CONTINUE CALL SKPBLK IF (.NOT.(GCTOK(TEMP, 4) .NE. 41))GOTO 23346 CALL BADERR(ST010Z) 23346 CONTINUE RETURN END INTEGER FUNCTION GNBTOK (TOKEN, TOKSIZ) INTEGER TOKEN (120) INTEGER TOKSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER GETTOK COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23348 CONTINUE CALL SKPBLK GNBTOK = GETTOK (TOKEN, TOKSIZ) 23349 IF (.NOT.(GNBTOK .NE. 32))GOTO 23348 23350 CONTINUE RETURN END INTEGER FUNCTION GTOK (LEXSTR, TOKSIZ) INTEGER LEXSTR (120) INTEGER TOKSIZ INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER C INTEGER I, B, N, D INTEGER NGETCH, CLOWER, ESC INTEGER ITOC, INDEX, CTOI INTEGER CTYPE INTEGER TYPE INTEGER DIGITS(37) INTEGER ALFCHR(2) INTEGER ST011Z(14) INTEGER ST012Z(40) INTEGER ST013Z(22) INTEGER ST014Z(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 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)/97/,DIGITS(12)/98/,DIGITS(13)/99/, *DIGITS(14)/100/,DIGITS(15)/101/,DIGITS(16)/102/,DIGITS(17)/103/, *DIGITS(18)/104/,DIGITS(19)/105/,DIGITS(20)/106/,DIGITS(21)/107/, *DIGITS(22)/108/,DIGITS(23)/109/,DIGITS(24)/110/,DIGITS(25)/111/, *DIGITS(26)/112/,DIGITS(27)/113/,DIGITS(28)/114/,DIGITS(29)/115/, *DIGITS(30)/116/,DIGITS(31)/117/,DIGITS(32)/118/,DIGITS(33)/119/, *DIGITS(34)/120/,DIGITS(35)/121/,DIGITS(36)/122/,DIGITS(37)/0/ DATA ALFCHR(1)/95/,ALFCHR(2)/0/ DATA ST011Z(1)/109/,ST011Z(2)/105/,ST011Z(3)/115/,ST011Z(4)/115/, *ST011Z(5)/105/,ST011Z(6)/110/,ST011Z(7)/103/,ST011Z(8)/32/,ST011Z( *9)/113/,ST011Z(10)/117/,ST011Z(11)/111/,ST011Z(12)/116/,ST011Z(13) */101/,ST011Z(14)/0/ DATA ST012Z(1)/109/,ST012Z(2)/105/,ST012Z(3)/115/,ST012Z(4)/115/, *ST012Z(5)/105/,ST012Z(6)/110/,ST012Z(7)/103/,ST012Z(8)/32/,ST012Z( *9)/97/,ST012Z(10)/112/,ST012Z(11)/111/,ST012Z(12)/115/,ST012Z(13)/ *116/,ST012Z(14)/114/,ST012Z(15)/111/,ST012Z(16)/112/,ST012Z(17)/10 *4/,ST012Z(18)/101/,ST012Z(19)/32/,ST012Z(20)/105/,ST012Z(21)/110/, *ST012Z(22)/32/,ST012Z(23)/99/,ST012Z(24)/104/,ST012Z(25)/97/, *ST012Z(26)/114/,ST012Z(27)/97/,ST012Z(28)/99/,ST012Z(29)/116/, *ST012Z(30)/101/,ST012Z(31)/114/,ST012Z(32)/32/,ST012Z(33)/108/, *ST012Z(34)/105/,ST012Z(35)/116/,ST012Z(36)/101/,ST012Z(37)/114/, *ST012Z(38)/97/,ST012Z(39)/108/,ST012Z(40)/0/ DATA ST013Z(1)/109/,ST013Z(2)/105/,ST013Z(3)/115/,ST013Z(4)/115/, *ST013Z(5)/105/,ST013Z(6)/110/,ST013Z(7)/103/,ST013Z(8)/32/,ST013Z( *9)/108/,ST013Z(10)/105/,ST013Z(11)/116/,ST013Z(12)/101/,ST013Z(13) */114/,ST013Z(14)/97/,ST013Z(15)/108/,ST013Z(16)/32/,ST013Z(17)/113 */,ST013Z(18)/117/,ST013Z(19)/111/,ST013Z(20)/116/,ST013Z(21)/101/, *ST013Z(22)/0/ DATA ST014Z(1)/116/,ST014Z(2)/111/,ST014Z(3)/107/,ST014Z(4)/101/, *ST014Z(5)/110/,ST014Z(6)/32/,ST014Z(7)/116/,ST014Z(8)/111/,ST014Z( *9)/111/,ST014Z(10)/32/,ST014Z(11)/108/,ST014Z(12)/111/,ST014Z(13)/ *110/,ST014Z(14)/103/,ST014Z(15)/0/ 23351 CONTINUE C = NGETCH (LEXSTR (1)) IF (.NOT.(C .EQ. 95))GOTO 23354 IF (.NOT.(NGETCH(C) .NE. 10))GOTO 23356 CALL PUTBAK(C) C = 95 GOTO 23353 23356 CONTINUE 23354 CONTINUE 23352 IF (.NOT.(LEXSTR(1) .NE. 95))GOTO 23351 23353 CONTINUE IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23358 LEXSTR (1) = 32 23360 IF (.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23361 C = NGETCH (C) GOTO 23360 23361 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23362 23364 IF (.NOT.(NGETCH (C) .NE. 10))GOTO 23365 GOTO 23364 23365 CONTINUE 23362 CONTINUE IF (.NOT.(C .NE. 10))GOTO 23366 CALL PUTBAK (C) GOTO 23367 23366 CONTINUE LEXSTR (1) = 10 23367 CONTINUE LEXSTR (2) = 0 GTOK = LEXSTR (1) RETURN 23358 CONTINUE I = 1 IF (.NOT.(TYPE(C) .EQ. 1))GOTO 23368 I = 1 23370 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23372 C = NGETCH (LEXSTR (I + 1)) CTYPE = TYPE(C) IF (.NOT.(CTYPE .NE. 1 .AND. CTYPE .NE. 2 .AND. INDEX(ALFCHR, C) *.EQ. 0))GOTO 23373 GOTO 23372 23373 CONTINUE 23371 I = I + 1 GOTO 23370 23372 CONTINUE CALL PUTBAK (C) GTOK = -9 GOTO 23369 23368 CONTINUE IF (.NOT.(TYPE(C) .EQ. 2))GOTO 23375 I = 1 23377 IF (.NOT.(I .LT. TOKSIZ - 2))GOTO 23379 C = NGETCH (LEXSTR (I + 1)) IF (.NOT.(TYPE(C) .NE. 2))GOTO 23380 GOTO 23379 23380 CONTINUE 23378 I = I + 1 GOTO 23377 23379 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23382 LEXSTR(I + 1) = 0 N = 1 B = CTOI(LEXSTR, N) 23382 CONTINUE IF (.NOT.(C .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO 23384 N = 0 23386 CONTINUE D = INDEX (DIGITS, CLOWER (NGETCH (C))) - 1 IF (.NOT.(D .LT. 0))GOTO 23389 GOTO 23388 23389 CONTINUE N = B * N + D 23387 GOTO 23386 23388 CONTINUE CALL PUTBAK (C) I = ITOC (N, LEXSTR, TOKSIZ) GOTO 23385 23384 CONTINUE CALL PUTBAK (C) 23385 CONTINUE GTOK = 2 GOTO 23376 23375 CONTINUE IF (.NOT.(C .EQ. 91))GOTO 23391 LEXSTR (1) = 123 GTOK = 123 GOTO 23392 23391 CONTINUE IF (.NOT.(C .EQ. 93))GOTO 23393 LEXSTR (1) = 125 GTOK = 125 GOTO 23394 23393 CONTINUE IF (.NOT.(C .EQ. 36))GOTO 23395 IF (.NOT.(NGETCH (LEXSTR (2)) .EQ. 40))GOTO 23397 I = 2 GTOK = -10 GOTO 23398 23397 CONTINUE IF (.NOT.(LEXSTR (2) .EQ. 41))GOTO 23399 I = 2 GTOK = -11 GOTO 23400 23399 CONTINUE CALL PUTBAK (LEXSTR (2)) GTOK = 36 23400 CONTINUE 23398 CONTINUE GOTO 23396 23395 CONTINUE IF (.NOT.(C .EQ. 34 .OR. C .EQ. 39))GOTO 23401 GTOK = C I = 2 23403 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23405 LEXSTR(I) = C IF (.NOT.(LEXSTR(I) .EQ. 95))GOTO 23406 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23408 23410 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23411 C = NGETCH(C) GOTO 23410 23411 CONTINUE LEXSTR(I) = C GOTO 23409 23408 CONTINUE CALL PUTBAK(C) 23409 CONTINUE C = LEXSTR(I) 23406 CONTINUE IF (.NOT.(C .EQ. 64))GOTO 23412 IF (.NOT.(NGETCH(C) .EQ. -1))GOTO 23414 CALL PUTBAK(C) GOTO 23415 23414 CONTINUE I = I + 1 IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23416 I = TOKSIZ - 1 23416 CONTINUE LEXSTR(I) = C 23415 CONTINUE C = 64 23412 CONTINUE IF (.NOT.(C .EQ. LEXSTR(1)))GOTO 23418 GOTO 23405 23418 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23420 CALL SYNERR (ST011Z) LEXSTR(I) = LEXSTR(1) CALL PUTBAK(10) GOTO 23405 23420 CONTINUE 23404 I = I + 1 GOTO 23403 23405 CONTINUE IF (.NOT.(LEXSTR(1) .EQ. 39))GOTO 23422 N = 2 C = ESC(LEXSTR, N) IF (.NOT.(LEXSTR(N + 1) .NE. 39))GOTO 23424 CALL SYNERR(ST012Z) 23424 CONTINUE N = C I = ITOC(N, LEXSTR, TOKSIZ) GTOK = 2 23422 CONTINUE GOTO 23402 23401 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23426 IF (.NOT.(NGETCH(LEXSTR(2)) .NE. 40))GOTO 23428 CALL PUTBAK(LEXSTR(2)) GTOK = 37 GOTO 23429 23428 CONTINUE GTOK = 34 LEXSTR(1) = -12 I = 2 23430 IF (.NOT.(NGETCH(C) .NE. -1))GOTO 23432 LEXSTR(I) = C IF (.NOT.(C .EQ. 95))GOTO 23433 IF (.NOT.(NGETCH(C) .EQ. 10))GOTO 23435 23437 IF (.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23438 C = NGETCH(C) GOTO 23437 23438 CONTINUE LEXSTR(I) = C GOTO 23436 23435 CONTINUE CALL PUTBAK(C) 23436 CONTINUE C = LEXSTR(I) 23433 CONTINUE IF (.NOT.(C .EQ. 37))GOTO 23439 IF (.NOT.(NGETCH(C) .EQ. 41))GOTO 23441 LEXSTR(I) = -12 GOTO 23432 23441 CONTINUE CALL PUTBAK(C) 23442 CONTINUE 23439 CONTINUE IF (.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ - 1))GOTO 23443 CALL SYNERR(ST013Z) LEXSTR(I) = -12 CALL PUTBAK(10) GOTO 23432 23443 CONTINUE 23431 I = I + 1 GOTO 23430 23432 CONTINUE 23429 CONTINUE GOTO 23427 23426 CONTINUE IF (.NOT.(C .EQ. -12))GOTO 23445 GTOK = 34 I = 2 23447 IF (.NOT.(NGETCH(LEXSTR(I)) .NE. -12))GOTO 23449 23448 I = I + 1 GOTO 23447 23449 CONTINUE GOTO 23446 23445 CONTINUE IF (.NOT.(C .EQ. 35))GOTO 23450 23452 IF (.NOT.(NGETCH (LEXSTR (1)) .NE. 10))GOTO 23453 GOTO 23452 23453 CONTINUE GTOK = 10 GOTO 23451 23450 CONTINUE IF (.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 33 .OR. C .EQ. 38 . *OR. C .EQ. 124 .OR. C .EQ. 61 .OR. C .EQ. 33 .OR. C .EQ. 126 .OR. *C .EQ. 94))GOTO 23454 CALL RELATE (LEXSTR, I) GTOK = C GOTO 23455 23454 CONTINUE GTOK = C 23455 CONTINUE 23451 CONTINUE 23446 CONTINUE 23427 CONTINUE 23402 CONTINUE 23396 CONTINUE 23394 CONTINUE 23392 CONTINUE 23376 CONTINUE 23369 CONTINUE IF (.NOT.(I .GE. TOKSIZ - 1))GOTO 23456 CALL SYNERR (ST014Z) 23456 CONTINUE LEXSTR (I + 1) = 0 RETURN END SUBROUTINE IFCODE (LAB) INTEGER LAB INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER LABGEN COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 LAB = LABGEN (2) CALL IFGO (LAB) RETURN END SUBROUTINE IFGO (LAB) INTEGER LAB INTEGER IFNOT(10) 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)/0/ CALL OUTTAB CALL OUTSTR (IFNOT) CALL BALPAR CALL OUTCH (41) CALL OUTGO (LAB) RETURN END INTEGER FUNCTION IFPARM (STRNG) INTEGER STRNG (100) INTEGER C INTEGER I INTEGER INDEX INTEGER 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 .OR. C .EQ. -23))GOTO 23458 IFPARM = 1 GOTO 23459 23458 CONTINUE IFPARM = 0 I = 1 23460 IF (.NOT.(INDEX (STRNG (I), 36) .GT. 0))GOTO 23462 I = I + INDEX (STRNG (I), 36) IF (.NOT.(TYPE (STRNG (I)) .EQ. 2))GOTO 23463 IF (.NOT.(TYPE (STRNG (I + 1)) .NE. 2))GOTO 23465 IFPARM = 1 GOTO 23462 23465 CONTINUE 23463 CONTINUE 23461 GOTO 23460 23462 CONTINUE 23459 CONTINUE RETURN END SUBROUTINE INITKW INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER MKTABL COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT (4250) DEFTBL = MKTABL (1) CALL ENTDKW RKWTBL = MKTABL (1) CALL ENTRKW LABEL = 23000 STRCNT = 1 RETURN END SUBROUTINE INSCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ INTEGER C, BUF(100) INTEGER ST015Z(16) DATA ST015Z(1)/98/,ST015Z(2)/117/,ST015Z(3)/102/,ST015Z(4)/102/, *ST015Z(5)/101/,ST015Z(6)/114/,ST015Z(7)/32/,ST015Z(8)/111/,ST015Z( *9)/118/,ST015Z(10)/101/,ST015Z(11)/114/,ST015Z(12)/102/,ST015Z(13) */108/,ST015Z(14)/111/,ST015Z(15)/119/,ST015Z(16)/0/ IF (.NOT.(BP .GT. MAXSIZ))GOTO 23467 CALL BADERR(ST015Z) 23467 CONTINUE BUF(BP) = C BP = BP + 1 RETURN END SUBROUTINE INSDCL(NAME, VALUE, C) INTEGER NAME(100), VALUE(100), C INTEGER TEMP(10) INTEGER STRIP, DOSIZE, LEN, JUNK, FIRST, LAST, I INTEGER INDEX, ELENTH, ITOC, LENGTH INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(VALUE(1) .EQ. C))GOTO 23469 STRIP = 1 GOTO 23470 23469 CONTINUE STRIP = 0 23470 CONTINUE DOSIZE = 1 IF (.NOT.(INDEX(NAME, 40) .GT. 0 .OR. C .EQ. 39))GOTO 23471 DOSIZE = 0 23471 CONTINUE CALL INSCHR(C, SBUF, SBP, 600) CALL INSSTR(NAME, SBUF, SBP, 600) IF (.NOT.(DOSIZE .EQ. 1))GOTO 23473 LEN = ELENTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23475 LEN = LEN - 2 23475 CONTINUE IF (.NOT.(C .EQ. 34))GOTO 23477 LEN = LEN + 1 23477 CONTINUE CALL INSCHR(40, SBUF, SBP, 600) JUNK = ITOC(LEN, TEMP, 10) CALL INSSTR(TEMP, SBUF, SBP, 600) CALL INSCHR(41, SBUF, SBP, 600) 23473 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) FIRST = 1 LAST = LENGTH(VALUE) IF (.NOT.(STRIP .EQ. 1))GOTO 23479 FIRST = FIRST + 1 LAST = LAST -1 23479 CONTINUE I = FIRST 23481 IF (.NOT.(I .LE. LAST))GOTO 23483 CALL INSCHR(VALUE(I), SBUF, SBP, 600) 23482 I = I + 1 GOTO 23481 23483 CONTINUE CALL INSCHR(0, SBUF, SBP, 600) RETURN END SUBROUTINE INSSTR(S, BUF, BP, MAXSIZ) INTEGER S(100), BUF(100) INTEGER BP, MAXSIZ INTEGER I I = 1 23484 IF (.NOT.(S(I) .NE. 0))GOTO 23486 CALL INSCHR(S(I), BUF, BP, MAXSIZ) 23485 I=I+1 GOTO 23484 23486 CONTINUE RETURN END SUBROUTINE LABELC (LEXSTR) INTEGER LEXSTR (100) INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER LENGTH INTEGER ST016Z(33) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST016Z(1)/119/,ST016Z(2)/97/,ST016Z(3)/114/,ST016Z(4)/110/, *ST016Z(5)/105/,ST016Z(6)/110/,ST016Z(7)/103/,ST016Z(8)/58/,ST016Z( *9)/32/,ST016Z(10)/112/,ST016Z(11)/111/,ST016Z(12)/115/,ST016Z(13)/ *115/,ST016Z(14)/105/,ST016Z(15)/98/,ST016Z(16)/108/,ST016Z(17)/101 */,ST016Z(18)/32/,ST016Z(19)/108/,ST016Z(20)/97/,ST016Z(21)/98/, *ST016Z(22)/101/,ST016Z(23)/108/,ST016Z(24)/32/,ST016Z(25)/99/, *ST016Z(26)/111/,ST016Z(27)/110/,ST016Z(28)/102/,ST016Z(29)/108/, *ST016Z(30)/105/,ST016Z(31)/99/,ST016Z(32)/116/,ST016Z(33)/0/ XFER = 0 IF (.NOT.(LENGTH (LEXSTR) .EQ. 5))GOTO 23487 IF (.NOT.(LEXSTR (1) .EQ. 50 .AND. LEXSTR (2) .EQ. 51))GOTO 23489 CALL SYNERR (ST016Z) 23489 CONTINUE 23487 CONTINUE CALL OUTSTR (LEXSTR) CALL OUTTAB RETURN END INTEGER FUNCTION LABGEN (N) INTEGER N INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) LABGEN = LABEL LABEL = LABEL + N RETURN END INTEGER FUNCTION LEX (LEXSTR) INTEGER LEXSTR (120) INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER GNBTOK INTEGER LOOKUP COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23491 CONTINUE LEX = GNBTOK (LEXSTR, 120) IF (.NOT.(LEX .NE. 10))GOTO 23494 GOTO 23493 23494 CONTINUE 23492 GOTO 23491 23493 CONTINUE IF (.NOT.(LEX .EQ. -1 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LEX *.EQ. 125))GOTO 23496 RETURN 23496 CONTINUE IF (.NOT.(LEX .EQ. 2))GOTO 23498 LEX = -9 GOTO 23499 23498 CONTINUE IF (.NOT.(LEX .EQ. 37))GOTO 23500 LEX = -27 GOTO 23501 23500 CONTINUE CALL SCOPY(LEXSTR, 1, SCRTOK, 1) CALL FOLD(SCRTOK) IF (.NOT.(LOOKUP (SCRTOK, LEX, RKWTBL) .EQ. 0))GOTO 23502 LEX = -14 23502 CONTINUE 23501 CONTINUE 23499 CONTINUE RETURN END SUBROUTINE LITRAL INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GT. 0))GOTO 23504 CALL OUTDON 23504 CONTINUE OUTP = 1 23506 IF (.NOT.(NGETCH (OUTBUF (OUTP)) .NE. 10))GOTO 23508 23507 OUTP = OUTP + 1 GOTO 23506 23508 CONTINUE OUTP = OUTP - 1 CALL OUTDON RETURN END INTEGER FUNCTION NGETCH (C) INTEGER C INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER GETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(BP .GT. 0))GOTO 23509 C = BUF(BP) BP = BP - 1 GOTO 23510 23509 CONTINUE C = GETCH(C, INFILE (LEVEL) ) IF (.NOT.(C .EQ. 10))GOTO 23511 LINECT (LEVEL) = LINECT (LEVEL) + 1 23511 CONTINUE 23510 CONTINUE NGETCH=(C) RETURN END SUBROUTINE OTHERC (LEXSTR) INTEGER LEXSTR (100) INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER TYPE COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTTAB CALL OUTSTR (LEXSTR) CALL EATUP CALL OUTDON RETURN END SUBROUTINE OUTCH (C) INTEGER C INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.(OUTP .GE. 72))GOTO 23513 CALL CONTLN 23513 CONTINUE OUTP = OUTP + 1 OUTBUF (OUTP) = C RETURN END SUBROUTINE OUTCON (N) INTEGER N INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER CONTIN(9) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/, *CONTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN *(9)/0/ XFER = 0 IF (.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23515 RETURN 23515 CONTINUE IF (.NOT.(N .GT. 0))GOTO 23517 CALL OUTNUM (N) 23517 CONTINUE CALL OUTTAB CALL OUTSTR (CONTIN) CALL OUTDON RETURN END SUBROUTINE OUTDEF(STR, TOK) INTEGER STR(100), TOK(120), T INTEGER GNBTOK CALL PUTBAK(47) CALL PBSTR(STR) 23519 CONTINUE T = GNBTOK(TOK, 120) IF (.NOT.(T .EQ. 47))GOTO 23522 GOTO 23521 23522 CONTINUE CALL OUTSTR(TOK) 23520 GOTO 23519 23521 CONTINUE RETURN END SUBROUTINE OUTDON INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) OUTBUF (OUTP + 1) = 10 OUTBUF (OUTP + 2) = 0 CALL PUTLIN (OUTBUF, 2) OUTP = 0 RETURN END SUBROUTINE OUTGO (N) INTEGER N INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER SGOTO(6) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SGOTO(1)/103/,SGOTO(2)/111/,SGOTO(3)/116/,SGOTO(4)/111/,SGOTO *(5)/32/,SGOTO(6)/0/ IF (.NOT.(XFER .EQ. 1))GOTO 23524 RETURN 23524 CONTINUE CALL OUTTAB CALL OUTSTR (SGOTO) CALL OUTNUM (N) CALL OUTDON RETURN END SUBROUTINE OUTNUM (N) INTEGER N INTEGER CHARS (20) INTEGER I, M M = IABS (N) I = 0 23526 CONTINUE I = I + 1 CHARS (I) = MOD (M, 10) + 48 M = M / 10 23527 IF (.NOT.(M .EQ. 0 .OR. I .GE. 20))GOTO 23526 23528 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23529 CALL OUTCH (45) 23529 CONTINUE 23531 IF (.NOT.(I .GT. 0))GOTO 23533 CALL OUTCH (CHARS (I)) 23532 I = I - 1 GOTO 23531 23533 CONTINUE RETURN END SUBROUTINE OUTSTR (STR) INTEGER STR (100) INTEGER VARBUF(7) INTEGER I, N INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER QSTFIX INTEGER GENNAM INTEGER STROOT(3) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA STROOT(1)/115/,STROOT(2)/116/,STROOT(3)/0/ IF (.NOT.(STR(1) .EQ. -12))GOTO 23534 I = 2 23536 IF (.NOT.(STR(I) .NE. -12))GOTO 23538 CALL OUTCH(STR(I)) 23537 I = I + 1 GOTO 23536 23538 CONTINUE GOTO 23535 23534 CONTINUE IF (.NOT.(STR(1) .NE. 34))GOTO 23539 CALL STROUT(STR, 1) GOTO 23540 23539 CONTINUE N = QSTFIX(STR) I = GENNAM(STROOT, STRCNT, VARBUF) CALL INSDCL(VARBUF, STR, 34) CALL STROUT(VARBUF, 1) 23540 CONTINUE 23535 CONTINUE RETURN END SUBROUTINE OUTTAB INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23541 IF (.NOT.(OUTP .LT. 6))GOTO 23542 CALL OUTCH (32) GOTO 23541 23542 CONTINUE RETURN END SUBROUTINE PARSE INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER LEXSTR (120) INTEGER LAB, LABVAL (100), LEXTYP (100), SP, TOKEN, I INTEGER LEX INTEGER ST017Z(13) INTEGER ST018Z(25) INTEGER ST019Z(20) INTEGER ST01AZ(15) INTEGER ST01BZ(43) INTEGER ST01CZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST017Z(1)/105/,ST017Z(2)/108/,ST017Z(3)/108/,ST017Z(4)/101/, *ST017Z(5)/103/,ST017Z(6)/97/,ST017Z(7)/108/,ST017Z(8)/32/,ST017Z(9 *)/101/,ST017Z(10)/108/,ST017Z(11)/115/,ST017Z(12)/101/,ST017Z(13)/ *0/ DATA ST018Z(1)/115/,ST018Z(2)/116/,ST018Z(3)/97/,ST018Z(4)/99/, *ST018Z(5)/107/,ST018Z(6)/32/,ST018Z(7)/111/,ST018Z(8)/118/,ST018Z( *9)/101/,ST018Z(10)/114/,ST018Z(11)/102/,ST018Z(12)/108/,ST018Z(13) */111/,ST018Z(14)/119/,ST018Z(15)/32/,ST018Z(16)/105/,ST018Z(17)/11 *0/,ST018Z(18)/32/,ST018Z(19)/112/,ST018Z(20)/97/,ST018Z(21)/114/, *ST018Z(22)/115/,ST018Z(23)/101/,ST018Z(24)/114/,ST018Z(25)/0/ DATA ST019Z(1)/105/,ST019Z(2)/108/,ST019Z(3)/108/,ST019Z(4)/101/, *ST019Z(5)/103/,ST019Z(6)/97/,ST019Z(7)/108/,ST019Z(8)/32/,ST019Z(9 *)/114/,ST019Z(10)/105/,ST019Z(11)/103/,ST019Z(12)/104/,ST019Z(13)/ *116/,ST019Z(14)/32/,ST019Z(15)/98/,ST019Z(16)/114/,ST019Z(17)/97/, *ST019Z(18)/99/,ST019Z(19)/101/,ST019Z(20)/0/ DATA ST01AZ(1)/117/,ST01AZ(2)/110/,ST01AZ(3)/101/,ST01AZ(4)/120/, *ST01AZ(5)/112/,ST01AZ(6)/101/,ST01AZ(7)/99/,ST01AZ(8)/116/,ST01AZ( *9)/101/,ST01AZ(10)/100/,ST01AZ(11)/32/,ST01AZ(12)/69/,ST01AZ(13)/7 *9/,ST01AZ(14)/70/,ST01AZ(15)/0/ DATA ST01BZ(1)/99/,ST01BZ(2)/111/,ST01BZ(3)/110/,ST01BZ(4)/100/, *ST01BZ(5)/105/,ST01BZ(6)/116/,ST01BZ(7)/105/,ST01BZ(8)/111/,ST01BZ *(9)/110/,ST01BZ(10)/97/,ST01BZ(11)/108/,ST01BZ(12)/32/,ST01BZ(13)/ *112/,ST01BZ(14)/114/,ST01BZ(15)/111/,ST01BZ(16)/99/,ST01BZ(17)/101 */,ST01BZ(18)/115/,ST01BZ(19)/115/,ST01BZ(20)/105/,ST01BZ(21)/110/, *ST01BZ(22)/103/,ST01BZ(23)/32/,ST01BZ(24)/115/,ST01BZ(25)/116/, *ST01BZ(26)/105/,ST01BZ(27)/108/,ST01BZ(28)/108/,ST01BZ(29)/32/, *ST01BZ(30)/97/,ST01BZ(31)/99/,ST01BZ(32)/116/,ST01BZ(33)/105/, *ST01BZ(34)/118/,ST01BZ(35)/101/,ST01BZ(36)/32/,ST01BZ(37)/97/, *ST01BZ(38)/116/,ST01BZ(39)/32/,ST01BZ(40)/69/,ST01BZ(41)/79/, *ST01BZ(42)/70/,ST01BZ(43)/0/ DATA ST01CZ(1)/65/,ST01CZ(2)/99/,ST01CZ(3)/99/,ST01CZ(4)/117/, *ST01CZ(5)/109/,ST01CZ(6)/117/,ST01CZ(7)/108/,ST01CZ(8)/97/,ST01CZ( *9)/116/,ST01CZ(10)/101/,ST01CZ(11)/100/,ST01CZ(12)/32/,ST01CZ(13)/ *100/,ST01CZ(14)/101/,ST01CZ(15)/99/,ST01CZ(16)/108/,ST01CZ(17)/97/ *,ST01CZ(18)/114/,ST01CZ(19)/97/,ST01CZ(20)/116/,ST01CZ(21)/105/, *ST01CZ(22)/111/,ST01CZ(23)/110/,ST01CZ(24)/115/,ST01CZ(25)/32/, *ST01CZ(26)/97/,ST01CZ(27)/116/,ST01CZ(28)/32/,ST01CZ(29)/69/, *ST01CZ(30)/79/,ST01CZ(31)/70/,ST01CZ(32)/0/ CALL FINIT SP = 1 LEXTYP (1) = -1 23543 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23546 CALL DMPDCL(LEXSTR) 23546 CONTINUE TOKEN = LEX (LEXSTR) IF (.NOT.(TOKEN .EQ. -1))GOTO 23548 GOTO 23545 23548 CONTINUE IF (.NOT.(TOKEN .EQ. -19))GOTO 23550 CALL IFCODE (LAB) GOTO 23551 23550 CONTINUE IF (.NOT.(TOKEN .EQ. -10))GOTO 23552 CALL DOCODE (LAB) GOTO 23553 23552 CONTINUE IF (.NOT.(TOKEN .EQ. -15))GOTO 23554 CALL WHILEC (LAB) GOTO 23555 23554 CONTINUE IF (.NOT.(TOKEN .EQ. -16))GOTO 23556 CALL FORCOD (LAB) GOTO 23557 23556 CONTINUE IF (.NOT.(TOKEN .EQ. -17))GOTO 23558 CALL REPCOD (LAB) GOTO 23559 23558 CONTINUE IF (.NOT.(TOKEN .EQ. -9))GOTO 23560 CALL LABELC (LEXSTR) GOTO 23561 23560 CONTINUE IF (.NOT.(TOKEN .EQ. -11))GOTO 23562 IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23564 CALL ELSEIF (LABVAL (SP)) GOTO 23565 23564 CONTINUE CALL SYNERR (ST017Z) 23565 CONTINUE GOTO 23563 23562 CONTINUE IF (.NOT.(TOKEN .EQ. -27))GOTO 23566 CALL LITRAL 23566 CONTINUE 23563 CONTINUE 23561 CONTINUE 23559 CONTINUE 23557 CONTINUE 23555 CONTINUE 23553 CONTINUE 23551 CONTINUE IF (.NOT.(TOKEN .EQ. -19 .OR. TOKEN .EQ. -11 .OR. TOKEN .EQ. -15 *.OR. TOKEN .EQ. -16 .OR. TOKEN .EQ. -17 .OR. TOKEN .EQ. -10 .OR. *TOKEN .EQ. -9 .OR. TOKEN .EQ. 123))GOTO 23568 SP = SP + 1 IF (.NOT.(SP .GT. 100))GOTO 23570 CALL BADERR (ST018Z) 23570 CONTINUE LEXTYP (SP) = TOKEN LABVAL (SP) = LAB GOTO 23569 23568 CONTINUE IF (.NOT.(TOKEN .NE. -25 .AND. TOKEN .NE. -26))GOTO 23572 IF (.NOT.(TOKEN .EQ. 125))GOTO 23574 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23576 SP = SP - 1 GOTO 23577 23576 CONTINUE CALL SYNERR (ST019Z) 23577 CONTINUE GOTO 23575 23574 CONTINUE IF (.NOT.(TOKEN .EQ. -14))GOTO 23578 CALL OTHERC (LEXSTR) GOTO 23579 23578 CONTINUE IF (.NOT.(TOKEN .EQ. -8 .OR. TOKEN .EQ. -13))GOTO 23580 CALL BRKNXT (SP, LEXTYP, LABVAL, TOKEN) GOTO 23581 23580 CONTINUE IF (.NOT.(TOKEN .EQ. -20))GOTO 23582 CALL RETCOD GOTO 23583 23582 CONTINUE IF (.NOT.(TOKEN .EQ. -23))GOTO 23584 CALL STRDCL 23584 CONTINUE 23583 CONTINUE 23581 CONTINUE 23579 CONTINUE 23575 CONTINUE TOKEN = LEX (LEXSTR) CALL PBSTR (LEXSTR) CALL UNSTAK (SP, LEXTYP, LABVAL, TOKEN) IF (.NOT.(TOKEN .EQ. -1))GOTO 23586 GOTO 23545 23586 CONTINUE 23572 CONTINUE 23569 CONTINUE 23544 GOTO 23543 23545 CONTINUE IF (.NOT.(SP .NE. 1))GOTO 23588 CALL SYNERR (ST01AZ) 23588 CONTINUE IF (.NOT.(CSP .GT. 0))GOTO 23590 CALL SYNERR(ST01BZ) 23590 CONTINUE IF (.NOT.(SBP .GT. 1))GOTO 23592 CALL SYNERR(ST01CZ) 23592 CONTINUE RETURN END SUBROUTINE PBNUM (N) INTEGER N INTEGER M, NUM 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)/0/ NUM = IABS(N) 23594 CONTINUE M = MOD (NUM, 10) CALL PUTBAK (DIGITS (M + 1)) NUM = NUM / 10 23595 IF (.NOT.(NUM .EQ. 0))GOTO 23594 23596 CONTINUE IF (.NOT.(N .LT. 0))GOTO 23597 CALL PUTBAK(45) 23597 CONTINUE RETURN END SUBROUTINE PBSTR (IN) INTEGER IN (100) INTEGER I INTEGER LENGTH I = LENGTH (IN) 23599 IF (.NOT.(I .GT. 0))GOTO 23601 CALL PUTBAK (IN (I)) 23600 I = I - 1 GOTO 23599 23601 CONTINUE RETURN END INTEGER FUNCTION PUSH (EP, ARGSTK, AP) INTEGER AP, ARGSTK (100), EP INTEGER ST01DZ(19) DATA ST01DZ(1)/97/,ST01DZ(2)/114/,ST01DZ(3)/103/,ST01DZ(4)/32/, *ST01DZ(5)/115/,ST01DZ(6)/116/,ST01DZ(7)/97/,ST01DZ(8)/99/,ST01DZ(9 *)/107/,ST01DZ(10)/32/,ST01DZ(11)/111/,ST01DZ(12)/118/,ST01DZ(13)/1 *01/,ST01DZ(14)/114/,ST01DZ(15)/102/,ST01DZ(16)/108/,ST01DZ(17)/111 */,ST01DZ(18)/119/,ST01DZ(19)/0/ IF (.NOT.(AP .GT. 100))GOTO 23602 CALL BADERR (ST01DZ) 23602 CONTINUE ARGSTK (AP) = EP PUSH = AP + 1 RETURN END SUBROUTINE PUTBAK (C) INTEGER C INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER ST01EZ(32) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01EZ(1)/116/,ST01EZ(2)/111/,ST01EZ(3)/111/,ST01EZ(4)/32/, *ST01EZ(5)/109/,ST01EZ(6)/97/,ST01EZ(7)/110/,ST01EZ(8)/121/,ST01EZ( *9)/32/,ST01EZ(10)/99/,ST01EZ(11)/104/,ST01EZ(12)/97/,ST01EZ(13)/11 *4/,ST01EZ(14)/97/,ST01EZ(15)/99/,ST01EZ(16)/116/,ST01EZ(17)/101/, *ST01EZ(18)/114/,ST01EZ(19)/115/,ST01EZ(20)/32/,ST01EZ(21)/112/, *ST01EZ(22)/117/,ST01EZ(23)/115/,ST01EZ(24)/104/,ST01EZ(25)/101/, *ST01EZ(26)/100/,ST01EZ(27)/32/,ST01EZ(28)/98/,ST01EZ(29)/97/, *ST01EZ(30)/99/,ST01EZ(31)/107/,ST01EZ(32)/0/ IF (.NOT.(BP .GE. 500))GOTO 23604 CALL BADERR (ST01EZ) GOTO 23605 23604 CONTINUE BP = BP + 1 BUF (BP) = C 23605 CONTINUE RETURN END SUBROUTINE PUTCHR (C) INTEGER C INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER ST01FZ(26) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA ST01FZ(1)/101/,ST01FZ(2)/118/,ST01FZ(3)/97/,ST01FZ(4)/108/, *ST01FZ(5)/117/,ST01FZ(6)/97/,ST01FZ(7)/116/,ST01FZ(8)/105/,ST01FZ( *9)/111/,ST01FZ(10)/110/,ST01FZ(11)/32/,ST01FZ(12)/115/,ST01FZ(13)/ *116/,ST01FZ(14)/97/,ST01FZ(15)/99/,ST01FZ(16)/107/,ST01FZ(17)/32/, *ST01FZ(18)/111/,ST01FZ(19)/118/,ST01FZ(20)/101/,ST01FZ(21)/114/, *ST01FZ(22)/102/,ST01FZ(23)/108/,ST01FZ(24)/111/,ST01FZ(25)/119/, *ST01FZ(26)/0/ IF (.NOT.(EP .GT. 500))GOTO 23606 CALL BADERR (ST01FZ) 23606 CONTINUE EVALST (EP) = C EP = EP + 1 RETURN END SUBROUTINE PUTTOK (STR) INTEGER STR (120) INTEGER I I = 1 23608 IF (.NOT.(STR (I) .NE. 0))GOTO 23610 CALL PUTCHR (STR (I)) 23609 I = I + 1 GOTO 23608 23610 CONTINUE RETURN END INTEGER FUNCTION QSTFIX(STR) INTEGER STR(100) INTEGER LAST, N, I INTEGER LENGTH LAST = LENGTH(STR) N = 1 I = 2 23611 IF (.NOT.(I .LT. LAST))GOTO 23613 STR(N) = STR(I) N = N + 1 23612 I = I + 1 GOTO 23611 23613 CONTINUE STR(N) = 0 QSTFIX=(N-1) RETURN END SUBROUTINE RELATE (TOKEN, LAST) INTEGER TOKEN (100) INTEGER LAST INTEGER NGETCH INTEGER LENGTH IF (.NOT.(NGETCH (TOKEN (2)) .NE. 61))GOTO 23614 CALL PUTBAK (TOKEN (2)) TOKEN (3) = 116 GOTO 23615 23614 CONTINUE TOKEN (3) = 101 23615 CONTINUE TOKEN (4) = 46 TOKEN (5) = 0 TOKEN (6) = 0 IF (.NOT.(TOKEN (1) .EQ. 62))GOTO 23616 TOKEN (2) = 103 GOTO 23617 23616 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 60))GOTO 23618 TOKEN (2) = 108 GOTO 23619 23618 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 33 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) *.EQ. 126 .OR. TOKEN(1) .EQ. 94))GOTO 23620 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23622 TOKEN (3) = 111 TOKEN (4) = 116 TOKEN (5) = 46 23622 CONTINUE TOKEN (2) = 110 GOTO 23621 23620 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 61))GOTO 23624 IF (.NOT.(TOKEN (2) .NE. 61))GOTO 23626 TOKEN (2) = 0 LAST = 1 RETURN 23626 CONTINUE TOKEN (2) = 101 TOKEN (3) = 113 GOTO 23625 23624 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 38))GOTO 23628 TOKEN (2) = 97 TOKEN (3) = 110 TOKEN (4) = 100 TOKEN (5) = 46 GOTO 23629 23628 CONTINUE IF (.NOT.(TOKEN (1) .EQ. 124))GOTO 23630 TOKEN (2) = 111 TOKEN (3) = 114 GOTO 23631 23630 CONTINUE TOKEN (2) = 0 23631 CONTINUE 23629 CONTINUE 23625 CONTINUE 23621 CONTINUE 23619 CONTINUE 23617 CONTINUE TOKEN (1) = 46 LAST = LENGTH (TOKEN) RETURN END SUBROUTINE REPCOD (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (3) CALL OUTCON (LAB) LAB = LAB + 1 RETURN END SUBROUTINE RETCOD INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER T INTEGER GNBTOK INTEGER SRET(7) INTEGER ST01GZ(50) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1 *14/,SRET(6)/110/,SRET(7)/0/ DATA ST01GZ(1)/99/,ST01GZ(2)/97/,ST01GZ(3)/110/,ST01GZ(4)/39/, *ST01GZ(5)/116/,ST01GZ(6)/32/,ST01GZ(7)/103/,ST01GZ(8)/105/,ST01GZ( *9)/118/,ST01GZ(10)/101/,ST01GZ(11)/32/,ST01GZ(12)/39/,ST01GZ(13)/1 *14/,ST01GZ(14)/101/,ST01GZ(15)/116/,ST01GZ(16)/117/,ST01GZ(17)/114 */,ST01GZ(18)/110/,ST01GZ(19)/39/,ST01GZ(20)/32/,ST01GZ(21)/97/, *ST01GZ(22)/110/,ST01GZ(23)/32/,ST01GZ(24)/97/,ST01GZ(25)/114/, *ST01GZ(26)/103/,ST01GZ(27)/117/,ST01GZ(28)/109/,ST01GZ(29)/101/, *ST01GZ(30)/110/,ST01GZ(31)/116/,ST01GZ(32)/32/,ST01GZ(33)/102/, *ST01GZ(34)/114/,ST01GZ(35)/111/,ST01GZ(36)/109/,ST01GZ(37)/32/, *ST01GZ(38)/97/,ST01GZ(39)/32/,ST01GZ(40)/115/,ST01GZ(41)/117/, *ST01GZ(42)/98/,ST01GZ(43)/114/,ST01GZ(44)/111/,ST01GZ(45)/117/, *ST01GZ(46)/116/,ST01GZ(47)/105/,ST01GZ(48)/110/,ST01GZ(49)/101/, *ST01GZ(50)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23632 CALL PBSTR (SCRTOK) IF (.NOT.( FCNAME(1) .EQ. 0 ))GOTO 23634 CALL SYNERR(ST01GZ) CALL EATUP RETURN 23634 CONTINUE CALL OUTTAB CALL SCOPY (FCNAME, 1, SCRTOK, 1) CALL OUTSTR (SCRTOK) CALL OUTCH (61) CALL EATUP CALL OUTDON GOTO 23633 23632 CONTINUE IF (.NOT.(T .EQ. 125))GOTO 23636 CALL PBSTR (SCRTOK) 23636 CONTINUE 23633 CONTINUE CALL OUTTAB CALL OUTSTR (SRET) CALL OUTDON XFER = 1 RETURN END SUBROUTINE SKPBLK INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER C INTEGER NGETCH COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) 23638 CONTINUE C = NGETCH (C) 23639 IF (.NOT.(C .NE. 32 .AND. C .NE. 9))GOTO 23638 23640 CONTINUE CALL PUTBAK (C) RETURN END SUBROUTINE STRDCL INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER T, DCHAR (120) INTEGER I, J, K, N, LEN INTEGER GNBTOK, ESC INTEGER LENGTH, CTOI, LEX, ELENTH INTEGER CHAR(10) INTEGER DAT(6) INTEGER EOSS(4) INTEGER ST01HZ(21) INTEGER ST01IZ(20) INTEGER ST01JZ(20) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA CHAR(1)/99/,CHAR(2)/104/,CHAR(3)/97/,CHAR(4)/114/,CHAR(5)/97/ *,CHAR(6)/99/,CHAR(7)/116/,CHAR(8)/101/,CHAR(9)/114/,CHAR(10)/0/ DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT( *6)/0/ DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/0/ DATA ST01HZ(1)/109/,ST01HZ(2)/105/,ST01HZ(3)/115/,ST01HZ(4)/115/, *ST01HZ(5)/105/,ST01HZ(6)/110/,ST01HZ(7)/103/,ST01HZ(8)/32/,ST01HZ( *9)/115/,ST01HZ(10)/116/,ST01HZ(11)/114/,ST01HZ(12)/105/,ST01HZ(13) */110/,ST01HZ(14)/103/,ST01HZ(15)/32/,ST01HZ(16)/116/,ST01HZ(17)/11 *1/,ST01HZ(18)/107/,ST01HZ(19)/101/,ST01HZ(20)/110/,ST01HZ(21)/0/ DATA ST01IZ(1)/105/,ST01IZ(2)/110/,ST01IZ(3)/118/,ST01IZ(4)/97/, *ST01IZ(5)/108/,ST01IZ(6)/105/,ST01IZ(7)/100/,ST01IZ(8)/32/,ST01IZ( *9)/115/,ST01IZ(10)/116/,ST01IZ(11)/114/,ST01IZ(12)/105/,ST01IZ(13) */110/,ST01IZ(14)/103/,ST01IZ(15)/32/,ST01IZ(16)/115/,ST01IZ(17)/10 *5/,ST01IZ(18)/122/,ST01IZ(19)/101/,ST01IZ(20)/0/ DATA ST01JZ(1)/109/,ST01JZ(2)/105/,ST01JZ(3)/115/,ST01JZ(4)/115/, *ST01JZ(5)/105/,ST01JZ(6)/110/,ST01JZ(7)/103/,ST01JZ(8)/32/,ST01JZ( *9)/114/,ST01JZ(10)/105/,ST01JZ(11)/103/,ST01JZ(12)/104/,ST01JZ(13) */116/,ST01JZ(14)/32/,ST01JZ(15)/112/,ST01JZ(16)/97/,ST01JZ(17)/114 */,ST01JZ(18)/101/,ST01JZ(19)/110/,ST01JZ(20)/0/ T = GNBTOK (SCRTOK, 120) IF (.NOT.(T .NE. -9))GOTO 23641 CALL SYNERR (ST01HZ) 23641 CONTINUE IF (.NOT.(GNBTOK(DCHAR, 120) .EQ. 40))GOTO 23643 CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 2))GOTO 23645 CALL SYNERR(ST01IZ) 23645 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) IF (.NOT.(GNBTOK(DCHAR, 120) .NE. 41))GOTO 23647 CALL SYNERR(ST01JZ) 23647 CONTINUE CALL CONCAT(SCRTOK, DCHAR, SCRTOK) T = GNBTOK(DCHAR, 120) 23643 CONTINUE CALL INSDCL(SCRTOK, DCHAR, 34) RETURN END SUBROUTINE STROUT(STR, IFUP) INTEGER STR(100), C INTEGER IFUP, I INTEGER CUPPER INTEGER LENGTH INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) IF (.NOT.( (LENGTH(STR) + OUTP) .GT. 72 ))GOTO 23649 CALL CONTLN 23649 CONTINUE I = 1 23651 IF (.NOT.(STR(I) .NE. 0))GOTO 23653 C = STR(I) IF (.NOT.(IFUP .EQ. 1))GOTO 23654 C = CUPPER(C) 23654 CONTINUE CALL OUTCH(C) 23652 I = I + 1 GOTO 23651 23653 CONTINUE RETURN END SUBROUTINE SYNERR (MSG) INTEGER MSG (100) INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER LC (20) INTEGER I, JUNK INTEGER ITOC INTEGER IN(5) INTEGER ERRMSG(15) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/0/ DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/, *ERRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9 *)/32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/1 *01/,ERRMSG(14)/32/,ERRMSG(15)/0/ IF (.NOT.(CURCND .NE. 1))GOTO 23656 RETURN 23656 CONTINUE CALL PUTLIN (ERRMSG, 3) IF (.NOT.(LEVEL .GE. 1))GOTO 23658 I = LEVEL GOTO 23659 23658 CONTINUE I = 1 23659 CONTINUE JUNK = ITOC (LINECT (I), LC, 20) CALL PUTLIN (LC, 3) I = FNAMP - 1 23660 IF (.NOT.(I .GT. 1))GOTO 23662 IF (.NOT.(FNAMES (I - 1) .EQ. 0))GOTO 23663 CALL PUTLIN (IN, 3) CALL PUTLIN (FNAMES (I), 3) GOTO 23662 23663 CONTINUE 23661 I = I - 1 GOTO 23660 23662 CONTINUE CALL PUTCH (58, 3) CALL PUTCH (32, 3) CALL REMARK (MSG) RETURN END SUBROUTINE ULSTAL (NAME, VAL) INTEGER NAME (100), DEFN (2), VAL INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) DEFN (1) = VAL DEFN (2) = 0 CALL ENTDEF (NAME, DEFN, DEFTBL) CALL UPPER (NAME) CALL ENTDEF (NAME, DEFN, DEFTBL) RETURN END SUBROUTINE UNSTAK (SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL (100), LEXTYP (100), SP, TOKEN 23665 IF (.NOT.(SP .GT. 1))GOTO 23667 IF (.NOT.(LEXTYP (SP) .EQ. 123))GOTO 23668 GOTO 23667 23668 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19 .AND. TOKEN .EQ. -11))GOTO 23670 GOTO 23667 23670 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -19))GOTO 23672 CALL OUTCON (LABVAL (SP)) GOTO 23673 23672 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -11))GOTO 23674 IF (.NOT.(SP .GT. 2))GOTO 23676 SP = SP - 1 23676 CONTINUE CALL OUTCON (LABVAL (SP) + 1) GOTO 23675 23674 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -10))GOTO 23678 CALL DOSTAT (LABVAL (SP)) GOTO 23679 23678 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -15))GOTO 23680 CALL WHILES (LABVAL (SP)) GOTO 23681 23680 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -16))GOTO 23682 CALL FORS (LABVAL (SP)) GOTO 23683 23682 CONTINUE IF (.NOT.(LEXTYP (SP) .EQ. -17))GOTO 23684 CALL UNTILS (LABVAL (SP), TOKEN) 23684 CONTINUE 23683 CONTINUE 23681 CONTINUE 23679 CONTINUE 23675 CONTINUE 23673 CONTINUE 23666 SP = SP - 1 GOTO 23665 23667 CONTINUE RETURN END SUBROUTINE UNTILS (LAB, TOKEN) INTEGER LAB, TOKEN INTEGER BP INTEGER BUF INTEGER FCNAME INTEGER FORDEP INTEGER FORSTK INTEGER XFER INTEGER LABEL INTEGER LEVEL INTEGER LINECT INTEGER INFILE INTEGER FNAMP INTEGER FNAMES INTEGER CP INTEGER EP INTEGER EVALST INTEGER DEFTBL INTEGER OUTP INTEGER OUTBUF INTEGER SBP INTEGER SBUF INTEGER RKWTBL INTEGER CSP INTEGER CURCND INTEGER CNDSTK INTEGER SCRTOK INTEGER DOSYM INTEGER STRCNT INTEGER MEM( 4250) INTEGER CMEM(4250) INTEGER PTOKEN (120) INTEGER JUNK INTEGER LEX COMMON /CDEFIO/ BP, BUF (500) COMMON /CFNAME/ FCNAME (36) COMMON /CFOR/ FORDEP, FORSTK (300) COMMON /CGOTO/ XFER COMMON /CLABEL/ LABEL COMMON /CLINE/ LEVEL, LINECT (4), INFILE (4), FNAMP, FNAMES ( 144) COMMON /CMACRO/ CP, EP, EVALST (500), DEFTBL COMMON /COUTLN/ OUTP, OUTBUF (74) COMMON /CSBUF/ SBP, SBUF (600) COMMON /CKWORD/ RKWTBL COMMON /CONDPP/ CSP, CURCND, CNDSTK(10) COMMON / CSCTOK / SCRTOK(120) COMMON / CFLAGS / DOSYM COMMON / CPASS1 / STRCNT COMMON /CDSMEM/ MEM EQUIVALENCE (CMEM(1),MEM(1)) XFER = 0 CALL OUTNUM (LAB) IF (.NOT.(TOKEN .EQ. -18))GOTO 23686 JUNK = LEX (PTOKEN) CALL IFGO (LAB - 1) GOTO 23687 23686 CONTINUE CALL OUTGO (LAB - 1) 23687 CONTINUE CALL OUTCON (LAB + 1) RETURN END SUBROUTINE WHILEC (LAB) INTEGER LAB INTEGER LABGEN CALL OUTCON (0) LAB = LABGEN (2) CALL OUTNUM (LAB) CALL IFGO (LAB + 1) RETURN END SUBROUTINE WHILES (LAB) INTEGER LAB CALL OUTGO (LAB) CALL OUTCON (LAB + 1) RETURN END #-t- ratp1bint.f ascii 01/09/84 15:54 #-h- ratp1sym.rat ascii 01/09/84 15:54 #-h- defns ascii 01/09/83 12:06:00 # Ratfor preprocessor # include ratdef #--------------------------------------------------------------- # 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 STDEFNS to "". # The suggested name for this file is `ratdef'. # #--------------------------------------------------------------- # If you want the preprocessor to output upper case only, # set the following definition: # # define (UPPERC,) # # This is defined by default #--------------------------------------------------------------- # If you want the preprocessor to perform the long name conversion, # set the following definition # # define (DO_LONGNAME,) # #--------------------------------------------------------------- # If you want the preprocessor to process the switch statement, # set the following definition # # define (DO_SWITCH,) # # This is defined by default #--------------------------------------------------------------- # Quoted string handling # # One of the major changes to the pre-processor with this release # is to permit pre-processors to be built which handle # quoted strings differently. # # This action is determined by one of three defined symbols: # # DO_PASS1 - all quoted strings encountered will have a character # variable name generated for them, with the appropriate # data statements expanded inline with the declaration. # As a result, all quoted strings are legal character # variables, and may be used anywhere a character array # could be used before. For example # # call putlin("Hello world.@n", STDOUT) # # is now legal. This is at the expense of requiring that # the output of the pre-processor must be run through the # second pass of the processor, RATP2. In addition, the # variable generated by the switch statement is declared # to be of type INTEGER. # # DO_F77_STRINGS - all quoted strings are output as F77 style strings. # it is expected that sites who wish to use ratfor # to pre-process into F77 will define this symbol # instead of DO_PASS1 and probably will define # STDEFNS to be "". Such a version of the pre-processor # should probably be called RAT77 # # DO_HOLLERITH - this outputs hollerith strings as before. # # The default is DO_PASS1. #--------------------------------------------------------------- # If you want to generate the fortran bootstrap, # set the following definition # # define (DO_BOOTSTRAP,) # # In addition, it will be necessary to append the fortran of several # of the library routines to the generated fortran file. #--------------------------------------------------------------- # 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,"ratdef") define (ALPHA_CHARACTERS,"_") # the set of legal characters in alpha tokens # VMS users might like to set this to "_$" define (UPPERC,) # define if Fortran compiler wants upper case define (DO_SWITCH,) # process the switch statement # # Pick only ONE of the following pairs !!!!! # define (DO_PASS1,) # output char decl and data statements for "...." define (USE_STRING,"usage: ratp1 [-n] [file] ... >outfile") #define (DO_F77_STRINGS,) # output F77 strings for "...." #define (USE_STRING,"usage: rat77 [-n] [file] ... >outfile") #define (DO_HOLLERITH,) # output hollerith strings for "...." #define (USE_STRING,"usage: ratfor [-n] [file] ... >outfile") define (RADIX,PERCENT) # % indicates alternate radix define (TOGGLE,PERCENT) # toggle for literal lines define (ARGFLAG,DOLLAR) # parameter delimeter in macros 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 # Lexical items: define (LEXBREAK,-8) define (LEXCASE,-25) define (LEXDEFAULT,-26) define (LEXDIGITS,-9) define (LEXDO,-10) define (LEXELSE,-11) define (LEXEND,-21) define (LEXFOR,-16) define (LEXIF,-19) define (LEXLITERAL,-27) define (LEXNEXT,-13) define (LEXOTHER,-14) define (LEXREPEAT,-17) define (LEXRETURN,-20) define (LEXSTOP,-22) define (LEXSTRING,-23) define (LEXSWITCH,-24) define (LEXUNTIL,-18) define (LEXWHILE,-15) define (LSTRIPC,-10) define (RSTRIPC,-11) define (LITQUOTEC,-12) # 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 (ELSEDEFTYPE,-17) define (ENDDEFTYPE,-18) define (NOTDEFTYPE,-19) define (UNDEFTYPE,-21) define (LINKTYPE,-22) define (LENTOKTYPE,-23) # Size-limiting definitions: define(A_S_X,1) define(EVALSIZE,arith(A_S_X,*,500)) define(MEMSIZE,arith(A_S_X,*,4250)) # symbol tables and macro text define(MAXDEF,arith(A_S_X,*,250)) # max chars in a defn define(SBUFSIZE,arith(A_S_X,*,600)) # buffer for string statements define (BUFSIZE,arith(2,*,MAXDEF)) # pushback buffer size define (MAXFORSTK,300) # max space for for reinit clauses define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) define (MAXSTACK,100) # max stack depth for parser define (MAXSWITCH,300) # max stack for switch statement define (MAXTOK,120) # max chars in a token define (NFILES,arith(MAXOFILES,-,3)) # maximum number of include file nests define (MAXNBRSTR,20) # max nbr string decls per module define (CALLSIZE,50) define (ARGSIZE,100) define (COND_STACK_DEPTH,10) # size of conditional stack define (C_TRUE,1) # conditional value is true # Where to find the common blocks: define(COMMON_BLOCKS,"common") define(ext_subr,#) define(ext_func,) #-t- defns ascii 01/09/83 12:06:00 #-h- main ascii 01/09/83 12:06:00 DRIVER(ratfor) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, n ext_func integer getarg, open ext_subr query, initkw, ratarg, lodsym, cant, parse, close, lndict character arg (FILENAMESIZE) call query (USE_STRING) call initkw # initialize variables call ratarg # process command line flags if (dosym == YES) # load symbols call lodsym(arg) # Read standard definitions file n = 1 for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) { if (arg (1) == MINUS) if (arg(2) == EOS) infile (1) = STDIN else next # skip command flags else { infile (1) = open (arg, READ) if (infile (1) == ERR) call cant (arg) } n = n + 1 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 parse } DRETURN end #-t- main ascii 01/09/83 12:06:00 #-h- baderr ascii 01/09/83 12:06:00 # baderr --- report fatal error message, then die subroutine baderr (msg) character msg (ARB) ext_subr synerr, endst call synerr (msg) call endst(ERR) return end #-t- baderr ascii 01/09/83 12:06:00 #-h- balpar ascii 01/09/83 12:06:00 # balpar - copy balanced paren string subroutine balpar character t, token (MAXTOK) ext_func character gettok, gnbtok ext_subr synerr, outstr, pbstr, squash 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 # else nothing special call outstr (token) } until (nlpar <= 0) if (nlpar != 0) call synerr ("missing parenthesis in condition") return end #-t- balpar ascii 01/09/83 12:06:00 #-h- brknxt ascii 01/09/83 12:06:00 # brknxt - generate code for break n and next n; n = 1 is default subroutine brknxt (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token integer i, n character t ext_func integer alldig, ctoi ext_func character gnbtok ext_subr pbstr, outgo, synerr # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) n = 0 t = gnbtok (scrtok, MAXTOK) if (alldig (scrtok) == YES) { # have break n or next n i = 1 n = ctoi (scrtok, i) - 1 } else if (t != SEMICOL) # default case call pbstr (scrtok) 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 #-t- brknxt ascii 01/09/83 12:06:00 #-h- cascod ascii 01/09/83 12:06:00 # cascod - generate code for case or default label subroutine cascod (lab, token) integer lab, token # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer t, l, lb, ub, i, j, junk ext_func integer caslab, labgen ext_func character gnbtok ext_subr synerr, outgo, baderr, outcon if (swtop <= 0) { call synerr ("illegal case or default") return } 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 (scrtok, MAXTOK) if (swstak (swtop + 2) != 0) call baderr ("multiple defaults in switch statement") else swstak (swtop + 2) = l } if (t == EOF) call synerr ("unexpected EOF") else if (t != COLON) call baderr ("missing colon in case or default label") xfer = NO call outcon (l) return end #-t- cascod ascii 01/09/83 12:06:00 #-h- caslab ascii 01/09/83 12:06:00 # caslab - get one case label integer function caslab (n, t) integer n, t character tok (MAXTOK) integer i, s ext_func character gnbtok ext_func integer ctoi ext_subr synerr t = gnbtok (tok, MAXTOK) while (t == NEWLINE) t = gnbtok (tok, MAXTOK) if (t == EOF) return (t) if (t == MINUS) s = -1 else s = +1 if (t == MINUS | t == PLUS) t = gnbtok (tok, MAXTOK) if (t != DIGIT) { call synerr ("invalid case label") n = 0 } else { i = 1 n = s * ctoi (tok, i) } t = gnbtok (tok, MAXTOK) while (t == NEWLINE) t = gnbtok (tok, MAXTOK) return end #-t- caslab ascii 01/09/83 12:06:00 #-h- contln ascii 01/09/83 12:06:00 ### contln - start a continuation line subroutine contln # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) string blstar " *" call outdon call scopy(blstar, 1, outbuf, 1) outp = 6 return end #-t- contln ascii 01/09/83 12:06:00 #-h- deftok ascii 01/09/83 12:06:00 # deftok - get token; process macro calls and invocations # 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 # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t, c, defn (MAXDEF) integer ap, argstk (ARGSIZE), callst (CALLSIZE), nlb, plev (CALLSIZE), ifl ext_func integer ludef, push, ifparm, enter ext_func character gctok ext_subr puttok, getdef, entdef, baderr, putchr, pbstr, putbak, evalr, fold string balp "()" cp = 0 ap = 1 ep = 1 repeat { t = gctok (token, toksiz) if (t == EOF) break 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) == UNDEFTYPE) { # undefine the token call getund (token) # get name to undefine call rmdef (token, deftbl) } 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 = gctok (token, toksiz) if (t == BLANK) { # allow blanks before arguments t = gctok (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 = gctok (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 #-t- deftok ascii 01/09/83 12:06:00 #-h- dmpdcl ascii 01/09/83 12:06:00 # dmpdcl - dump accumulated declarations subroutine dmpdcl(token) character token(ARB) integer i, j, n character c ext_func integer index ext_func character esc # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) string char "character" string comstr "c " string dats "data " string eoss "EOS" if (sbp > 1) # something to do { for (i = 1; i < sbp; i = i + 1) { call outtab call outdef(char, token) call outch(BLANK) c = sbuf(i) j = 1 for (i = i + 1; sbuf(i) != EOS; i = i + 1) { token(j) = sbuf(i) j = j + 1 } token(j) = EOS i = i + 1 call outstr(token) call outdon # call outstr(comstr) # call outstr(token) # call outch(BLANK) # call outch(c) # for (j = i; sbuf(j) != EOS; j = j + 1) # call outch(sbuf(j)) # call outch(c) # call outdon j = index(token, LPAREN) if (j > 0) token(j) = EOS j = 1 repeat { if (sbuf(i) == EOS & c == SQUOTE) break if (j == 1) { call outtab call outstr(dats) } else call outch(COMMA) call outstr(token) if (c == DQUOTE) { call outch(LPAREN) call outnum(j) call outch(RPAREN) } call outch(SLASH) if (sbuf(i) == EOS) { call outdef(eoss, token) call outch(SLASH) break } else { n = esc(sbuf, i) call outnum(n) call outch(SLASH) } j = j + 1 i = i + 1 } call outdon } sbp = 1 } return end #-t- dmpdcl ascii 01/09/83 12:06:00 #-h- doarth ascii 01/09/83 12:06:00 # doarth - do arithmetic operation subroutine doarth (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k, l, ans, first, second character op ext_func integer ctoi ext_subr pbnum, synerr k = argstk (i + 2) first = ctoi(evalst, k) l = argstk (i + 4) second = ctoi(evalst, l) op = evalst (argstk (i + 3)) if (op == PLUS) call pbnum (first + second) else if (op == MINUS) call pbnum (first - second) else if (op == STAR ) { if (evalst(argstk(i+3) + 1) == STAR) { ans = 1 for ( ; second > 0; second = second - 1) ans = ans * first call pbnum(ans) } else call pbnum (first * second) } else if (op == SLASH ) call pbnum (first / second) else call synerr ("arith error") return end #-t- doarth ascii 01/09/83 12:06:00 #-h- docode ascii 01/09/83 12:06:00 # docode - generate code for beginning of do subroutine docode (lab) integer lab integer labgen # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gnbtok ext_subr outtab, outstr, outch, pbstr, outnum, eatup, outdon string sdo "do" xfer = NO call outtab call outstr (sdo) call outch (BLANK) lab = labgen (2) if (gnbtok (scrtok, MAXTOK) == DIGIT) # check for fortran DO call outstr (scrtok) else { call pbstr (scrtok) call outnum (lab) } call outch (BLANK) call eatup call outdon return end #-t- docode ascii 01/09/83 12:06:00 #-h- doif ascii 01/09/83 12:06:00 # doif - select one of two (macro) arguments subroutine doif (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer a2, a3, a4, a5 ext_func integer equal ext_subr pbstr 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 #-t- doif ascii 01/09/83 12:06:00 #-h- doincr ascii 01/09/83 12:06:00 # doincr - increment macro argument by 1 subroutine doincr (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k ext_func integer ctoi ext_subr pbnum k = argstk (i + 2) call pbnum (ctoi (evalst, k) + 1) return end #-t- doincr ascii 01/09/83 12:06:00 #-h- dolent ascii 01/09/83 12:06:00 # dolent - push back length of argument subroutine dolent(argstk, i, j) integer argstk(ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer k ext_func integer length ext_subr pbnum k = argstk(i + 2) call pbnum(length(evalst(k))) return end #-t- dolent ascii 01/09/83 12:06:00 #-h- domac ascii 01/09/83 12:06:00 # domac - install macro definition in table subroutine domac (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer a2, a3 ext_subr entdef ext_func character type if (j - i > 2) { a2 = argstk (i + 2) a3 = argstk (i + 3) if (type(evalst(a2)) != LETTER) call synerr("Illegal first argument to mdefine") else call entdef (evalst (a2), evalst (a3), deftbl) # subarrays } return end #-t- domac ascii 01/09/83 12:06:00 #-h- dostat ascii 01/09/83 12:06:00 # dostat - generate code for end of do statement subroutine dostat (lab) integer lab ext_subr outcon call outcon (lab) call outcon (lab + 1) return end #-t- dostat ascii 01/09/83 12:06:00 #-h- dosub ascii 01/09/83 12:06:00 # dosub - select macro substring subroutine dosub (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer ap, fc, k, nc ext_func integer ctoi, length ext_subr putbak 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 #-t- dosub ascii 01/09/83 12:06:00 #-h- dother ascii 01/09/83 12:06:00 # process one other string in for clause character function dother(token) character token(MAXTOK), t integer nlpar ext_func character gettok ext_subr outtab, synerr, pbstr, squash, outstr, outdon call outtab nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == SEMICOL | (t == COMMA & nlpar == 0)) break if (t == EOF) { call synerr("unexpected EOF") call pbstr(token) break } if (t != NEWLINE) call outstr(token) } call outdon return(t) end #-t- dother ascii 01/09/83 12:06:00 #-h- eatup ascii 01/09/83 12:06:00 # eatup - process rest of statement; interpret continuations subroutine eatup character ptoken (MAXTOK), t, token (MAXTOK) integer nlpar ext_func character gettok ext_subr pbstr, synerr, squash, outstr nlpar = 0 repeat { t = gettok (token, MAXTOK) 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 == LPAREN | t == AND | t == OR | t == NOT | t == BANG | t == TILDE | t == CARET | t == EQUALS) { while (gettok (ptoken, MAXTOK) == NEWLINE) ; call pbstr (ptoken) } if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 call outstr (token) } until (nlpar < 0) if (nlpar != 0) call synerr ("unbalanced parentheses") return end #-t- eatup ascii 01/09/83 12:06:00 #-h- elenth ascii 01/09/83 12:06:00 # calculate length of buf, taking escaped characters into account integer function elenth(buf) character buf(ARB), c integer i, n ext_func character esc n = 0 for (i=1; buf(i) != EOS; i=i+1) { c = esc(buf, i) n = n + 1 } elenth = n return end #-t- elenth ascii 01/09/83 12:06:00 #-h- elseif ascii 01/09/83 12:06:00 # elseif - generate code for end of if before else subroutine elseif (lab) integer lab ext_subr outgo, outcon call outgo (lab+1) call outcon (lab) return end #-t- elseif ascii 01/09/83 12:06:00 #-h- entdkw ascii 01/09/83 12:06:00 # entdkw --- install macro processor keywords subroutine entdkw ext_subr ulstal string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" string undefn "undefine" string linknm "linkage" string lentnm "lentok" call ulstal (defnam, DEFTYPE) call ulstal (macnam, MACTYPE) call ulstal (incnam, INCTYPE) call ulstal (subnam, SUBTYPE) call ulstal (ifnam, IFTYPE) call ulstal (arnam, ARITHTYPE) call ulstal (undefn, UNDEFTYPE) call ulstal(linknm, DEFTYPE) call ulstal(lentnm, LENTOKTYPE) return end #-t- entdkw ascii 01/09/83 12:06:00 #-h- entrkw ascii 01/09/83 12:06:00 # entrkw --- install Ratfor keywords in symbol table subroutine entrkw # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer junk ext_func integer enter 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" junk = enter (sif, LEXIF, rkwtbl) junk = enter (selse, LEXELSE, rkwtbl) junk = enter (swhile, LEXWHILE, rkwtbl) junk = enter (sdo, LEXDO, rkwtbl) junk = enter (sbreak, LEXBREAK, rkwtbl) junk = enter (snext, LEXNEXT, rkwtbl) junk = enter (sfor, LEXFOR, rkwtbl) junk = enter (srept, LEXREPEAT, rkwtbl) junk = enter (suntil, LEXUNTIL, rkwtbl) junk = enter (sret, LEXRETURN, rkwtbl) junk = enter (sstr, LEXSTRING, rkwtbl) junk = enter (sswtch, LEXSWITCH, rkwtbl) junk = enter (scase, LEXCASE, rkwtbl) junk = enter (sdeflt, LEXDEFAULT, rkwtbl) return end #-t- entrkw ascii 01/09/83 12:06:00 #-h- evalr ascii 01/09/83 12:06:00 # evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr (argstk, i, j) integer argstk (ARGSIZE), i, j # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer argno, k, m, n, t, td ext_func integer index, length ext_subr domac, doincr, dosub, doif, doarth, putbak, pbstr 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 if (td == LENTOKTYPE) call dolent (argstk, i, j) else { for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) if (evalst (k - 1) != ARGFLAG) call putbak (evalst (k)) else { argno = index (digits, evalst (k)) - 1 if (argno >= 0) # was a digit { if (argno < j - i) # user provided argument { n = i + argno + 1 m = argstk (n) call pbstr (evalst (m)) } k = k - 1 # skip over $ } else call putbak (evalst (k)) } if (k == t) # do last character call putbak (evalst (k)) } return end #-t- evalr ascii 01/09/83 12:06:00 #-h- fclaus ascii 01/09/83 12:06:00 # process for init or re-init clause subroutine fclaus character token(MAXTOK), t ext_func character gnbtok, dother ext_subr pbstr, synerr repeat { t = gnbtok(token, MAXTOK) # get rid of leading blanks call pbstr(token) # ... t = dother(token) # process single other } until (t == SEMICOL | t == EOF) return end #-t- fclaus ascii 01/09/83 12:06:00 #-h- finit ascii 01/09/83 12:06:00 # finit - initialize for each input file subroutine finit # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) outp = 0 # output character pointer level = 1 # file control linect (1) = 1 sbp = 1 fnamp = 2 fnames (1) = EOS bp = 0 # nothing in push back buffer fordep = 0 # for stack fcname (1) = EOS # current function name swtop = 0 # switch stack swlast = 1 csp = 0 curcnd = C_TRUE return end #-t- finit ascii 01/09/83 12:06:00 #-h- forcod ascii 01/09/83 12:06:00 # forcod - beginning of for statement subroutine forcod (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t integer i, j, nlpar, len ext_func character gettok, gnbtok ext_func integer length, labgen ext_subr outcon, synerr, pbstr, fclaus, outnum, outtab, outstr, outch ext_subr squash, outgo, baderr, scopy string ifnot "if (.not." string semi ";" lab = labgen (3) call outcon (0) if (gnbtok (scrtok, MAXTOK) != LPAREN) { call synerr ("missing left paren") return } if (gnbtok (scrtok, MAXTOK) != SEMICOL) { # real init clause call pbstr (scrtok) call fclaus # output init clause } if (gnbtok (scrtok, MAXTOK) == SEMICOL) # empty condition call outcon (lab) else { # non-empty condition call pbstr (scrtok) call outnum (lab) call outtab call outstr (ifnot) call outch (LPAREN) nlpar = 0 while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == SEMICOL) break if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) return } if (t != NEWLINE) call outstr (scrtok) } call outch (RPAREN) call outch (RPAREN) call outgo (lab+2) if (nlpar < 0) call synerr ("invalid for clause") } fordep = fordep + 1 # stack reinit clause len = 0 # total length of re-init 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 (scrtok, MAXTOK) call pbstr (scrtok) while (nlpar >= 0) { t = gettok (scrtok, MAXTOK) if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr (scrtok) break } if (nlpar >= 0 & t != NEWLINE) { if (j + length (scrtok) >= MAXFORSTK) call baderr ("for clause too long") call scopy (scrtok, 1, forstk, j) j = j + length (scrtok) len = len + length (scrtok) } } lab = lab + 1 # label for next's return end #-t- forcod ascii 01/09/83 12:06:00 #-h- fors ascii 01/09/83 12:06:00 # fors - process end of for statement subroutine fors (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, j ext_func integer length ext_subr outnum, pbstr, fclaus, outgo, outcon 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 putbak (SEMICOL) # push back trailing colon call pbstr (forstk (j)) # push back re-init clause call fclaus # output clause } call outgo (lab - 1) call outcon (lab + 1) fordep = fordep - 1 return end #-t- fors ascii 01/09/83 12:06:00 #-h- gctok ascii 01/09/83 12:06:00 # gctok - get next token, subject to conditionals character function gctok(token, toksiz) character token(MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character temp(9) integer ctype, i, n, j, cndval(4), newcnd, value ext_func character gtok ext_func integer equal, lookup ext_subr upper, baderr, skpblk string letts "eEiI" string cndtbl "ifdef/ifnotdef/elsedef/enddef/" data cndval(1)/IFDEFTYPE/, cndval(2)/IFNOTDEFTYPE/, cndval(3)/ELSEDEFTYPE/, cndval(4)/ENDDEFTYPE/ repeat { gctok = gtok (token, toksiz) if (gctok == EOF) break ctype = NOTDEFTYPE # assume not conditional for (i = 1; letts(i) != EOS; i = i + 1) # see if correct first char if (letts(i) == token(1)) break if (letts(i) != EOS) { # YES, check further n = 1 # index into cndval for (i = 1; cndtbl(i) != EOS; i = i + 1) { for (j = 1; cndtbl(i) != SLASH; j = j + 1) { temp(j) = cndtbl(i) i = i + 1 } temp(j) = EOS j = equal(token, temp) if (j == NO) { call upper(temp) j = equal(token, temp) } if (j == YES) { ctype = cndval(n) break } n = n + 1 } } if (ctype == NOTDEFTYPE) { if (curcnd == C_TRUE) break } else if (ctype == ENDDEFTYPE) { if (csp <= 0) call baderr("Illegal enddef encountered") curcnd = cndstk(csp) csp = csp - 1 } else { if (ctype == ELSEDEFTYPE) newcnd = - curcnd else { if (csp >= COND_STACK_DEPTH) call baderr("Conditionals nested too deeply") csp = csp + 1 cndstk(csp) = curcnd call skpblk if (gtok(temp, 9) != LPAREN) call baderr("missing `(' in conditional") call skpblk if (gtok(token, toksiz) != ALPHA) call baderr("invalid conditional token") call skpblk if (gtok(temp, 9) != RPAREN) call baderr("missing `)' in conditional") if (lookup(token, value, deftbl) == YES) newcnd = C_TRUE else newcnd = - C_TRUE if (ctype == IFNOTDEFTYPE) newcnd = - newcnd } curcnd = min (newcnd, cndstk (csp) ) } } return end #-t- gctok ascii 01/09/83 12:06:00 #-h- gennam ascii 01/09/83 12:06:00 # gennam - generate name for string and character variables integer function gennam(root, countr, buf) character root(ARB), buf(incr(MAXIDLENGTH)), temp(4) integer countr, x, i, d, j string digits "0123456789abcdefghijklmnopqrst" x = countr countr = countr + 1 if (countr > arith(30,**,3)) countr = 1 for (i = 1; x > 0; i = i + 1) { d = mod(x, 30) + 1 temp(i) = digits(d) x = x / 30 } temp(i) = EOS j = 1 call insstr(root, buf, j, MAXIDLENGTH) for (x = 4 - i; x > 0; x = x - 1) call inschr(DIG0, buf, j, MAXIDLENGTH) for (i = i - 1; i > 0; i = i - 1) call inschr(temp(i), buf, j, MAXIDLENGTH) call inschr(LETZ, buf, j, MAXIDLENGTH) buf(j) = EOS return (j-1) end #-t- gennam ascii 01/09/83 12:06:00 #-h- getdef ascii 01/09/83 12:06:00 # getdef (for no arguments) - get name and definition subroutine getdef (token, toksiz, defn, defsiz) character token (MAXTOK), defn (MAXDEF) integer toksiz, defsiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c, t, ptoken (MAXTOK) integer i, nlpar ext_func character gctok, ngetch ext_subr skpblk, pbstr, baderr, putbak call skpblk c = gctok (ptoken, MAXTOK) if (c == LPAREN) t = LPAREN # define (name, defn) else { t = BLANK # define name defn call pbstr (ptoken) } call skpblk if (gctok (token, toksiz) != ALPHA) call baderr ("non-alphanumeric name") call skpblk c = gctok (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 #-t- getdef ascii 01/09/83 12:06:00 #-h- gettok ascii 01/09/83 12:06:00 # gettok - get token. handles file inclusion and line numbers character function gettok (token, toksiz) character token (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer i, len character name (MAXNAME), t, tbuf(9) ext_func integer equal, open, length ext_func character deftok ext_subr skpblk, pbstr, synerr, putbak, scopy, close string fncn "function" string incl "include" for ( ; level > 0; level = level - 1) { repeat { gettok = deftok(token, toksiz) if (gettok == EOF) break else if (gettok != ALPHA) return for (i = 1; i <= 9; i = i + 1) { t = token(i) tbuf(i) = t if (t == EOS) break } if (i < 8 | t != EOS) return call fold(tbuf) if (equal (tbuf, fncn) == YES) { call skpblk t = deftok (fcname, MAXNAME) call pbstr (fcname) if (t != ALPHA) call synerr ("missing function name") call putbak (BLANK) return } else if (equal (tbuf, incl) == NO) return # process 'include' statements: call skpblk t = deftok (name, MAXNAME) if (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) = 1 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 } } token (1) = EOF # in case called more than once token (2) = EOS gettok = EOF return end #-t- gettok ascii 01/09/83 12:06:00 #-h- getund ascii 01/09/83 12:06:00 # getund - get name for undefine statement subroutine getund(token) character token(MAXTOK), temp(4) ext_func character gctok call skpblk if (gctok(token, MAXTOK) != LPAREN) call baderr("missing `(' in undefine") call skpblk if (gctok(token, MAXTOK) != ALPHA) call baderr("non-alphanumeric name") call skpblk if (gctok(temp, 4) != RPAREN) call baderr("missing `)' in undefine") return end #-t- getund ascii 01/09/83 12:06:00 #-h- gnbtok ascii 01/09/83 12:06:00 # gnbtok - get nonblank token character function gnbtok (token, toksiz) character token (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gettok ext_subr skpblk repeat { call skpblk gnbtok = gettok (token, toksiz) } until (gnbtok != BLANK) return end #-t- gnbtok ascii 01/09/83 12:06:00 #-h- gtok ascii 01/09/83 12:06:00 # gtok - get token for Ratfor character function gtok (lexstr, toksiz) character lexstr (MAXTOK) integer toksiz # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c integer i, b, n, d ext_func character ngetch, clower, esc ext_func integer itoc, index, ctoi ext_subr putbak, synerr, relate character ctype ext_func character type string digits "0123456789abcdefghijklmnopqrstuvwxyz" string alfchr ALPHA_CHARACTERS repeat # get next character, gobbling "_@n" { c = ngetch (lexstr (1)) if (c == UNDERLINE) if (ngetch(c) != NEWLINE) { call putbak(c) c = UNDERLINE break } } until (lexstr(1) != UNDERLINE) 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 (type(c) == LETTER) { # alpha for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) ctype = type(c) if (ctype != LETTER & ctype != DIGIT & index(alfchr, c) == 0) break } call putbak (c) gtok = ALPHA } else if (type(c) == DIGIT) { # digits for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) if (type(c) != DIGIT) break } if (c == RADIX) { # n%ddd lexstr(i + 1) = EOS # terminate numeric string n = 1 b = ctoi(lexstr, n) # have base of number } 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 == DQUOTE | c == SQUOTE) { # string or character constant gtok = c for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (lexstr(i) == UNDERLINE) { # see if continuation if (ngetch(c) == NEWLINE) { while (c == NEWLINE | c == BLANK | c == TAB) c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == ATSIGN) { # keep @ intact if (ngetch(c) == EOF) call putbak(c) else { i = i + 1 if (i >= toksiz - 1) i = toksiz - 1 lexstr(i) = c } c = ATSIGN } if (c == lexstr(1)) # found terminator break if (lexstr(i) == NEWLINE | i >= toksiz - 1) { call synerr ("missing quote") lexstr(i) = lexstr(1) call putbak(NEWLINE) break } } if (lexstr(1) == SQUOTE) { # character constant n = 2 c = esc(lexstr, n) if (lexstr(n + 1) != SQUOTE) # flag old style string literal call synerr("missing apostrophe in character literal") n = c i = itoc(n, lexstr, toksiz) # convert to characters gtok = DIGIT } } else if (c == PERCENT) { # possible literal quote if (ngetch(lexstr(2)) != LPAREN) { # not literal quote call putbak(lexstr(2)) gtok = PERCENT } else { gtok = DQUOTE lexstr(1) = LITQUOTEC for (i = 2; ngetch(c) != EOF; i = i + 1) { lexstr(i) = c if (c == UNDERLINE) { # possible continuation if (ngetch(c) == NEWLINE) { # YES it is while (c == NEWLINE | c == BLANK | c == TAB) c = ngetch(c) lexstr(i) = c } else call putbak(c) c = lexstr(i) } if (c == PERCENT) # are we done? if (ngetch(c) == RPAREN) { # YES lexstr(i) = LITQUOTEC break } else call putbak(c) if (lexstr(i) == NEWLINE | i >= toksiz - 1) { call synerr("missing literal quote") lexstr(i) = LITQUOTEC call putbak(NEWLINE) break } } } } else if (c == LITQUOTEC) { # pushed back literal quote gtok = DQUOTE for (i = 2; ngetch(lexstr(i)) != LITQUOTEC; i = i + 1) ; } else if (c == SHARP) { # strip comments while (ngetch (lexstr (1)) != NEWLINE) ; gtok = NEWLINE } else if (c == GREATER | c == LESS | c == NOT | c == AND | c == OR | c == EQUALS | c == BANG | c == TILDE | c == CARET) { 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 #-t- gtok ascii 01/09/83 12:06:00 #-h- ifcode ascii 01/09/83 12:06:00 # ifcode - generate initial code for if subroutine ifcode (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer labgen ext_subr ifgo xfer = NO lab = labgen (2) call ifgo (lab) return end #-t- ifcode ascii 01/09/83 12:06:00 #-h- ifgo ascii 01/09/83 12:06:00 # ifgo - generate "if (.not.(...))goto lab" subroutine ifgo (lab) integer lab ext_subr outtab, outstr, balpar, outch, outgo string ifnot "if (.not." call outtab # get to column 7 call outstr (ifnot) # " if (.not. " call balpar # collect and output condition call outch (RPAREN) # " ) " call outgo (lab) # " goto lab " return end #-t- ifgo ascii 01/09/83 12:06:00 #-h- ifparm ascii 01/09/83 12:06:00 # ifparm - determines if the defined symbol has arguments in its # definition. This effects how the macro is expanded. integer function ifparm (strng) character strng (ARB) character c integer i ext_func integer index ext_func character type c = strng (1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == MACTYPE | c == LENTOKTYPE) 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 #-t- ifparm ascii 01/09/83 12:06:00 #-h- initkw ascii 01/09/83 12:06:00 # initkw - initialize tables and important global variables # this routine assumes that there is no error return from mktabl # entfkw and entrkw assume successful entry of elements in those tables, also subroutine initkw # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func pointer mktabl ext_subr dsinit, entdkw, entrkw, entfkw call dsinit (MEMSIZE) deftbl = mktabl (1) # symbol table for definitions call entdkw rkwtbl = mktabl (1) # symbol table for Ratfor key words call entrkw label = 23000 strcnt = 1 return end #-t- initkw ascii 01/09/83 12:06:00 #-h- inschr ascii 01/09/83 12:06:00 # inschr - put c in buf(bp) if it fits, increment bp subroutine inschr(c, buf, bp, maxsiz) integer bp, maxsiz character c, buf(ARB) ext_subr baderr if (bp > maxsiz) call baderr("buffer overflow") buf(bp) = c bp = bp + 1 return end #-t- inschr ascii 01/09/83 12:06:00 #-h- insdcl ascii 01/09/83 12:06:00 # insdcl - insert declaration information - will be dumped by dmpdcl subroutine insdcl(name, value, c) character name(ARB), value(ARB), c character temp(10) integer strip, dosize, len, junk, first, last, i ext_func integer index, elenth, itoc, length # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) if (value(1) == c) strip = YES else strip = NO dosize = YES # must calculate size if (index(name, LPAREN) > 0 | c == SQUOTE) # size specified by user or char litral dosize = NO call inschr(c, sbuf, sbp, SBUFSIZE) # store type of declaration call insstr(name, sbuf, sbp, SBUFSIZE) # variable name if (dosize == YES) # insert (len) { len = elenth(value) if (strip == YES) len = len - 2 # do not count delimiter if (c == DQUOTE) # need location for EOS len = len + 1 call inschr(LPAREN, sbuf, sbp, SBUFSIZE) junk = itoc(len, temp, 10) call insstr(temp, sbuf, sbp, SBUFSIZE) call inschr(RPAREN, sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) first = 1 last = length(value) if (strip == YES) { first = first + 1 last = last -1 } for (i = first; i <= last; i = i + 1) { call inschr(value(i), sbuf, sbp, SBUFSIZE) } call inschr(EOS, sbuf, sbp, SBUFSIZE) return end #-t- insdcl ascii 01/09/83 12:06:00 #-h- insstr ascii 01/09/83 12:06:00 # insstr - put s in buf(bp) by repeated calls to inschr subroutine insstr(s, buf, bp, maxsiz) character s(ARB), buf(ARB) integer bp, maxsiz integer i ext_subr inschr for (i = 1; s(i) != EOS; i=i+1) call inschr(s(i), buf, bp, maxsiz) return end #-t- insstr ascii 01/09/83 12:06:00 #-h- labelc ascii 01/09/83 12:06:00 # labelc - output statement number subroutine labelc (lexstr) character lexstr (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer length ext_subr synerr, outstr, outtab xfer = NO # can't suppress goto's now if (length (lexstr) == 5) # warn about 23xxx labels if (lexstr (1) == DIG2 & lexstr (2) == DIG3) call synerr ("warning: possible label conflict") call outstr (lexstr) call outtab return end #-t- labelc ascii 01/09/83 12:06:00 #-h- labgen ascii 01/09/83 12:06:00 # labgen - generate n consecutive labels, return first one integer function labgen (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) labgen = label label = label + n return end #-t- labgen ascii 01/09/83 12:06:00 #-h- lex ascii 01/09/83 12:06:00 # lex - return lexical type of token integer function lex (lexstr) character lexstr (MAXTOK) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character gnbtok ext_func integer lookup repeat { lex = gnbtok (lexstr, MAXTOK) if (lex != NEWLINE) break } if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE) return if (lex == DIGIT) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else { call scopy(lexstr, 1, scrtok, 1) call fold(scrtok) if (lookup (scrtok, lex, rkwtbl) == NO) lex = LEXOTHER } return end #-t- lex ascii 01/09/83 12:06:00 #-h- litral ascii 01/09/83 12:06:00 # litral - process literal Fortran line subroutine litral # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character ngetch ext_subr outdon # Finish off any left-over characters if (outp > 0) call outdon for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1) ; outp = outp - 1 call outdon return end #-t- litral ascii 01/09/83 12:06:00 #-h- locsym ascii 01/09/83 12:06:00 # locsym - locate standard definitions file subroutine locsym(file) character file(FILENAMESIZE) string defns STDEFNS call scopy(defns, 1, file, 1) return end #-t- locsym ascii 01/09/83 12:06:00 #-h- lodsym ascii 01/09/83 12:06:00 # lodsym - load standard definitions file subroutine lodsym(fbuf) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character fbuf(FILENAMESIZE) ext_func integer open ext_subr remark, parse, close call locsym(fbuf) # locate file with standard definitions if (fbuf(1) != EOS) { infile(1) = open(fbuf, READ) if (infile(1) == ERR) call remark("cannot open standard definitions file") else { call parse call close(infile(1)) } } return end #-t- lodsym ascii 01/09/83 12:06:00 #-h- ngetch ascii 01/09/83 12:06:00 # ngetch - get a (possibly pushed back) character character function ngetch (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func character getch if (bp > 0) { c = buf(bp) bp = bp - 1 } else { c = getch(c, infile (level) ) if (c == NEWLINE) linect (level) = linect (level) + 1 } return (c) end #-t- ngetch ascii 01/09/83 12:06:00 #-h- otherc ascii 01/09/83 12:06:00 # otherc - output ordinary Fortran statement subroutine otherc (lexstr) character lexstr (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outtab, squash, outstr, eatup, outdon ext_func character type xfer = NO call outtab call outstr (lexstr) call eatup call outdon return end #-t- otherc ascii 01/09/83 12:06:00 #-h- outch ascii 01/09/83 12:06:00 # outch - put one character into output buffer subroutine outch (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outdon if (outp >= 72) # continuation needed call contln outp = outp + 1 outbuf (outp) = c return end #-t- outch ascii 01/09/83 12:06:00 #-h- outcon ascii 01/09/83 12:06:00 # outcon - output "n continue" subroutine outcon (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outnum, outtab, outstr, outdon 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 #-t- outcon ascii 01/09/83 12:06:00 #-h- outdef ascii 01/09/83 12:06:00 # output defined value of string `str' subroutine outdef(str, tok) character str(ARB), tok(MAXTOK), t ext_func character gnbtok call putbak(SLASH) # push back delimiter call pbstr(str) # push back string repeat { t = gnbtok(tok, MAXTOK) if (t == SLASH) break call outstr(tok) } return end #-t- outdef ascii 01/09/83 12:06:00 #-h- outdon ascii 01/09/83 12:06:00 # outdon - finish off an output line subroutine outdon # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr putlin outbuf (outp + 1) = NEWLINE outbuf (outp + 2) = EOS call putlin (outbuf, STDOUT) outp = 0 return end #-t- outdon ascii 01/09/83 12:06:00 #-h- outgo ascii 01/09/83 12:06:00 # outgo - output "goto n" subroutine outgo (n) integer n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outtab, outstr, outnum, outdon string sgoto "goto " if (xfer == YES) return call outtab call outstr (sgoto) call outnum (n) call outdon return end #-t- outgo ascii 01/09/83 12:06:00 #-h- outnum ascii 01/09/83 12:06:00 # outnum - output decimal number subroutine outnum (n) integer n character chars (MAXCHARS) integer i, m ext_subr outch 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 #-t- outnum ascii 01/09/83 12:06:00 #-h- outstr ascii 01/09/83 12:06:00 # outstr - output string; handles quoted literals subroutine outstr (str) character str (ARB) character varbuf(incr(MAXIDLENGTH)) integer i, n # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer qstfix ext_func integer gennam ext_subr outch, outnum, strout string stroot "st" if (str(1) == LITQUOTEC) # literal quoted string for (i = 2; str(i) != LITQUOTEC; i = i + 1) call outch(str(i)) else if (str(1) != DQUOTE) # not a quoted string call strout(str, YES) # output string, uppercase if defined else { n = qstfix(str) i = gennam(stroot, strcnt, varbuf) call insdcl(varbuf, str, DQUOTE) call strout(varbuf, YES) } return end #-t- outstr ascii 01/09/83 12:06:00 #-h- outtab ascii 01/09/83 12:06:00 # outtab - get past column 6 subroutine outtab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr outch while (outp < 6) call outch (BLANK) return end #-t- outtab ascii 01/09/83 12:06:00 #-h- parse ascii 01/09/83 12:06:00 # parse - parse Ratfor source program subroutine parse # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character lexstr (MAXTOK) integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i ext_func integer lex ext_subr finit, ifcode, docode, whilec, forcod, repcod, swcode, synerr ext_subr cascod, labelc, elseif, litral, baderr, swend , otherc, brknxt ext_subr retcod, strdcl, pbstr, unstak call finit sp = 1 lextyp (1) = EOF repeat { if (sbp > 1) # accumulated declarations? call dmpdcl(lexstr) # output them token = lex (lexstr) if (token == EOF) break if (token == LEXIF) call ifcode (lab) else if (token == LEXDO) call docode (lab) else if (token == LEXWHILE) call whilec (lab) else if (token == LEXFOR) call forcod (lab) else if (token == LEXREPEAT) call repcod (lab) else if (token == LEXSWITCH) call swcode (lab) else if (token == LEXCASE | token == 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) } else if (token == LEXDIGITS) call labelc (lexstr) else if (token == LEXELSE) { if (lextyp (sp) == LEXIF) call elseif (labval (sp)) else call synerr ("illegal else") } else if (token == LEXLITERAL) call litral if (token == LEXIF | token == LEXELSE | token == LEXWHILE | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH | token == LEXDO | token == LEXDIGITS | token == LBRACE) { 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) { 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") } else if (token == LEXOTHER) call otherc (lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt (sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod else if (token == LEXSTRING) call strdcl token = lex (lexstr) # peek at next token call pbstr (lexstr) call unstak (sp, lextyp, labval, token) if (token == EOF) break } } if (sp != 1) call synerr ("unexpected EOF") if (csp > 0) call synerr("conditional processing still active at EOF") if (sbp > 1) # accumulated declarations? call synerr("Accumulated declarations at EOF") return end #-t- parse ascii 01/09/83 12:06:00 #-h- pbnum ascii 01/09/83 12:06:00 # pbnum - convert number to string, push back on input subroutine pbnum (n) integer n integer m, num ext_subr putbak string digits "0123456789" num = abs(n) repeat { m = mod (num, 10) call putbak (digits (m + 1)) num = num / 10 } until (num == 0) if (n < 0) call putbak(MINUS) return end #-t- pbnum ascii 01/09/83 12:06:00 #-h- pbstr ascii 01/09/83 12:06:00 # pbstr - push string back onto input subroutine pbstr (in) character in (ARB) integer i ext_func integer length ext_subr putbak for (i = length (in); i > 0; i = i - 1) call putbak (in (i)) return end #-t- pbstr ascii 01/09/83 12:06:00 #-h- push ascii 01/09/83 12:06:00 # push - push ep onto argstk, return new pointer ap integer function push (ep, argstk, ap) integer ap, argstk (ARGSIZE), ep ext_subr baderr if (ap > ARGSIZE) call baderr ("arg stack overflow") argstk (ap) = ep push = ap + 1 return end #-t- push ascii 01/09/83 12:06:00 #-h- putbak ascii 01/09/83 12:06:00 # putbak - push character back onto input subroutine putbak (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr baderr if (bp >= BUFSIZE) call baderr ("too many characters pushed back") else { bp = bp + 1 buf (bp) = c } return end #-t- putbak ascii 01/09/83 12:06:00 #-h- putchr ascii 01/09/83 12:06:00 # putchr - put single char into eval stack subroutine putchr (c) character c # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr baderr if (ep > EVALSIZE) call baderr ("evaluation stack overflow") evalst (ep) = c ep = ep + 1 return end #-t- putchr ascii 01/09/83 12:06:00 #-h- puttok ascii 01/09/83 12:06:00 # puttok-put token into eval stack subroutine puttok (str) character str (MAXTOK) integer i ext_subr putchr for (i = 1; str (i) != EOS; i = i + 1) call putchr (str (i)) return end #-t- puttok ascii 01/09/83 12:06:00 #-h- qstfix ascii 01/09/83 12:06:00 # qstfix - fix quoted string # collapses quoted string in the same array, removing first and last quotes # and converting intermediate @" ==> " # returns the length of the string as its value integer function qstfix(str) character str(ARB) integer last, n, i integer length last = length(str) n = 1 for (i = 2; i < last; i = i + 1) { str(n) = str(i) # copy character n = n + 1 } str(n) = EOS return(n-1) end #-t- qstfix ascii 01/09/83 12:06:00 #-h- ratarg ascii 01/09/83 12:06:00 # ratarg - routine to crack command line flags to ratfor subroutine ratarg integer i ext_func integer getarg # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) dosym = YES # load "symbols" by default for (i = 1; getarg(i, scrtok, MAXTOK) != EOF; i = i + 1) if (scrtok(1) == MINUS & scrtok(2) != EOS) # found a flag if (scrtok(2) == LETN | scrtok(2) == BIGN) # user does not want ratdef dosym = NO return end #-t- ratarg ascii 01/09/83 12:06:00 #-h- relate ascii 01/09/83 12:06:00 # relate - convert relational shorthands into long form subroutine relate (token, last) character token (ARB) integer last ext_func character ngetch ext_func integer length ext_subr putbak 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) == TILDE | token(1) == CARET) { 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 #-t- relate ascii 01/09/83 12:06:00 #-h- repcod ascii 01/09/83 12:06:00 # repcod - generate code for beginning of repeat subroutine repcod (lab) integer lab ext_func integer labgen ext_subr outcon call outcon (0) # in case there was a label lab = labgen (3) call outcon (lab) lab = lab + 1 # label to go on next's return end #-t- repcod ascii 01/09/83 12:06:00 #-h- retcod ascii 01/09/83 12:06:00 # retcod - generate code for return subroutine retcod # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t ext_func character gnbtok ext_subr pbstr, outtab, scopy, squash, outstr, outch, eatup, outdon string sret "return" t = gnbtok (scrtok, MAXTOK) if (t != NEWLINE & t != SEMICOL & t != RBRACE) { call pbstr (scrtok) if ( fcname(1) == EOS ) { # we are in a subroutine call synerr("can't give 'return' an argument from a subroutine") call eatup return } call outtab call scopy (fcname, 1, scrtok, 1) call outstr (scrtok) call outch (EQUALS) call eatup call outdon } else if (t == RBRACE) call pbstr (scrtok) call outtab call outstr (sret) call outdon xfer = YES return end #-t- retcod ascii 01/09/83 12:06:00 #-h- skpblk ascii 01/09/83 12:06:00 # skpblk - skip blanks and tabs in current input file subroutine skpblk # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character c ext_func character ngetch ext_subr putbak repeat c = ngetch (c) until (c != BLANK & c != TAB) call putbak (c) return end #-t- skpblk ascii 01/09/83 12:06:00 #-h- strdcl ascii 01/09/83 12:06:00 # strdcl - generate code for string declaration subroutine strdcl # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character t, dchar (MAXTOK) integer i, j, k, n, len ext_func character gnbtok, esc ext_func integer length, ctoi, lex, elenth ext_subr synerr, squash, outtab, pbstr, outstr, outch, insstr, inschr ext_subr outnum, outdon string char "character" string dat "data " string eoss "EOS" t = gnbtok (scrtok, MAXTOK) if (t != ALPHA) call synerr ("missing string token") if (gnbtok(dchar, MAXTOK) == LPAREN) # user-specified size { call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != DIGIT) call synerr("invalid string size") call concat(scrtok, dchar, scrtok) if (gnbtok(dchar, MAXTOK) != RPAREN) call synerr("missing right paren") call concat(scrtok, dchar, scrtok) t = gnbtok(dchar, MAXTOK) } call insdcl(scrtok, dchar, DQUOTE) return end #-t- strdcl ascii 01/09/83 12:06:00 #-h- strout ascii 01/09/83 12:06:00 # strout - output character array, upper-casing if desired subroutine strout(str, ifup) character str(ARB), c integer ifup, i ext_func character cupper ext_func integer length # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) if ( (length(str) + outp) > 72 ) # don't split keywords call contln for (i = 1; str(i) != EOS; i = i + 1) { c = str(i) if (ifup == YES) c = cupper(c) call outch(c) } return end #-t- strout ascii 01/09/83 12:06:00 #-h- swcode ascii 01/09/83 12:06:00 # swcode - generate code for beginning of switch statement subroutine swcode (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_func integer labgen, gnbtok ext_subr baderr, outtab, swvar , outch, balpar, outdon, outgo, synerr, pbstr string intstr "integer" lab = labgen (2) 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 (lab) call outch (EQUALS) call balpar call outdon call outtab # Integer Innn call outstr (intstr) call outch (BLANK) call swvar (lab) call outdon call outgo (lab) # goto L xfer = YES while (gnbtok (scrtok, MAXTOK) == NEWLINE) ; if (scrtok (1) != LBRACE) { call synerr ("missing left brace in switch statement") call pbstr (scrtok) } return end #-t- swcode ascii 01/09/83 12:06:00 #-h- swend ascii 01/09/83 12:06:00 # swend - finish off switch statement; generate dispatch code subroutine swend (lab) integer lab # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) integer lb, ub, n, i, j ext_subr outgo, outcon, outtab, swvar , outch, outnum, outdon 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." 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 outcon (lab) # L continue if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table if (lb != 1) { # L Innn=Innn-lb+1 call outtab call swvar (lab) call outch (EQUALS) call swvar (lab) if (lb < 1) call outch (PLUS) call outnum (-lb + 1) call outdon } call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr (sif) call swvar (lab) call outstr (slt) call swvar (lab) call outstr (sgt) call outnum (ub - lb + 1) call outch (RPAREN) 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 (lab) 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 (lab) 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 (lab) call outstr (sle) call outnum (swstak (i + 1)) } call outch (RPAREN) # ) goto ... call outgo (swstak (i + 2)) } if (lab + 1 != swstak (swtop + 2)) call outgo (swstak (swtop + 2)) } call outcon (lab + 1) # L+1 continue swlast = swtop # pop switch stack swtop = swstak (swtop) return end #-t- swend ascii 01/09/83 12:06:00 #-h- swvar ascii 01/09/83 12:06:00 # swvar - output switch variable Innn, where nnn = lab subroutine swvar (lab) integer lab ext_subr outch, outnum call outch (BIGI) call outnum (lab) return end #-t- swvar ascii 01/09/83 12:06:00 #-h- synerr ascii 01/09/83 12:06:00 # synerr --- report non-fatal error subroutine synerr (msg) character msg (ARB) # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character lc (MAXCHARS) integer i, junk ext_func integer itoc ext_subr putlin, putch, remark string in " in " string errmsg "error at line " if (curcnd != C_TRUE) # avoid error messages in non-preprocessed code return 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) { # print file name call putlin (in, ERROUT) call putlin (fnames (i), ERROUT) break } call putch (COLON, ERROUT) call putch (BLANK, ERROUT) call remark (msg) return end #-t- synerr ascii 01/09/83 12:06:00 #-h- ulstal ascii 01/09/83 12:06:00 # ulstal - install lower and upper case versions of symbol subroutine ulstal (name, val) character name (ARB), defn (2), val # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) ext_subr entdef, upper defn (1) = val defn (2) = EOS call entdef (name, defn, deftbl) call upper (name) call entdef (name, defn, deftbl) return end #-t- ulstal ascii 01/09/83 12:06:00 #-h- unstak ascii 01/09/83 12:06:00 # unstak - unstack at end of statement subroutine unstak (sp, lextyp, labval, token) integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token ext_subr outcon, dostat, whiles, fors, untils for ( ; sp > 1; sp = sp - 1) { if (lextyp (sp) == LBRACE) break if (lextyp (sp) == LEXSWITCH) break if (lextyp (sp) == LEXIF & token == LEXELSE) break if (lextyp (sp) == LEXIF) call outcon (labval (sp)) else if (lextyp (sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon (labval (sp) + 1) } else if (lextyp (sp) == LEXDO) call dostat (labval (sp)) else if (lextyp (sp) == LEXWHILE) call whiles (labval (sp)) else if (lextyp (sp) == LEXFOR) call fors (labval (sp)) else if (lextyp (sp) == LEXREPEAT) call untils (labval (sp), token) } return end #-t- unstak ascii 01/09/83 12:06:00 #-h- untils ascii 01/09/83 12:06:00 # untils - generate code for until or end of repeat subroutine untils (lab, token) integer lab, token # 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 integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) 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) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values common / csctok / scrtok(MAXTOK) character scrtok # scratch token buffer used by routines called by parse common / cflags / dosym integer dosym # whether to load "symbols" or not; init = YES common / cpass1 / strcnt integer strcnt # counter for generated string variables - init = 1 DS_DECL(mem, MEMSIZE) character ptoken (MAXTOK) integer junk ext_func integer lex ext_subr outnum, ifgo, outgo, outcon xfer = NO call outnum (lab) if (token == LEXUNTIL) { junk = lex (ptoken) call ifgo (lab - 1) } else call outgo (lab - 1) call outcon (lab + 1) return end #-t- untils ascii 01/09/83 12:06:00 #-h- whilec ascii 01/09/83 12:06:00 # whilec - generate code for beginning of while subroutine whilec (lab) integer lab ext_func integer labgen ext_subr outcon, outnum, ifgo call outcon (0) # unlabeled continue, in case there was a label lab = labgen (2) call outnum (lab) call ifgo (lab + 1) return end #-t- whilec ascii 01/09/83 12:06:00 #-h- whiles ascii 01/09/83 12:06:00 # whiles - generate code for end of while subroutine whiles (lab) integer lab ext_subr outgo, outcon call outgo (lab) call outcon (lab + 1) return end #-t- whiles ascii 01/09/83 12:06:00 #-t- ratp1sym.rat ascii 01/09/84 15:54 #-h- ratp2.rat ascii 01/09/84 15:54 #-h- defns 627 asc 24-dec-83 08:45:38 sventek (joseph sventek [lbl/csam]) # # If you are generating the bootstrap version of ratp2, you must # uncomment the following line # #define(DO_BOOTSTRAP,) # define(HEAD,1) define(END,2) define(BODY,3) define(PROG,4) define(TYPE,5) define(COMN,6) define(EQUI,7) define(DAT,8) define(DOUBLE,9) define(BLOCK,10) define(PRECISION,11) define(WRONG,12) define(MAXNAMES,10) define(A_S_X,1) define(MAXBUF,arith(A_S_X,*,20000)) define(MAXSAVE,arith(A_S_X,*,1000)) define(Mem_size,500) #-h- main 454 asc 24-dec-83 08:45:39 sventek (joseph sventek [lbl/csam]) DRIVER(ratp2) integer getarg, open integer i, fd character buf(FILENAMESIZE) call query ("usage: ratp2 [files] ...") for (i=1; getarg(i, buf, FILENAMESIZE) != EOF; i=i+1) { if (buf(1) == '-' & buf(2) == EOS) fd = STDIN else fd = open(buf, READ) if (fd == ERR) call cant (buf) call fsort (fd, STDOUT) if (fd != STDIN) call close (fd) } if (i == 1) # no files given call fsort (STDIN, STDOUT) DRETURN end #-h- fsort 745 asc 24-dec-83 08:45:40 sventek (joseph sventek [lbl/csam]) subroutine fsort(ifd,ofd) integer ifd,ofd integer len, i integer kind character line(MAXLINE) integer getlin, lookup, mktabl integer gcode DS_DECL(Mem,Mem_size) #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb call dsinit(Mem_size) nextp = 1 ptr(nextp) = 1 kind = WRONG stb = mktabl (1) call initfs (stb) for(len=getlin(line,ifd);len!=EOF;len=getlin(line,ifd)) { i = 1 call skipbl(line, i) if (line(i) == '@n') # line is blank next; if (len>6 & line(6)!= ' ' & line(6)!= '0' & line(6)!= '@t') { # continuation line # kind = kind } else kind = gcode(line) call keepln(line,kind) if (kind==END) { call sflush (ofd) nextp = 1 ptr(nextp) = 1 kind = WRONG } } if (nextp > 1) # flush accumulated stuff call sflush (ofd) return end #-h- ftntok 806 asc 24-dec-83 08:45:41 sventek (joseph sventek [lbl/csam]) # ftntok - routine to return next FORTRAN token in `token', incrementing # `i'. The token is folded to lower case and the length is # returned as the function value integer function ftntok(line, i, token) character line(ARB), token(ARB), c integer i, j character type call skipbl(line, i) # skip leading blanks and tabs j = 1 if (type(line(i)) == LETTER) # get token if starts with alpha repeat { token(j) = line(i) j = j + 1 i = i + 1 c = type(line(i)) } until (c != LETTER & c != DIGIT & c != '_') token(j) = EOS if (line(i) == '*') # handle type*N declarations repeat i = i + 1 until (type(line(i)) != DIGIT) # skip to first non-digit call fold(token) # lower case for future comparisons return(j - 1) # return length end #-h- gcode 563 asc 24-dec-83 08:45:42 sventek (joseph sventek [lbl/csam]) integer function gcode(line) character line(ARB), word(MAXLINE) integer i, len, code integer lookup, ftntok integer tmp #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb i = 1 if (ftntok(line, i, word) == 0) return(BODY) if (lookup(word, code, stb) == NO) return(BODY) if (code==BLOCK | code==DOUBLE) { tmp = code len = ftntok(line,i,word) if (lookup(word,code, stb) == NO) return(BODY) if (tmp==BLOCK & code==DAT) return(PROG) else if(tmp==DOUBLE & code==PRECISION) return(TYPE) else return(BODY) } else return(code) return(BODY) # no path here but supress message end #-h- initfs 1100 asc 24-dec-83 08:45:43 sventek (joseph sventek [lbl/csam]) subroutine initfs (tb) integer tb # symbol table pointer integer junk integer enter string send "end" string sprog "program" string ssub "subroutine" string sfunc "function" string sblck "block" string sdata "data" string sint "integer" string sreal "real" string sdoubl "double" string sprec "precision" string slog "logical" string scompl "complex" string schar "character" string sbyte "byte" string sext "external" string sdim "dimension" string simpl "implicit" string scom "common" string sequ "equivalence" junk = enter(sprog, PROG, tb) junk = enter(ssub, PROG, tb) junk = enter(sblck, BLOCK, tb) junk = enter(scom, COMN, tb) junk = enter(sfunc, TYPE, tb) junk = enter(sint, TYPE, tb) junk = enter(sreal, TYPE, tb) junk = enter(slog, TYPE, tb) junk = enter(scompl, TYPE, tb) junk = enter(schar, TYPE, tb) junk = enter(sbyte, TYPE, tb) junk = enter(sdim, TYPE, tb) junk = enter(sext, TYPE, tb) junk = enter(simpl, TYPE, tb) junk = enter(sequ, EQUI, tb) junk = enter(sdata, DAT, tb) junk = enter(sdoubl, DOUBLE, tb) junk = enter(sprec, PRECISION, tb) junk = enter(send, END, tb) return end #-h- keepln 396 asc 24-dec-83 08:45:44 sventek (joseph sventek [lbl/csam]) subroutine keepln(line,kind) character line(ARB) integer length integer i,j integer kind #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb if (kind == WRONG) call error("ratp2 sequence error") if (nextp == MAXSAVE) call error("too many decl lines") type(nextp) = kind i = ptr(nextp) j = length(line) if (i+j >= MAXBUF) call error("too many decl chars") call scopy(line,1,buf,i) nextp = nextp + 1 ptr(nextp) = i+j+1 return end #-h- sflush 421 asc 24-dec-83 08:45:45 sventek (joseph sventek [lbl/csam]) subroutine sflush(fd) integer fd,j,p integer i,kind, ord(MAXNAMES) #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb data ord(1)/PROG/, ord(2)/TYPE/, ord(3)/COMN/, ord(4)/EQUI/, ord(5)/DAT/, ord(6)/BODY/, ord(7)/END/, ord(8)/WRONG/ for (i=1; ord(i) != WRONG; i=i+1) # step thru kinds { kind = ord(i) for (p=1; p6 & line(6)!= ' ' & line(6)!= '0' & line(6)!= '@t') { # continuation line # kind = kind } else kind = gcode(line) call keepln(line,kind) if (kind==END) { call sflush (ofd) nextp = 1 ptr(nextp) = 1 kind = WRONG } } if (nextp > 1) # flush accumulated stuff call sflush (ofd) return end #-t- fsort ascii 01/09/84 15:24 #-h- ftntok ascii 01/09/84 15:24 # ftntok - routine to return next FORTRAN token in `token', incrementing # `i'. The token is folded to lower case and the length is # returned as the function value integer function ftntok(line, i, token) character line(ARB), token(ARB), c integer i, j character type call skipbl(line, i) # skip leading blanks and tabs j = 1 if (type(line(i)) == LETTER) # get token if starts with alpha repeat { token(j) = line(i) j = j + 1 i = i + 1 c = type(line(i)) } until (c != LETTER & c != DIGIT & c != '_') token(j) = EOS if (line(i) == '*') # handle type*N declarations repeat i = i + 1 until (type(line(i)) != DIGIT) # skip to first non-digit call fold(token) # lower case for future comparisons return(j - 1) # return length end #-t- ftntok ascii 01/09/84 15:24 #-h- gcode ascii 01/09/84 15:24 integer function gcode(line) character line(ARB), word(MAXLINE) integer i, len, code integer lookup, ftntok integer tmp include cratp2 i = 1 if (ftntok(line, i, word) == 0) return(BODY) if (lookup(word, code, stb) == NO) return(BODY) if (code==BLOCK | code==DOUBLE) { tmp = code len = ftntok(line,i,word) if (lookup(word,code, stb) == NO) return(BODY) if (tmp==BLOCK & code==DAT) return(PROG) else if(tmp==DOUBLE & code==PRECISION) return(TYPE) else return(BODY) } else return(code) return(BODY) # no path here but supress message end #-t- gcode ascii 01/09/84 15:24 #-h- initfs ascii 01/09/84 15:24 subroutine initfs (tb) integer tb # symbol table pointer integer junk integer enter string send "end" string sprog "program" string ssub "subroutine" string sfunc "function" string sblck "block" string sdata "data" string sint "integer" string sreal "real" string sdoubl "double" string sprec "precision" string slog "logical" string scompl "complex" string schar "character" string sbyte "byte" string sext "external" string sdim "dimension" string simpl "implicit" string scom "common" string sequ "equivalence" junk = enter(sprog, PROG, tb) junk = enter(ssub, PROG, tb) junk = enter(sblck, BLOCK, tb) junk = enter(scom, COMN, tb) junk = enter(sfunc, TYPE, tb) junk = enter(sint, TYPE, tb) junk = enter(sreal, TYPE, tb) junk = enter(slog, TYPE, tb) junk = enter(scompl, TYPE, tb) junk = enter(schar, TYPE, tb) junk = enter(sbyte, TYPE, tb) junk = enter(sdim, TYPE, tb) junk = enter(sext, TYPE, tb) junk = enter(simpl, TYPE, tb) junk = enter(sequ, EQUI, tb) junk = enter(sdata, DAT, tb) junk = enter(sdoubl, DOUBLE, tb) junk = enter(sprec, PRECISION, tb) junk = enter(send, END, tb) return end #-t- initfs ascii 01/09/84 15:24 #-h- keepln ascii 01/09/84 15:24 subroutine keepln(line,kind) character line(ARB) integer length integer i,j integer kind include cratp2 if (kind == WRONG) call error("ratp2 sequence error") if (nextp == MAXSAVE) call error("too many decl lines") type(nextp) = kind i = ptr(nextp) j = length(line) if (i+j >= MAXBUF) call error("too many decl chars") call scopy(line,1,buf,i) nextp = nextp + 1 ptr(nextp) = i+j+1 return end #-t- keepln ascii 01/09/84 15:24 #-h- sflush ascii 01/09/84 15:24 subroutine sflush(fd) integer fd,j,p integer i,kind, ord(MAXNAMES) include cratp2 data ord(1)/PROG/, ord(2)/TYPE/, ord(3)/COMN/, ord(4)/EQUI/, ord(5)/DAT/, ord(6)/BODY/, ord(7)/END/, ord(8)/WRONG/ for (i=1; ord(i) != WRONG; i=i+1) # step thru kinds { kind = ord(i) for (p=1; poutfile .ds `ratp2' is the second pass of the new pre-processor. It's function is to re-order the output of the first pass to be ANSI-66 compliant. It's input is simply FORTRAN code, and all statements between successive END statements are re-ordered. If filename arguments are not provided, it reads from standard input. .sa ratfor, the ratfor preprocessor, for descriptions of the language. .au Phil Scherrer wrote ratp2. .bu #-t- ratp2doc ascii 01/09/84 15:25 #-t- ratp2.z ascii 01/09/84 15:54 #-h- ratp2b2ch.f ascii 01/09/84 15:54 CALL INITST CALL RATP2 CALL ENDST(0) END SUBROUTINE RATP2 CALL FSORT (1, 2) RETURN END SUBROUTINE FSORT(IFD,OFD) INTEGER IFD,OFD INTEGER LEN, I INTEGER KIND BYTE LINE(82) INTEGER GETLIN, LOOKUP, MKTABL INTEGER GCODE INTEGER MEM(500) BYTE CMEM(1000) BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /CDSMEM/ MEM COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT(500) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 STB = MKTABL (1) CALL INITFS (STB) LEN=GETLIN(LINE,IFD) 23000 IF (.NOT.(LEN.NE.-1))GOTO 23002 I = 1 CALL SKIPBL(LINE, I) IF (.NOT.(LINE(I) .EQ. 10))GOTO 23003 GOTO 23001 23003 CONTINUE IF (.NOT.(LEN.GT.6 .AND. LINE(6).NE. 32 .AND. LINE(6).NE. 48 .AND. * LINE(6).NE. 9))GOTO 23005 GOTO 23006 23005 CONTINUE KIND = GCODE(LINE) 23006 CONTINUE CALL KEEPLN(LINE,KIND) IF (.NOT.(KIND.EQ.2))GOTO 23007 CALL SFLUSH (OFD) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 23007 CONTINUE 23001 LEN=GETLIN(LINE,IFD) GOTO 23000 23002 CONTINUE IF (.NOT.(NEXTP .GT. 1))GOTO 23009 CALL SFLUSH (OFD) 23009 CONTINUE RETURN END INTEGER FUNCTION FTNTOK(LINE, I, TOKEN) BYTE LINE(100), TOKEN(100), C INTEGER I, J BYTE TYPE CALL SKIPBL(LINE, I) J = 1 IF (.NOT.(TYPE(LINE(I)) .EQ. 1))GOTO 23011 23013 CONTINUE TOKEN(J) = LINE(I) J = J + 1 I = I + 1 C = TYPE(LINE(I)) 23014 IF (.NOT.(C .NE. 1 .AND. C .NE. 2 .AND. C .NE. 95))GOTO 23013 23015 CONTINUE 23011 CONTINUE TOKEN(J) = 0 IF (.NOT.(LINE(I) .EQ. 42))GOTO 23016 23018 CONTINUE I = I + 1 23019 IF (.NOT.(TYPE(LINE(I)) .NE. 2))GOTO 23018 23020 CONTINUE 23016 CONTINUE CALL FOLD(TOKEN) FTNTOK=(J - 1) RETURN END INTEGER FUNCTION GCODE(LINE) BYTE LINE(100), WORD(82) INTEGER I, LEN, CODE INTEGER LOOKUP, FTNTOK INTEGER TMP BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB I = 1 IF (.NOT.(FTNTOK(LINE, I, WORD) .EQ. 0))GOTO 23021 GCODE=(3) RETURN 23021 CONTINUE IF (.NOT.(LOOKUP(WORD, CODE, STB) .EQ. 0))GOTO 23023 GCODE=(3) RETURN 23023 CONTINUE IF (.NOT.(CODE.EQ.10 .OR. CODE.EQ.9))GOTO 23025 TMP = CODE LEN = FTNTOK(LINE,I,WORD) IF (.NOT.(LOOKUP(WORD,CODE, STB) .EQ. 0))GOTO 23027 GCODE=(3) RETURN 23027 CONTINUE IF (.NOT.(TMP.EQ.10 .AND. CODE.EQ.8))GOTO 23029 GCODE=(4) RETURN 23029 CONTINUE IF (.NOT.(TMP.EQ.9 .AND. CODE.EQ.11))GOTO 23031 GCODE=(5) RETURN 23031 CONTINUE GCODE=(3) RETURN 23032 CONTINUE 23030 CONTINUE GOTO 23026 23025 CONTINUE GCODE=(CODE) RETURN 23026 CONTINUE GCODE=(3) RETURN END SUBROUTINE INITFS (TB) INTEGER TB INTEGER JUNK INTEGER ENTER BYTE SEND(4) BYTE SPROG(8) BYTE SSUB(11) BYTE SFUNC(9) BYTE SBLCK(6) BYTE SDATA(5) BYTE SINT(8) BYTE SREAL(5) BYTE SDOUBL(7) BYTE SPREC(10) BYTE SLOG(8) BYTE SCOMPL(8) BYTE SCHAR(10) BYTE SBYTE(5) BYTE SEXT(9) BYTE SDIM(10) BYTE SIMPL(9) BYTE SCOM(7) BYTE SEQU(12) DATA SEND(1)/101/,SEND(2)/110/,SEND(3)/100/,SEND(4)/0/ DATA SPROG(1)/112/,SPROG(2)/114/,SPROG(3)/111/,SPROG(4)/103/,SPROG *(5)/114/,SPROG(6)/97/,SPROG(7)/109/,SPROG(8)/0/ DATA SSUB(1)/115/,SSUB(2)/117/,SSUB(3)/98/,SSUB(4)/114/,SSUB(5)/11 *1/,SSUB(6)/117/,SSUB(7)/116/,SSUB(8)/105/,SSUB(9)/110/,SSUB(10)/10 *1/,SSUB(11)/0/ DATA SFUNC(1)/102/,SFUNC(2)/117/,SFUNC(3)/110/,SFUNC(4)/99/,SFUNC( *5)/116/,SFUNC(6)/105/,SFUNC(7)/111/,SFUNC(8)/110/,SFUNC(9)/0/ DATA SBLCK(1)/98/,SBLCK(2)/108/,SBLCK(3)/111/,SBLCK(4)/99/,SBLCK(5 *)/107/,SBLCK(6)/0/ DATA SDATA(1)/100/,SDATA(2)/97/,SDATA(3)/116/,SDATA(4)/97/,SDATA(5 *)/0/ DATA SINT(1)/105/,SINT(2)/110/,SINT(3)/116/,SINT(4)/101/,SINT(5)/1 *03/,SINT(6)/101/,SINT(7)/114/,SINT(8)/0/ DATA SREAL(1)/114/,SREAL(2)/101/,SREAL(3)/97/,SREAL(4)/108/,SREAL( *5)/0/ DATA SDOUBL(1)/100/,SDOUBL(2)/111/,SDOUBL(3)/117/,SDOUBL(4)/98/, *SDOUBL(5)/108/,SDOUBL(6)/101/,SDOUBL(7)/0/ DATA SPREC(1)/112/,SPREC(2)/114/,SPREC(3)/101/,SPREC(4)/99/,SPREC( *5)/105/,SPREC(6)/115/,SPREC(7)/105/,SPREC(8)/111/,SPREC(9)/110/, *SPREC(10)/0/ DATA SLOG(1)/108/,SLOG(2)/111/,SLOG(3)/103/,SLOG(4)/105/,SLOG(5)/9 *9/,SLOG(6)/97/,SLOG(7)/108/,SLOG(8)/0/ DATA SCOMPL(1)/99/,SCOMPL(2)/111/,SCOMPL(3)/109/,SCOMPL(4)/112/, *SCOMPL(5)/108/,SCOMPL(6)/101/,SCOMPL(7)/120/,SCOMPL(8)/0/ DATA SCHAR(1)/99/,SCHAR(2)/104/,SCHAR(3)/97/,SCHAR(4)/114/,SCHAR(5 *)/97/,SCHAR(6)/99/,SCHAR(7)/116/,SCHAR(8)/101/,SCHAR(9)/114/,SCHAR *(10)/0/ DATA SBYTE(1)/98/,SBYTE(2)/121/,SBYTE(3)/116/,SBYTE(4)/101/,SBYTE( *5)/0/ DATA SEXT(1)/101/,SEXT(2)/120/,SEXT(3)/116/,SEXT(4)/101/,SEXT(5)/1 *14/,SEXT(6)/110/,SEXT(7)/97/,SEXT(8)/108/,SEXT(9)/0/ DATA SDIM(1)/100/,SDIM(2)/105/,SDIM(3)/109/,SDIM(4)/101/,SDIM(5)/1 *10/,SDIM(6)/115/,SDIM(7)/105/,SDIM(8)/111/,SDIM(9)/110/,SDIM(10)/0 */ DATA SIMPL(1)/105/,SIMPL(2)/109/,SIMPL(3)/112/,SIMPL(4)/108/,SIMPL *(5)/105/,SIMPL(6)/99/,SIMPL(7)/105/,SIMPL(8)/116/,SIMPL(9)/0/ DATA SCOM(1)/99/,SCOM(2)/111/,SCOM(3)/109/,SCOM(4)/109/,SCOM(5)/11 *1/,SCOM(6)/110/,SCOM(7)/0/ DATA SEQU(1)/101/,SEQU(2)/113/,SEQU(3)/117/,SEQU(4)/105/,SEQU(5)/1 *18/,SEQU(6)/97/,SEQU(7)/108/,SEQU(8)/101/,SEQU(9)/110/,SEQU(10)/99 */,SEQU(11)/101/,SEQU(12)/0/ JUNK = ENTER(SPROG, 4, TB) JUNK = ENTER(SSUB, 4, TB) JUNK = ENTER(SBLCK, 10, TB) JUNK = ENTER(SCOM, 6, TB) JUNK = ENTER(SFUNC, 5, TB) JUNK = ENTER(SINT, 5, TB) JUNK = ENTER(SREAL, 5, TB) JUNK = ENTER(SLOG, 5, TB) JUNK = ENTER(SCOMPL, 5, TB) JUNK = ENTER(SCHAR, 5, TB) JUNK = ENTER(SBYTE, 5, TB) JUNK = ENTER(SDIM, 5, TB) JUNK = ENTER(SEXT, 5, TB) JUNK = ENTER(SIMPL, 5, TB) JUNK = ENTER(SEQU, 7, TB) JUNK = ENTER(SDATA, 8, TB) JUNK = ENTER(SDOUBL, 9, TB) JUNK = ENTER(SPREC, 11, TB) JUNK = ENTER(SEND, 2, TB) RETURN END SUBROUTINE KEEPLN(LINE,KIND) BYTE LINE(100) INTEGER LENGTH INTEGER I,J INTEGER KIND BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB BYTE ST001Z(21) BYTE ST002Z(20) BYTE ST003Z(20) COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ST001Z(1)/114/,ST001Z(2)/97/,ST001Z(3)/116/,ST001Z(4)/112/, *ST001Z(5)/50/,ST001Z(6)/32/,ST001Z(7)/115/,ST001Z(8)/101/,ST001Z(9 *)/113/,ST001Z(10)/117/,ST001Z(11)/101/,ST001Z(12)/110/,ST001Z(13)/ *99/,ST001Z(14)/101/,ST001Z(15)/32/,ST001Z(16)/101/,ST001Z(17)/114/ *,ST001Z(18)/114/,ST001Z(19)/111/,ST001Z(20)/114/,ST001Z(21)/0/ DATA ST002Z(1)/116/,ST002Z(2)/111/,ST002Z(3)/111/,ST002Z(4)/32/, *ST002Z(5)/109/,ST002Z(6)/97/,ST002Z(7)/110/,ST002Z(8)/121/,ST002Z( *9)/32/,ST002Z(10)/100/,ST002Z(11)/101/,ST002Z(12)/99/,ST002Z(13)/1 *08/,ST002Z(14)/32/,ST002Z(15)/108/,ST002Z(16)/105/,ST002Z(17)/110/ *,ST002Z(18)/101/,ST002Z(19)/115/,ST002Z(20)/0/ DATA ST003Z(1)/116/,ST003Z(2)/111/,ST003Z(3)/111/,ST003Z(4)/32/, *ST003Z(5)/109/,ST003Z(6)/97/,ST003Z(7)/110/,ST003Z(8)/121/,ST003Z( *9)/32/,ST003Z(10)/100/,ST003Z(11)/101/,ST003Z(12)/99/,ST003Z(13)/1 *08/,ST003Z(14)/32/,ST003Z(15)/99/,ST003Z(16)/104/,ST003Z(17)/97/, *ST003Z(18)/114/,ST003Z(19)/115/,ST003Z(20)/0/ IF (.NOT.(KIND .EQ. 12))GOTO 23033 CALL ERROR(ST001Z) 23033 CONTINUE IF (.NOT.(NEXTP .EQ. 500))GOTO 23035 CALL ERROR(ST002Z) 23035 CONTINUE TYPE(NEXTP) = KIND I = PTR(NEXTP) J = LENGTH(LINE) IF (.NOT.(I+J .GE. 10000))GOTO 23037 CALL ERROR(ST003Z) 23037 CONTINUE CALL SCOPY(LINE,1,BUF,I) NEXTP = NEXTP + 1 PTR(NEXTP) = I+J+1 RETURN END SUBROUTINE SFLUSH(FD) INTEGER FD,J,P INTEGER I,KIND, ORD(10) BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ORD(1)/4/, ORD(2)/5/, ORD(3)/6/, ORD(4)/7/, ORD(5)/8/, ORD(6) */3/, ORD(7)/2/, ORD(8)/12/ I=1 23039 IF (.NOT.(ORD(I) .NE. 12))GOTO 23041 KIND = ORD(I) P=1 23042 IF (.NOT.(P.LT.NEXTP))GOTO 23044 IF (.NOT.(TYPE(P) .EQ. KIND))GOTO 23045 J = PTR(P) CALL PUTLIN(BUF(J),FD) 23045 CONTINUE 23043 P=P+1 GOTO 23042 23044 CONTINUE 23040 I=I+1 GOTO 23039 23041 CONTINUE RETURN END #-t- ratp2b2ch.f ascii 01/09/84 15:54 #-h- ratp2b4ch.f ascii 01/09/84 15:54 CALL INITST CALL RATP2 CALL ENDST(0) END SUBROUTINE RATP2 CALL FSORT (1, 2) RETURN END SUBROUTINE FSORT(IFD,OFD) INTEGER IFD,OFD INTEGER LEN, I INTEGER KIND BYTE LINE(82) INTEGER GETLIN, LOOKUP, MKTABL INTEGER GCODE INTEGER MEM(500) BYTE CMEM(2000) BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /CDSMEM/ MEM COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT(500) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 STB = MKTABL (1) CALL INITFS (STB) LEN=GETLIN(LINE,IFD) 23000 IF (.NOT.(LEN.NE.-1))GOTO 23002 I = 1 CALL SKIPBL(LINE, I) IF (.NOT.(LINE(I) .EQ. 10))GOTO 23003 GOTO 23001 23003 CONTINUE IF (.NOT.(LEN.GT.6 .AND. LINE(6).NE. 32 .AND. LINE(6).NE. 48 .AND. * LINE(6).NE. 9))GOTO 23005 GOTO 23006 23005 CONTINUE KIND = GCODE(LINE) 23006 CONTINUE CALL KEEPLN(LINE,KIND) IF (.NOT.(KIND.EQ.2))GOTO 23007 CALL SFLUSH (OFD) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 23007 CONTINUE 23001 LEN=GETLIN(LINE,IFD) GOTO 23000 23002 CONTINUE IF (.NOT.(NEXTP .GT. 1))GOTO 23009 CALL SFLUSH (OFD) 23009 CONTINUE RETURN END INTEGER FUNCTION FTNTOK(LINE, I, TOKEN) BYTE LINE(100), TOKEN(100), C INTEGER I, J BYTE TYPE CALL SKIPBL(LINE, I) J = 1 IF (.NOT.(TYPE(LINE(I)) .EQ. 1))GOTO 23011 23013 CONTINUE TOKEN(J) = LINE(I) J = J + 1 I = I + 1 C = TYPE(LINE(I)) 23014 IF (.NOT.(C .NE. 1 .AND. C .NE. 2 .AND. C .NE. 95))GOTO 23013 23015 CONTINUE 23011 CONTINUE TOKEN(J) = 0 IF (.NOT.(LINE(I) .EQ. 42))GOTO 23016 23018 CONTINUE I = I + 1 23019 IF (.NOT.(TYPE(LINE(I)) .NE. 2))GOTO 23018 23020 CONTINUE 23016 CONTINUE CALL FOLD(TOKEN) FTNTOK=(J - 1) RETURN END INTEGER FUNCTION GCODE(LINE) BYTE LINE(100), WORD(82) INTEGER I, LEN, CODE INTEGER LOOKUP, FTNTOK INTEGER TMP BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB I = 1 IF (.NOT.(FTNTOK(LINE, I, WORD) .EQ. 0))GOTO 23021 GCODE=(3) RETURN 23021 CONTINUE IF (.NOT.(LOOKUP(WORD, CODE, STB) .EQ. 0))GOTO 23023 GCODE=(3) RETURN 23023 CONTINUE IF (.NOT.(CODE.EQ.10 .OR. CODE.EQ.9))GOTO 23025 TMP = CODE LEN = FTNTOK(LINE,I,WORD) IF (.NOT.(LOOKUP(WORD,CODE, STB) .EQ. 0))GOTO 23027 GCODE=(3) RETURN 23027 CONTINUE IF (.NOT.(TMP.EQ.10 .AND. CODE.EQ.8))GOTO 23029 GCODE=(4) RETURN 23029 CONTINUE IF (.NOT.(TMP.EQ.9 .AND. CODE.EQ.11))GOTO 23031 GCODE=(5) RETURN 23031 CONTINUE GCODE=(3) RETURN 23032 CONTINUE 23030 CONTINUE GOTO 23026 23025 CONTINUE GCODE=(CODE) RETURN 23026 CONTINUE GCODE=(3) RETURN END SUBROUTINE INITFS (TB) INTEGER TB INTEGER JUNK INTEGER ENTER BYTE SEND(4) BYTE SPROG(8) BYTE SSUB(11) BYTE SFUNC(9) BYTE SBLCK(6) BYTE SDATA(5) BYTE SINT(8) BYTE SREAL(5) BYTE SDOUBL(7) BYTE SPREC(10) BYTE SLOG(8) BYTE SCOMPL(8) BYTE SCHAR(10) BYTE SBYTE(5) BYTE SEXT(9) BYTE SDIM(10) BYTE SIMPL(9) BYTE SCOM(7) BYTE SEQU(12) DATA SEND(1)/101/,SEND(2)/110/,SEND(3)/100/,SEND(4)/0/ DATA SPROG(1)/112/,SPROG(2)/114/,SPROG(3)/111/,SPROG(4)/103/,SPROG *(5)/114/,SPROG(6)/97/,SPROG(7)/109/,SPROG(8)/0/ DATA SSUB(1)/115/,SSUB(2)/117/,SSUB(3)/98/,SSUB(4)/114/,SSUB(5)/11 *1/,SSUB(6)/117/,SSUB(7)/116/,SSUB(8)/105/,SSUB(9)/110/,SSUB(10)/10 *1/,SSUB(11)/0/ DATA SFUNC(1)/102/,SFUNC(2)/117/,SFUNC(3)/110/,SFUNC(4)/99/,SFUNC( *5)/116/,SFUNC(6)/105/,SFUNC(7)/111/,SFUNC(8)/110/,SFUNC(9)/0/ DATA SBLCK(1)/98/,SBLCK(2)/108/,SBLCK(3)/111/,SBLCK(4)/99/,SBLCK(5 *)/107/,SBLCK(6)/0/ DATA SDATA(1)/100/,SDATA(2)/97/,SDATA(3)/116/,SDATA(4)/97/,SDATA(5 *)/0/ DATA SINT(1)/105/,SINT(2)/110/,SINT(3)/116/,SINT(4)/101/,SINT(5)/1 *03/,SINT(6)/101/,SINT(7)/114/,SINT(8)/0/ DATA SREAL(1)/114/,SREAL(2)/101/,SREAL(3)/97/,SREAL(4)/108/,SREAL( *5)/0/ DATA SDOUBL(1)/100/,SDOUBL(2)/111/,SDOUBL(3)/117/,SDOUBL(4)/98/, *SDOUBL(5)/108/,SDOUBL(6)/101/,SDOUBL(7)/0/ DATA SPREC(1)/112/,SPREC(2)/114/,SPREC(3)/101/,SPREC(4)/99/,SPREC( *5)/105/,SPREC(6)/115/,SPREC(7)/105/,SPREC(8)/111/,SPREC(9)/110/, *SPREC(10)/0/ DATA SLOG(1)/108/,SLOG(2)/111/,SLOG(3)/103/,SLOG(4)/105/,SLOG(5)/9 *9/,SLOG(6)/97/,SLOG(7)/108/,SLOG(8)/0/ DATA SCOMPL(1)/99/,SCOMPL(2)/111/,SCOMPL(3)/109/,SCOMPL(4)/112/, *SCOMPL(5)/108/,SCOMPL(6)/101/,SCOMPL(7)/120/,SCOMPL(8)/0/ DATA SCHAR(1)/99/,SCHAR(2)/104/,SCHAR(3)/97/,SCHAR(4)/114/,SCHAR(5 *)/97/,SCHAR(6)/99/,SCHAR(7)/116/,SCHAR(8)/101/,SCHAR(9)/114/,SCHAR *(10)/0/ DATA SBYTE(1)/98/,SBYTE(2)/121/,SBYTE(3)/116/,SBYTE(4)/101/,SBYTE( *5)/0/ DATA SEXT(1)/101/,SEXT(2)/120/,SEXT(3)/116/,SEXT(4)/101/,SEXT(5)/1 *14/,SEXT(6)/110/,SEXT(7)/97/,SEXT(8)/108/,SEXT(9)/0/ DATA SDIM(1)/100/,SDIM(2)/105/,SDIM(3)/109/,SDIM(4)/101/,SDIM(5)/1 *10/,SDIM(6)/115/,SDIM(7)/105/,SDIM(8)/111/,SDIM(9)/110/,SDIM(10)/0 */ DATA SIMPL(1)/105/,SIMPL(2)/109/,SIMPL(3)/112/,SIMPL(4)/108/,SIMPL *(5)/105/,SIMPL(6)/99/,SIMPL(7)/105/,SIMPL(8)/116/,SIMPL(9)/0/ DATA SCOM(1)/99/,SCOM(2)/111/,SCOM(3)/109/,SCOM(4)/109/,SCOM(5)/11 *1/,SCOM(6)/110/,SCOM(7)/0/ DATA SEQU(1)/101/,SEQU(2)/113/,SEQU(3)/117/,SEQU(4)/105/,SEQU(5)/1 *18/,SEQU(6)/97/,SEQU(7)/108/,SEQU(8)/101/,SEQU(9)/110/,SEQU(10)/99 */,SEQU(11)/101/,SEQU(12)/0/ JUNK = ENTER(SPROG, 4, TB) JUNK = ENTER(SSUB, 4, TB) JUNK = ENTER(SBLCK, 10, TB) JUNK = ENTER(SCOM, 6, TB) JUNK = ENTER(SFUNC, 5, TB) JUNK = ENTER(SINT, 5, TB) JUNK = ENTER(SREAL, 5, TB) JUNK = ENTER(SLOG, 5, TB) JUNK = ENTER(SCOMPL, 5, TB) JUNK = ENTER(SCHAR, 5, TB) JUNK = ENTER(SBYTE, 5, TB) JUNK = ENTER(SDIM, 5, TB) JUNK = ENTER(SEXT, 5, TB) JUNK = ENTER(SIMPL, 5, TB) JUNK = ENTER(SEQU, 7, TB) JUNK = ENTER(SDATA, 8, TB) JUNK = ENTER(SDOUBL, 9, TB) JUNK = ENTER(SPREC, 11, TB) JUNK = ENTER(SEND, 2, TB) RETURN END SUBROUTINE KEEPLN(LINE,KIND) BYTE LINE(100) INTEGER LENGTH INTEGER I,J INTEGER KIND BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB BYTE ST001Z(21) BYTE ST002Z(20) BYTE ST003Z(20) COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ST001Z(1)/114/,ST001Z(2)/97/,ST001Z(3)/116/,ST001Z(4)/112/, *ST001Z(5)/50/,ST001Z(6)/32/,ST001Z(7)/115/,ST001Z(8)/101/,ST001Z(9 *)/113/,ST001Z(10)/117/,ST001Z(11)/101/,ST001Z(12)/110/,ST001Z(13)/ *99/,ST001Z(14)/101/,ST001Z(15)/32/,ST001Z(16)/101/,ST001Z(17)/114/ *,ST001Z(18)/114/,ST001Z(19)/111/,ST001Z(20)/114/,ST001Z(21)/0/ DATA ST002Z(1)/116/,ST002Z(2)/111/,ST002Z(3)/111/,ST002Z(4)/32/, *ST002Z(5)/109/,ST002Z(6)/97/,ST002Z(7)/110/,ST002Z(8)/121/,ST002Z( *9)/32/,ST002Z(10)/100/,ST002Z(11)/101/,ST002Z(12)/99/,ST002Z(13)/1 *08/,ST002Z(14)/32/,ST002Z(15)/108/,ST002Z(16)/105/,ST002Z(17)/110/ *,ST002Z(18)/101/,ST002Z(19)/115/,ST002Z(20)/0/ DATA ST003Z(1)/116/,ST003Z(2)/111/,ST003Z(3)/111/,ST003Z(4)/32/, *ST003Z(5)/109/,ST003Z(6)/97/,ST003Z(7)/110/,ST003Z(8)/121/,ST003Z( *9)/32/,ST003Z(10)/100/,ST003Z(11)/101/,ST003Z(12)/99/,ST003Z(13)/1 *08/,ST003Z(14)/32/,ST003Z(15)/99/,ST003Z(16)/104/,ST003Z(17)/97/, *ST003Z(18)/114/,ST003Z(19)/115/,ST003Z(20)/0/ IF (.NOT.(KIND .EQ. 12))GOTO 23033 CALL ERROR(ST001Z) 23033 CONTINUE IF (.NOT.(NEXTP .EQ. 500))GOTO 23035 CALL ERROR(ST002Z) 23035 CONTINUE TYPE(NEXTP) = KIND I = PTR(NEXTP) J = LENGTH(LINE) IF (.NOT.(I+J .GE. 10000))GOTO 23037 CALL ERROR(ST003Z) 23037 CONTINUE CALL SCOPY(LINE,1,BUF,I) NEXTP = NEXTP + 1 PTR(NEXTP) = I+J+1 RETURN END SUBROUTINE SFLUSH(FD) INTEGER FD,J,P INTEGER I,KIND, ORD(10) BYTE BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ORD(1)/4/, ORD(2)/5/, ORD(3)/6/, ORD(4)/7/, ORD(5)/8/, ORD(6) */3/, ORD(7)/2/, ORD(8)/12/ I=1 23039 IF (.NOT.(ORD(I) .NE. 12))GOTO 23041 KIND = ORD(I) P=1 23042 IF (.NOT.(P.LT.NEXTP))GOTO 23044 IF (.NOT.(TYPE(P) .EQ. KIND))GOTO 23045 J = PTR(P) CALL PUTLIN(BUF(J),FD) 23045 CONTINUE 23043 P=P+1 GOTO 23042 23044 CONTINUE 23040 I=I+1 GOTO 23039 23041 CONTINUE RETURN END #-t- ratp2b4ch.f ascii 01/09/84 15:54 #-h- ratp2bint.f ascii 01/09/84 15:54 CALL INITST CALL RATP2 CALL ENDST(0) END SUBROUTINE RATP2 CALL FSORT (1, 2) RETURN END SUBROUTINE FSORT(IFD,OFD) INTEGER IFD,OFD INTEGER LEN, I INTEGER KIND INTEGER LINE(82) INTEGER GETLIN, LOOKUP, MKTABL INTEGER GCODE INTEGER MEM(500) INTEGER CMEM(500) INTEGER BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /CDSMEM/ MEM COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB EQUIVALENCE (CMEM(1),MEM(1)) CALL DSINIT(500) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 STB = MKTABL (1) CALL INITFS (STB) LEN=GETLIN(LINE,IFD) 23000 IF (.NOT.(LEN.NE.-1))GOTO 23002 I = 1 CALL SKIPBL(LINE, I) IF (.NOT.(LINE(I) .EQ. 10))GOTO 23003 GOTO 23001 23003 CONTINUE IF (.NOT.(LEN.GT.6 .AND. LINE(6).NE. 32 .AND. LINE(6).NE. 48 .AND. * LINE(6).NE. 9))GOTO 23005 GOTO 23006 23005 CONTINUE KIND = GCODE(LINE) 23006 CONTINUE CALL KEEPLN(LINE,KIND) IF (.NOT.(KIND.EQ.2))GOTO 23007 CALL SFLUSH (OFD) NEXTP = 1 PTR(NEXTP) = 1 KIND = 12 23007 CONTINUE 23001 LEN=GETLIN(LINE,IFD) GOTO 23000 23002 CONTINUE IF (.NOT.(NEXTP .GT. 1))GOTO 23009 CALL SFLUSH (OFD) 23009 CONTINUE RETURN END INTEGER FUNCTION FTNTOK(LINE, I, TOKEN) INTEGER LINE(100), TOKEN(100), C INTEGER I, J INTEGER TYPE CALL SKIPBL(LINE, I) J = 1 IF (.NOT.(TYPE(LINE(I)) .EQ. 1))GOTO 23011 23013 CONTINUE TOKEN(J) = LINE(I) J = J + 1 I = I + 1 C = TYPE(LINE(I)) 23014 IF (.NOT.(C .NE. 1 .AND. C .NE. 2 .AND. C .NE. 95))GOTO 23013 23015 CONTINUE 23011 CONTINUE TOKEN(J) = 0 IF (.NOT.(LINE(I) .EQ. 42))GOTO 23016 23018 CONTINUE I = I + 1 23019 IF (.NOT.(TYPE(LINE(I)) .NE. 2))GOTO 23018 23020 CONTINUE 23016 CONTINUE CALL FOLD(TOKEN) FTNTOK=(J - 1) RETURN END INTEGER FUNCTION GCODE(LINE) INTEGER LINE(100), WORD(82) INTEGER I, LEN, CODE INTEGER LOOKUP, FTNTOK INTEGER TMP INTEGER BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB I = 1 IF (.NOT.(FTNTOK(LINE, I, WORD) .EQ. 0))GOTO 23021 GCODE=(3) RETURN 23021 CONTINUE IF (.NOT.(LOOKUP(WORD, CODE, STB) .EQ. 0))GOTO 23023 GCODE=(3) RETURN 23023 CONTINUE IF (.NOT.(CODE.EQ.10 .OR. CODE.EQ.9))GOTO 23025 TMP = CODE LEN = FTNTOK(LINE,I,WORD) IF (.NOT.(LOOKUP(WORD,CODE, STB) .EQ. 0))GOTO 23027 GCODE=(3) RETURN 23027 CONTINUE IF (.NOT.(TMP.EQ.10 .AND. CODE.EQ.8))GOTO 23029 GCODE=(4) RETURN 23029 CONTINUE IF (.NOT.(TMP.EQ.9 .AND. CODE.EQ.11))GOTO 23031 GCODE=(5) RETURN 23031 CONTINUE GCODE=(3) RETURN 23032 CONTINUE 23030 CONTINUE GOTO 23026 23025 CONTINUE GCODE=(CODE) RETURN 23026 CONTINUE GCODE=(3) RETURN END SUBROUTINE INITFS (TB) INTEGER TB INTEGER JUNK INTEGER ENTER INTEGER SEND(4) INTEGER SPROG(8) INTEGER SSUB(11) INTEGER SFUNC(9) INTEGER SBLCK(6) INTEGER SDATA(5) INTEGER SINT(8) INTEGER SREAL(5) INTEGER SDOUBL(7) INTEGER SPREC(10) INTEGER SLOG(8) INTEGER SCOMPL(8) INTEGER SCHAR(10) INTEGER SBYTE(5) INTEGER SEXT(9) INTEGER SDIM(10) INTEGER SIMPL(9) INTEGER SCOM(7) INTEGER SEQU(12) DATA SEND(1)/101/,SEND(2)/110/,SEND(3)/100/,SEND(4)/0/ DATA SPROG(1)/112/,SPROG(2)/114/,SPROG(3)/111/,SPROG(4)/103/,SPROG *(5)/114/,SPROG(6)/97/,SPROG(7)/109/,SPROG(8)/0/ DATA SSUB(1)/115/,SSUB(2)/117/,SSUB(3)/98/,SSUB(4)/114/,SSUB(5)/11 *1/,SSUB(6)/117/,SSUB(7)/116/,SSUB(8)/105/,SSUB(9)/110/,SSUB(10)/10 *1/,SSUB(11)/0/ DATA SFUNC(1)/102/,SFUNC(2)/117/,SFUNC(3)/110/,SFUNC(4)/99/,SFUNC( *5)/116/,SFUNC(6)/105/,SFUNC(7)/111/,SFUNC(8)/110/,SFUNC(9)/0/ DATA SBLCK(1)/98/,SBLCK(2)/108/,SBLCK(3)/111/,SBLCK(4)/99/,SBLCK(5 *)/107/,SBLCK(6)/0/ DATA SDATA(1)/100/,SDATA(2)/97/,SDATA(3)/116/,SDATA(4)/97/,SDATA(5 *)/0/ DATA SINT(1)/105/,SINT(2)/110/,SINT(3)/116/,SINT(4)/101/,SINT(5)/1 *03/,SINT(6)/101/,SINT(7)/114/,SINT(8)/0/ DATA SREAL(1)/114/,SREAL(2)/101/,SREAL(3)/97/,SREAL(4)/108/,SREAL( *5)/0/ DATA SDOUBL(1)/100/,SDOUBL(2)/111/,SDOUBL(3)/117/,SDOUBL(4)/98/, *SDOUBL(5)/108/,SDOUBL(6)/101/,SDOUBL(7)/0/ DATA SPREC(1)/112/,SPREC(2)/114/,SPREC(3)/101/,SPREC(4)/99/,SPREC( *5)/105/,SPREC(6)/115/,SPREC(7)/105/,SPREC(8)/111/,SPREC(9)/110/, *SPREC(10)/0/ DATA SLOG(1)/108/,SLOG(2)/111/,SLOG(3)/103/,SLOG(4)/105/,SLOG(5)/9 *9/,SLOG(6)/97/,SLOG(7)/108/,SLOG(8)/0/ DATA SCOMPL(1)/99/,SCOMPL(2)/111/,SCOMPL(3)/109/,SCOMPL(4)/112/, *SCOMPL(5)/108/,SCOMPL(6)/101/,SCOMPL(7)/120/,SCOMPL(8)/0/ DATA SCHAR(1)/99/,SCHAR(2)/104/,SCHAR(3)/97/,SCHAR(4)/114/,SCHAR(5 *)/97/,SCHAR(6)/99/,SCHAR(7)/116/,SCHAR(8)/101/,SCHAR(9)/114/,SCHAR *(10)/0/ DATA SBYTE(1)/98/,SBYTE(2)/121/,SBYTE(3)/116/,SBYTE(4)/101/,SBYTE( *5)/0/ DATA SEXT(1)/101/,SEXT(2)/120/,SEXT(3)/116/,SEXT(4)/101/,SEXT(5)/1 *14/,SEXT(6)/110/,SEXT(7)/97/,SEXT(8)/108/,SEXT(9)/0/ DATA SDIM(1)/100/,SDIM(2)/105/,SDIM(3)/109/,SDIM(4)/101/,SDIM(5)/1 *10/,SDIM(6)/115/,SDIM(7)/105/,SDIM(8)/111/,SDIM(9)/110/,SDIM(10)/0 */ DATA SIMPL(1)/105/,SIMPL(2)/109/,SIMPL(3)/112/,SIMPL(4)/108/,SIMPL *(5)/105/,SIMPL(6)/99/,SIMPL(7)/105/,SIMPL(8)/116/,SIMPL(9)/0/ DATA SCOM(1)/99/,SCOM(2)/111/,SCOM(3)/109/,SCOM(4)/109/,SCOM(5)/11 *1/,SCOM(6)/110/,SCOM(7)/0/ DATA SEQU(1)/101/,SEQU(2)/113/,SEQU(3)/117/,SEQU(4)/105/,SEQU(5)/1 *18/,SEQU(6)/97/,SEQU(7)/108/,SEQU(8)/101/,SEQU(9)/110/,SEQU(10)/99 */,SEQU(11)/101/,SEQU(12)/0/ JUNK = ENTER(SPROG, 4, TB) JUNK = ENTER(SSUB, 4, TB) JUNK = ENTER(SBLCK, 10, TB) JUNK = ENTER(SCOM, 6, TB) JUNK = ENTER(SFUNC, 5, TB) JUNK = ENTER(SINT, 5, TB) JUNK = ENTER(SREAL, 5, TB) JUNK = ENTER(SLOG, 5, TB) JUNK = ENTER(SCOMPL, 5, TB) JUNK = ENTER(SCHAR, 5, TB) JUNK = ENTER(SBYTE, 5, TB) JUNK = ENTER(SDIM, 5, TB) JUNK = ENTER(SEXT, 5, TB) JUNK = ENTER(SIMPL, 5, TB) JUNK = ENTER(SEQU, 7, TB) JUNK = ENTER(SDATA, 8, TB) JUNK = ENTER(SDOUBL, 9, TB) JUNK = ENTER(SPREC, 11, TB) JUNK = ENTER(SEND, 2, TB) RETURN END SUBROUTINE KEEPLN(LINE,KIND) INTEGER LINE(100) INTEGER LENGTH INTEGER I,J INTEGER KIND INTEGER BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB INTEGER ST001Z(21) INTEGER ST002Z(20) INTEGER ST003Z(20) COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ST001Z(1)/114/,ST001Z(2)/97/,ST001Z(3)/116/,ST001Z(4)/112/, *ST001Z(5)/50/,ST001Z(6)/32/,ST001Z(7)/115/,ST001Z(8)/101/,ST001Z(9 *)/113/,ST001Z(10)/117/,ST001Z(11)/101/,ST001Z(12)/110/,ST001Z(13)/ *99/,ST001Z(14)/101/,ST001Z(15)/32/,ST001Z(16)/101/,ST001Z(17)/114/ *,ST001Z(18)/114/,ST001Z(19)/111/,ST001Z(20)/114/,ST001Z(21)/0/ DATA ST002Z(1)/116/,ST002Z(2)/111/,ST002Z(3)/111/,ST002Z(4)/32/, *ST002Z(5)/109/,ST002Z(6)/97/,ST002Z(7)/110/,ST002Z(8)/121/,ST002Z( *9)/32/,ST002Z(10)/100/,ST002Z(11)/101/,ST002Z(12)/99/,ST002Z(13)/1 *08/,ST002Z(14)/32/,ST002Z(15)/108/,ST002Z(16)/105/,ST002Z(17)/110/ *,ST002Z(18)/101/,ST002Z(19)/115/,ST002Z(20)/0/ DATA ST003Z(1)/116/,ST003Z(2)/111/,ST003Z(3)/111/,ST003Z(4)/32/, *ST003Z(5)/109/,ST003Z(6)/97/,ST003Z(7)/110/,ST003Z(8)/121/,ST003Z( *9)/32/,ST003Z(10)/100/,ST003Z(11)/101/,ST003Z(12)/99/,ST003Z(13)/1 *08/,ST003Z(14)/32/,ST003Z(15)/99/,ST003Z(16)/104/,ST003Z(17)/97/, *ST003Z(18)/114/,ST003Z(19)/115/,ST003Z(20)/0/ IF (.NOT.(KIND .EQ. 12))GOTO 23033 CALL ERROR(ST001Z) 23033 CONTINUE IF (.NOT.(NEXTP .EQ. 500))GOTO 23035 CALL ERROR(ST002Z) 23035 CONTINUE TYPE(NEXTP) = KIND I = PTR(NEXTP) J = LENGTH(LINE) IF (.NOT.(I+J .GE. 10000))GOTO 23037 CALL ERROR(ST003Z) 23037 CONTINUE CALL SCOPY(LINE,1,BUF,I) NEXTP = NEXTP + 1 PTR(NEXTP) = I+J+1 RETURN END SUBROUTINE SFLUSH(FD) INTEGER FD,J,P INTEGER I,KIND, ORD(10) INTEGER BUF INTEGER PTR INTEGER TYPE INTEGER NEXTP INTEGER STB COMMON /RATP2C/ BUF(10000),PTR(500),TYPE(500), NEXTP, STB DATA ORD(1)/4/, ORD(2)/5/, ORD(3)/6/, ORD(4)/7/, ORD(5)/8/, ORD(6) */3/, ORD(7)/2/, ORD(8)/12/ I=1 23039 IF (.NOT.(ORD(I) .NE. 12))GOTO 23041 KIND = ORD(I) P=1 23042 IF (.NOT.(P.LT.NEXTP))GOTO 23044 IF (.NOT.(TYPE(P) .EQ. KIND))GOTO 23045 J = PTR(P) CALL PUTLIN(BUF(J),FD) 23045 CONTINUE 23043 P=P+1 GOTO 23042 23044 CONTINUE 23040 I=I+1 GOTO 23039 23041 CONTINUE RETURN END #-t- ratp2bint.f ascii 01/09/84 15:54 #-h- ratp2sym.rat ascii 01/09/84 15:54 #-h- defns 627 asc 24-dec-83 08:45:38 sventek (joseph sventek [lbl/csam]) # # If you are generating the bootstrap version of ratp2, you must # uncomment the following line # #define(DO_BOOTSTRAP,) # define(HEAD,1) define(END,2) define(BODY,3) define(PROG,4) define(TYPE,5) define(COMN,6) define(EQUI,7) define(DAT,8) define(DOUBLE,9) define(BLOCK,10) define(PRECISION,11) define(WRONG,12) define(MAXNAMES,10) define(A_S_X,1) define(MAXBUF,arith(A_S_X,*,20000)) define(MAXSAVE,arith(A_S_X,*,1000)) define(Mem_size,500) #-h- main 454 asc 24-dec-83 08:45:39 sventek (joseph sventek [lbl/csam]) DRIVER(ratp2) integer getarg, open integer i, fd character buf(FILENAMESIZE) call query ("usage: ratp2 [files] ...") for (i=1; getarg(i, buf, FILENAMESIZE) != EOF; i=i+1) { if (buf(1) == MINUS & buf(2) == EOS) fd = STDIN else fd = open(buf, READ) if (fd == ERR) call cant (buf) call fsort (fd, STDOUT) if (fd != STDIN) call close (fd) } if (i == 1) # no files given call fsort (STDIN, STDOUT) DRETURN end #-h- fsort 745 asc 24-dec-83 08:45:40 sventek (joseph sventek [lbl/csam]) subroutine fsort(ifd,ofd) integer ifd,ofd integer len, i integer kind character line(MAXLINE) integer getlin, lookup, mktabl integer gcode DS_DECL(Mem,Mem_size) #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb call dsinit(Mem_size) nextp = 1 ptr(nextp) = 1 kind = WRONG stb = mktabl (1) call initfs (stb) for(len=getlin(line,ifd);len!=EOF;len=getlin(line,ifd)) { i = 1 call skipbl(line, i) if (line(i) == NEWLINE) # line is blank next; if (len>6 & line(6)!= BLANK & line(6)!= DIG0 & line(6)!= TAB) { # continuation line # kind = kind } else kind = gcode(line) call keepln(line,kind) if (kind==END) { call sflush (ofd) nextp = 1 ptr(nextp) = 1 kind = WRONG } } if (nextp > 1) # flush accumulated stuff call sflush (ofd) return end #-h- ftntok 806 asc 24-dec-83 08:45:41 sventek (joseph sventek [lbl/csam]) # ftntok - routine to return next FORTRAN token in `token', incrementing # `i'. The token is folded to lower case and the length is # returned as the function value integer function ftntok(line, i, token) character line(ARB), token(ARB), c integer i, j character type call skipbl(line, i) # skip leading blanks and tabs j = 1 if (type(line(i)) == LETTER) # get token if starts with alpha repeat { token(j) = line(i) j = j + 1 i = i + 1 c = type(line(i)) } until (c != LETTER & c != DIGIT & c != UNDERLINE) token(j) = EOS if (line(i) == STAR) # handle type*N declarations repeat i = i + 1 until (type(line(i)) != DIGIT) # skip to first non-digit call fold(token) # lower case for future comparisons return(j - 1) # return length end #-h- gcode 563 asc 24-dec-83 08:45:42 sventek (joseph sventek [lbl/csam]) integer function gcode(line) character line(ARB), word(MAXLINE) integer i, len, code integer lookup, ftntok integer tmp #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb i = 1 if (ftntok(line, i, word) == 0) return(BODY) if (lookup(word, code, stb) == NO) return(BODY) if (code==BLOCK | code==DOUBLE) { tmp = code len = ftntok(line,i,word) if (lookup(word,code, stb) == NO) return(BODY) if (tmp==BLOCK & code==DAT) return(PROG) else if(tmp==DOUBLE & code==PRECISION) return(TYPE) else return(BODY) } else return(code) return(BODY) # no path here but supress message end #-h- initfs 1100 asc 24-dec-83 08:45:43 sventek (joseph sventek [lbl/csam]) subroutine initfs (tb) integer tb # symbol table pointer integer junk integer enter string send "end" string sprog "program" string ssub "subroutine" string sfunc "function" string sblck "block" string sdata "data" string sint "integer" string sreal "real" string sdoubl "double" string sprec "precision" string slog "logical" string scompl "complex" string schar "character" string sbyte "byte" string sext "external" string sdim "dimension" string simpl "implicit" string scom "common" string sequ "equivalence" junk = enter(sprog, PROG, tb) junk = enter(ssub, PROG, tb) junk = enter(sblck, BLOCK, tb) junk = enter(scom, COMN, tb) junk = enter(sfunc, TYPE, tb) junk = enter(sint, TYPE, tb) junk = enter(sreal, TYPE, tb) junk = enter(slog, TYPE, tb) junk = enter(scompl, TYPE, tb) junk = enter(schar, TYPE, tb) junk = enter(sbyte, TYPE, tb) junk = enter(sdim, TYPE, tb) junk = enter(sext, TYPE, tb) junk = enter(simpl, TYPE, tb) junk = enter(sequ, EQUI, tb) junk = enter(sdata, DAT, tb) junk = enter(sdoubl, DOUBLE, tb) junk = enter(sprec, PRECISION, tb) junk = enter(send, END, tb) return end #-h- keepln 396 asc 24-dec-83 08:45:44 sventek (joseph sventek [lbl/csam]) subroutine keepln(line,kind) character line(ARB) integer length integer i,j integer kind #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb if (kind == WRONG) call error("ratp2 sequence error") if (nextp == MAXSAVE) call error("too many decl lines") type(nextp) = kind i = ptr(nextp) j = length(line) if (i+j >= MAXBUF) call error("too many decl chars") call scopy(line,1,buf,i) nextp = nextp + 1 ptr(nextp) = i+j+1 return end #-h- sflush 421 asc 24-dec-83 08:45:45 sventek (joseph sventek [lbl/csam]) subroutine sflush(fd) integer fd,j,p integer i,kind, ord(MAXNAMES) #common for ratp2 character buf # line hold buffer integer ptr # index of starts of lines integer type # kind of each line integer nextp # next line pos pointer integer stb # symbol table pointer common /ratp2c/ buf(MAXBUF),ptr(MAXSAVE),type(MAXSAVE), nextp, stb data ord(1)/PROG/, ord(2)/TYPE/, ord(3)/COMN/, ord(4)/EQUI/, ord(5)/DAT/, ord(6)/BODY/, ord(7)/END/, ord(8)/WRONG/ for (i=1; ord(i) != WRONG; i=i+1) # step thru kinds { kind = ord(i) for (p=1; p 0) if (buf(i) == '@n') return call putch('@n', ERROUT) return end #-t- remark local 10-may-83 11:11:58 #-t- remark.rat ascii 01/09/84 15:54 #-h- remark2ch.f ascii 01/09/84 15:54 SUBROUTINE REMARK(BUF) BYTE BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END #-t- remark2ch.f ascii 01/09/84 15:54 #-h- remark4ch.f ascii 01/09/84 15:54 SUBROUTINE REMARK(BUF) BYTE BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END #-t- remark4ch.f ascii 01/09/84 15:54 #-h- remarkint.f ascii 01/09/84 15:54 SUBROUTINE REMARK(BUF) INTEGER BUF(100) INTEGER I I = 1 23000 IF (.NOT.(BUF(I) .NE. 0))GOTO 23002 23001 I = I + 1 GOTO 23000 23002 CONTINUE I = I - 1 CALL PUTLIN(BUF, 3) IF (.NOT.(I .GT. 0))GOTO 23003 IF (.NOT.(BUF(I) .EQ. 10))GOTO 23005 RETURN 23005 CONTINUE 23003 CONTINUE CALL PUTCH(10, 3) RETURN END #-t- remarkint.f ascii 01/09/84 15:54 #-h- remarksym.rat ascii 01/09/84 15:54 #-h- remark local 10-may-83 11:11:58 subroutine remark(buf) character buf(ARB) integer i for (i = 1; buf(i) != EOS; i = i + 1) ; i = i - 1 call putlin(buf, ERROUT) if (i > 0) if (buf(i) == NEWLINE) return call putch(NEWLINE, ERROUT) return end #-t- remark local 10-may-83 11:11:58 #-t- remarksym.rat ascii 01/09/84 15:54