Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume8/prep/part01

Internet Message Format | 1987-03-01 | 59.2 KB

Subject:  v08i090:  A pre-processor for FORTRAN source, Part01/02
Newsgroups: mod.sources
Approved: mirror!rs

Submitted by: cmcl2!bullwinkle!batcomputer!prove (Roger Ove)
Mod.sources: Volume 8, Issue 90
Archive-name: prep/Part01

[  Different from RATFOR in some interesting aways, especially the
   parellelizing constructs, if that's a word.  --r$  ]

Mod.sources submission:
     This is part 1 of 2  of a preprocessor for fortran, which
supports macros, flow control extensions, vector statement
shorthand, and automatic loop unrolling for certain classes of
loops.  It is written in generic c and will run on nearly any
machine: ibmpc, Sun, CrayXMP, Definicon dsi20.

-----CUT-----HERE-----
# This is a shell archive.  Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
# Contents:  prep.doc Makefile makemsc prep.c macro.c vec.c str.c

echo x - prep.doc
sed 's/^@//' > "prep.doc" <<'@//E*O*F prep.doc//'
                             PREP v. 2.0

                    Copyright (C) 1985,1986 P.R.Ove
                          All rights reserved.

     Suggestions and comments regarding this program are welcome,
preferably in the form of code segments.  I will make an effort to
incorporate any suggestions that are deemed worthy and maintain an
"official" version of this program on the net.  At the moment comments
should be directed to [e-mail] (or equivalently 14004@
ncsaa.cso.uiuc.edu), or [e-mail], or
[e-mail].



Introduction

     This documentation describes the use of PREP, a preprocessor for
fortran.  As an alternative to ratfor, PREP offers some distinct advantages.
These include full macro facilities and a concise shorthand for array
and vector statements.  In addition, all of the standard flow control
constructs of forth are supported.  Some attempts have been made to
avoid ratfor syntax to that both preprocessors can be used, but this
has never been checked fully.  It is probably possible to emulate much of
ratfor's syntax using PREP's macro processor to modify the flow control
commands.  PREP is written is generic c and will run on nearly any
machine/compiler combination.  Currently it runs on IBM pc's and
compatibles, unix machines, the Definicon dsi20 68020 parasite card in
an IBM PC compatible machine, and the Cray XMP.
     PREP does not do everything, and in particular does not offer any
help with the deficiency of data structures in fortran.  It also does not
understand fortran, and will quite happily produce nonsense code if so
instructed.  It will detect errors in its own syntax, but errors in
fortran will be left for the compiler.  Therefore debugging will
unfortunately involve looking at the fortran output, which can be quite
ugly.  These problems are shared with ratfor.
     The vector statement notation makes it possible to incorporate do
loop unrolling automatically to any depth, which for certain classes of
loops on certain machines (memory bound loops on vector machines) will
improve performance.  On the Cray XMP performance for certain loops
was increased from the normal 50 Mflops to a maximum of 80 Mflops when
unrolled to a depth of 16.  On machines with many parallel paths to
memory there may also be situations where this is advantageous.
     Although the syntax is similar to forth, the spirit of forth is
totally absent.  The macros are really macros, not colon definitions,
and recursive macro definitions will cause an error during expansion.
Postfix notation would only cause confusion, being in conflict with
fortran conventions, and is not used.
    The macro processor can be considered a pre-preprocessor.  The
order of translation is:

    1) file inclusion
    2) macro processing
    3) flow control extensions
    4) vector statements

Note that because of this the flow control syntax can be modified
at the macro level.  Although this order of translation holds
rigorously, PREP is a one pass processor and makes no temporary
files.
     Macro definitions can be imbedded in the program file or in
files that can later be included.  Some common definitions mapping
certain symbols ( &, <=, !=, etc ) to their fortran equivalents ( .and.,
@.le., .ne., etc ) are stored in the file prepmac.h.  These can be made
active by placing the statement ' #include "prepmac.h" ' in the program
file, or by using the -i switch from the command line.
    The nesting limit for all loops is defined by an internal constant
NESTING, which is set to a number like 10 or 20 (implementation
dependent).  The flow control directives are permitted inside vector
loops, but since they will inhibit Cray vectorization of those loops it
may be best to avoid this.  One of the reasons for using the vector
shorthand is that it encourages programming in a style that can be
easily vectorized by the compiler.
    This program attempts to avoid all fixed limits on data structures,
and instead allocates memory when needed.  The flow control directives
do not adhere to this philosophy, since the maximum expansion length
can be determined in advance and processing is faster without continual
reallocation of memory.  Fairly robust memory management is used by the
macro processor and input routines (there is no source line length limit
other than any limitations imposed by the system).  Recursive macro
definitions are accepted during the definition phase, but will cause an
error during expansion.  When a macro is expanded more than the limit
(100 or so per line, but implementation dependent) the program will abort
with a recursion error message, but it is conceivable (if the memory of
the machine is small and the macro definitions are very long) that a
memory allocation error will occur before this.
    In most cases the flow control directives must be the first word
on the line (PREP is line oriented like fortran and unlike c).  The
only exception is that directives and fortran code can be on the same
line after an OF statement.  Any delimiters (){}[]'" may be used in the
logical expressions ( i.e.  leave [ i == 1 ] ).  Macro definitions
must use () for the parameter block however (to allow macro names
containing the character {, for instance), and macro names cannot contain
the open parens or whitespace characters.


Running PREP

     The command line interface and program function is identical
regardless of the machine (so far).  The syntax is

prep -x -x .... <file>

where file is the first name of the file and the extension is assumed
to be P.  The output file will have the extension F.  x represents
a command line option:

 Switches:
   -c        keep comments (truncated at column 72)
   -u        keep underline characters
   -m        only do macro substitution (==> -c and -u as well, and
        prevents file includes (except -i switch).
   -i    <file>    include <file> before processing
   -U n        unroll vector loops to depth n
   -L n        unroll loops with n or fewer lines
   -?        write message about allowed switches

     If no file is present standard input and output are used.  The -i
switch requires the full path name of the include file.
     Normally underline characters and comment records are eliminated
unless overridden with a switch.  Quoted underlines (the fortran quote
character is the apostrophe) are never deleted.  In general quoted
characters are safe from PREP, as is text in comment records.
     The -m switch is useful for converting existing programs to PREP
format.  It turns off all PREP functions except macro substitution.  To
partially convert a fortran program, enter:

prep -m -i fix.h <prog.f >prog.p

The file fix.h contains the inverse definitions of prepmac.h.  A side
effect of PREP on DOS machines is that the terminating control-z is
removed, which is useful if the fortran code is to be transferred to
another machine.  Running the above command without the -i switch and
without any internal macro definitions, it will do nothing but remove the
control-z.
     If the argument for -U is omitted the default is 8.  If -U is not
present then unrolling will not be done at all unless turned on by an
internal directive.  The command line switch will not override imbedded
unrolling commands.  If -L is omitted the default is 1000, while if the
argument is omitted the default is 1.
     Versions for Intel 80*** based machines come compiled for small
and large memory models.  The large model version is quite large
itself.  It is only necessary to use the large model if the memory
is needed for many very long macro definitions, which are memory resident.
If you have a memory allocation error with the small version try the
other.  The large one is called bigprep.exe.  Since I am now distributing
the source you can do what your want.




Summary of Features

    The extensions can be broken up into four classes: 1) including
files, 2) macro definition/expansion, 3) flow control directives, and
4) vector notation.  These will be discussed in this order, which is
also the order in which they are processed.



Included files
  example:
  #include "prepmac.h"

     Normally fortran incudes files with the directive "include".
Incidentally, using cft and precomp on a cray, files are included with
"use" so if you are using a cray you may find it convenient to define
"include" equivalent to "use" with
    : include(x)    use x ;
so that "include 'file'" will be translated to "use file".  Prep will
include a file if it finds an include directive ( #include "file" )
in the source, or if the -i switch is used from the command line.  Included
files can be nested 10 deep.  Only the current directory is searched,
and PREP will terminate if the file is not found.  To include a file in
another directory the full pathname must be used.


Macros
     The style is similar to that of c #define macros, except
that : is used instead of #define and ; terminates the macro.  No
special character is needed to continue to the next line.  Non-c syntax
is used to allow both PREP macros and c preprocessor macros in the
same program.
     Recursive definitions are permitted, but will cause an abort
(and possibly a memory allocation error) on expansion.  For each
line submitted to expand_macros, a count of is kept for each
stored macro indicating how many times it has been expanded in
the current line.  When this exceeds MAX_CALLS, the program
assumes a macro definition is recursive and stops.  Macros
are expanded starting with the one with the longest name, so that
if the definitions

   : >=        .ge. ;
   : >        .gt. ;

are in effect, >= will be changed to .ge. rather than .gt.=.  This
is only a potential problem when macro names are not fully
alphanumeric, since "arg" will not be flagged if "r" is defined.
The underline character is considered non-alphanumeric here, for
no good reason and perhaps it should not be.

     The definition phase is invoked when a leading : is found in
the record.  Text is then taken until the terminating ; is found.  Text
following the ; is ignored (until the next newline).  Multi-line macros
are permitted: they will be converted to at least as many lines in the
fortran program.  The general form of a macro definition is:

   : name( parm1, parm2, ... )    text with parameters
                more text with parameters
                 "    "    "    "    ;

with 20 as the maximum number of parameters.  There must be no space
between the macro name and the open delimiter of the parameter block in
a definition, and the delimiters (if present) must be ().  Macro names
can not contain the open parens.  Examples of macros with more than
one line are:

   : }
    end do ;
   : {
    ;

These will allow translation of ratfor style do loops:

    do i = 1, 10 { write(*,*) ' i = ', i }

is translated into:

    do i = 1, 10
    write(*,*) ' i = ', i
    end do

which will be translated into fortran during the flow control processing.
Note that this example relies on the fact the whitespace between the
macro definition and its terminating ; is significant (newline is not
considered whitespace here).  This is not the case for whitespace between
the name and the definition.  Failure to have a terminating ; will define
the entire program to be a macro.  This could cause a memory allocation
failure, as macros are stored in memory.
     While in a definition the open parens must follow the name without
whitespace, in the source code this requirement (and the need to use only
() as delimiters) is relaxed.  Alphanumeric macros must be not be next to
an alpha or number character or they will not be recognized.
     The macro definition routine puts the macro string into a more easily
handled format, replacing parameters in the text with n, where n is a
binary value (128 to 128+MAX_TOKENS).  The macro is placed in a structure
of the form:

struct mac {
    char *name ;        macro id tag
    char *text ;        encoded macro text
    int  parmcount ;    number of arguments
    int  callcount ;    recursion check
} macro[MAX_MACROS] ;

where the text string has binary symbols where the parms were.  Parmcount
is used to see if a parameter block should be searched for when expanding
a macro.  Callcount is used to stop expansion in case of recursive definitions.
     Caution must be exercised to avoid accidental recursive definitions
involving more than one macro:

    : h    i+x ;
    : i(y)    func(y) ;
    : func    h ;

This will generate the successive strings (from a = func(x)):

    a = h(x)
    a = i+x(x)
    a = func()+x(x)
    a = h()+x(x) .... and so on.  Beware.

     Macro names will not be flagged if they are quoted (with apostrophes)
in the source, or if they are in comment records.
     If more parameters are found than were present in the definition, the
trailers are ignored.  If fewer are found they will be inserted where
expected only (the missing parameters will be taken to be null strings).
Parameters are separated by commas, and are only recognized if they are
balanced according to delimiters.  If : MACRO(a,b) a + b ; is defined
and

    MACRO " [i,j] "

is found in the text, only one parameter will be found and it will be
expanded as:

    [i,j] +

It is not possible to have unbalanced delimiters in a parameter of a
macro unless the macro only has one argument.



Flow Control Extensions
     These commands are based on the flow control of forth (except for
the do/end_do construct).  With the exception of the OF and DEFAULT
commands, no other text is allowed on the line.  If trailing text is
present it is ignored, leading text will prevent PREP from seeing the
command.  This includes labels: PREP command lines may not have labels
unless macros are used to define labels to expand as continue statements
and newlines.  The commands end_case, end_do, and leave_do can have a
space instead of the underline, but the space is significant.  Of course
a macro could be defined as    : enddo end_do ;.  Unlike some other
languages (forth and c) where CONTINUE applies to all types of loops,
here there are three CONTINUE statements (continue, continue_do, and
continue_case) which apply to the three classes of loops supported by
PREP.  This avoids some confusion in certain situations with nested
loops of differing types.  In general for the flow control extensions,
if optional expressions are omitted they are taken to be TRUE.


 Forth style begin/while/until/again construct:
     begin ... again
     begin ... while (exp1) ... again
     begin ... until (exp1)
     leave (optional expression) to exit current level
     continue (optional expression) to got back to begin

     Here the ...'s represent lines of PREP and fortran code, not on
the same line with the directives.  A working example of one of these
is:
     begin
        line of code
     while ( SOME_MACRO[i] )   ; the macro evaluates to a logical expression
        line of code
        line of code
     again

The begin ... again construct will loop forever.  Usually it will have a
leave command inside ( leave [ EOF ], where EOF is a macro ), or a
return to caller.  These (as with the case construct and do/end_do) may
be nested ten levels deep.  The begin is always necessary, even it the
next statement is while.


 Case construct:
     case ( optional exp )
     of   ( exp2 )  line of code
                    line of code
                    continue_case ( optional logical exp )
     of   ( exp3 )  line of code
     default        line of code
                    line of code
     end_case

     This is processed by converting to if else endif expressions.  It is
somewhat clearer in general.  The expressions here must NOT be logical
(.eq. is used), unless CASE is followed by no parameter in which case
the OF expressions MUST be logical expressions.  Unfortunately fortran
does not allow comparisons between logical expressions using .eq., so
there is no way around this dilemma without having the preprocessor
understand fortran to determine variable types (which in turn would
require that all fortran include directives be processed).  Of course
if the value is logical there is not much sense in using the case
construct instead of and ordinary if/else/endif.  An example of a
case construct is

     c = getchar()    ; function that returns a character value
     case ( c )
     of ( 'q' )   call exit
     of ( 'd' )   call dump
                  continue_case ( not_done )
     default      write(*,*) 'illegal character, try again'
                  continue_case
     end_case

In this example the continue statements pass control back to the case, so
getchar is not reevaluated.  If getchar() were put in the case expression
however, it would be evaluated for each OF statement as

     if ( 'q' .eq. getchar() ) etc

which is probably not what was intended.  Therefore, continue_case is rather
useless here unless the value of variable c is changed by the OF clause.
The example will write indefinitely if any character other than q or d
is entered.  The right way to do this is by switching the 1st 2 lines:

     case ( c )
     c = getchar()    ; function that returns a character value
     of ( 'q' )   call exit
           ...
           ...
     end_case

This will evaluate the function getchar on entry and once every time
continue_case is encountered.  An example which uses logical expressions is

     case
     c = getchar()
     of ( 'q' == c ) call exit
           ...
     end case

The nesting limit for case constructs is again 10.  If continue_case
is too long a command name, it can always be abbreviated with a macro
definition (in prepmac.h the definition ": ->case continue_case ;" does
this).



 do ... end_do

     The syntax here is like that of vms fortran, except for the leave_do
which jumps out of the loop if the logical expression is true, and
continue_do which jumps to the end_do and continues the loop.  An
example:

     do i = 1, 10
    line of code
     continue do ( i == 2 )    ; goes to end_do if true
    line of code
    line of code
     leave do ( i*j == 4 )    ; exits loop if true
    line of code
     end do

The leave_do and continue_do commands cannot be used in normal labeled
do loops.  If the logical expressions are omitted they are assumed
true.




Vector Arithmetic
     When writing large number crunching programs in fortran it often
happens that there are a large number of arrays with the same dimensions.
More than likely the loop parameters will be the same for many loops,
and even a simple routine may be rather long and difficult to read
because of all the excess baggage.  It is therefore helpful to have
a shorthand method for writing loops that use common loop parameters.
     A few examples of the shorthand supported by PREP follow.

    a(#,#) = b(#,#) + 1

This has the obvious meaning that all of the elements of array a are
set equal to those of b incremented by 1.  Assuming the appropriate
default loop parameters have been set, this will be expanded as

    do 10001 i001 = 1, my
    do 10000 i000 = 1, mx
    a(i000,i001) = b(i000,i001) + 1
10000    continue
10001    continue

The labels will be generated uniquely.  The variables i000 -> i009 are
reserved for this purpose.  PREP assumes that the usual fortran
conventions hold and that variables beginning with i are integers.
In fortran the first index of an array changes the most rapidly as
one proceeds through the memory, so the loops are always generated
with the innermost loop over the first index.  This is essential for
efficiency on machines with virtual memory (VAX) or those that rely
on sequential addressing for vectorization (Cyber).
     More than one line can be placed in the core of a loop by using
square brackets to group them together.

    c(#,#) = exp( d(#,#) ) + c(#,#)
[    a(#,#) = b(#,#,1)*c(#,#) - 100
    x = y
    d(#,#) = e(#,#)         ]

is expanded as

    do 10001 i001 = 1, my
    do 10000 i000 = 1, mx
    c(i000, i001) = exp( d(i000,i001) ) + c(i000,i001)
10000    continue
10001    continue
    do 10003 i001 = 1, my
    do 10002 i000 = 1, mx
    a(i000,i001) = b(i000,i001,1)*c(i000,i001) - 100
    x = y
    d(i000,i001) = e(i000,i001)
10002    continue
10003    continue

Yes the output can get very ugly, but computers don't care.  PREP will
always continue to the next line if necessary so there is no need
to worry about line length.
    The above loops use default loop limits, and these must be set
with the do_limits command.  The general form is:

do_limits [ (mi, mf, minc), (ni, nf, ninc), .... ]

The number of triples (do i000=mi, mf, minc) determines how many
indices will be looped over.  If a triple has only 2 elements they are
assumed to be the initial value and final value and the increment is
taken to be 1.  If a triple has just one element (parens then not needed)
it is assumed to be the final value and the initial value and increment
are both taken to be 1.  Therefore the above examples could have their
limits set with

do_limits [ mx, my ]

Usually the do_limits statement will be tucked out of the way at the
beginning of the program file or in a PREP #include file.  Again the
underline can be replaced by a blank.
     As a rule the number of # symbols in each array should equal the
number of indices implied by the current default limits.  A common
exception is

    a(#) = a(#) + b(#,#)*c(#,#)

which expands as

    do 10001 i001 = 1, my
    do 10000 i000 = 1, mx
    a(i000) = a(i000) + b(i000,i001)*c(i000,i001)
10000    continue
10001    continue

This does a lot of dot products in parallel on a vector machine like
the Cray.  The compiler will vectorize the inner loop, but is not
smart enough to realize that the vector a should be kept in a vector
register from one outer iteration to the next, and does an unnecessary
save and fetch each time.  Because this loop is memory bound (the
performance is limited by the time it takes to fetch and store the
data rather than the floating point speed of the machine because
there are so few operations in the loop) the performance can be
increased by unrolling the loop.  This is done automatically by PREP
to any depth.  Unrolling this example to a depth of 4 gives

      do 10001 i001=1,int((1.0*(( my )-1+1))/(1*4))*1*4+1-1,1*4
      do 10000 i000 = 1, ( mx), 1
      a(i000) = a(i000) + b(i000,i001)*c(i000,i001)
      a(i000) = a(i000) + b(i000,i001+1*1)*c(i000,i001+1*1)
      a(i000) = a(i000) + b(i000,i001+1*2)*c(i000,i001+1*2)
      a(i000) = a(i000) + b(i000,i001+1*3)*c(i000,i001+1*3)
10000 continue
10001 continue
      do 10003 i001=int((1.0*(( my )-1+1))/(1*4))*1*4+1,( my ),1
      do 10002 i000 = 1, ( mx), 1
      a(i000) = a(i000) + b(i000,i001)*c(i000,i001)
10002 continue
10003 continue

The second set of loops is a clean up operation.  This technique
improves performance because now the compiler will see that the
same vector will be used in the next vector statement and therefore
keeps it in a register.  The example above which is not unrolled runs
at about 50 Mflops.  Unrolling to a depth of 16 results in a speed
of 80 Mflops (when mx=my=100)
     Unrolling can be controlled with the command line switches
mentioned earlier and with the command

unroll ( 8 )

imbedded in the source.  The depth must be explicit of course.
Using the imbedded command individual loops can be controlled
independently.
     Unfortunately, using the same trick on more complicated loops
actually degrades performance, since the loops become too
complicated for the optimizer.  For this reason there is a command
line switch -L n, which inhibits unrolling unless the vector
statement is on n or fewer lines.  Unrolling is always disabled
if the number of indices is not greater than 1, since it would
serve no purpose for 1 index loops on the vector machines for
which it is intended (Unrolling a 1 index loop will inhibit
vectorization).  This should perhaps be a command line option
as well, since scalar machines may derive some benefit for such
loops.
     Loops should never be unrolled unless one is certain that
the result is independent of the order over which the indices are
swept.  Usually if a loop is vectorizable on the Cray and can be
written in this notation, it can be unrolled.  A loop such as

[    a(#,#) = i
    i = i + 1
]

is not vectorizable and if unrolled the result will not be
independent of the unrolling depth.  Low precision calculations may
show differences depending on the depth because of round off errors.
For instance, if sum is a 32 bit real and a is an array of 32 or
64 bit reals with a(i,j)=i+mi*j where the dimensions are large,
the loop

    sum = sum + a(#,#)

may differ in the least significant digits when unrolled.  This is
because when not unrolling (in this example) small numbers have a
chance to add up before being added to large ones.  The unrolled
loops may add small numbers directly to large ones and lose them.
Of course this is just a precision problem and has nothing to do
with the correctness of the algorithm.  Examples could just as
easily be invented where the unrolled version is more accurate.
     Some performance improvements have been noted for scalar
machines.  Parallel processors have not yet been tested but
may allow the most improvement, since the technique will be
of greater assistance if the number of parallel paths to memory
is increased.  In principle each processor could access a local
memory store simultaneously, and unrolling would allow an
optimizing compiler to realize more easily that fetches could
be done in parallel.  PREP allows such matters to be investigated
without the need for a great deal of text editing to unroll
loops by hand.

     However, unrolling do loops is only a small benefit of this
program.  The main reason for using the vector shorthand (and
for using PREP at all) is that using a more intuitively clear
and concise language greatly reduces the time spent making
and correcting mistakes.


     If you have used this program and have any comments or
suggestions, they can be sent via lectric-mail to the addresses
mentioned above.

@//E*O*F prep.doc//
chmod u=rw,g=r,o=r prep.doc

echo x - Makefile
sed 's/^@//' > "Makefile" <<'@//E*O*F Makefile//'
LIBS      =
OBJS     = prep.o flow.o vec.o misc.o str.o

@.SUFFIXES :
@.SUFFIXES : .o .c

prep :: $(OBJS) macro.o
    cc -o prep $(OBJS) macro.o $(LIBS)

@.c.o :
    cc -c -O $*.c

macro.o : macro.c prepdf.h prep.h

$(OBJS) : prep.h prepdf.h

@//E*O*F Makefile//
chmod u=rw,g=r,o=r Makefile

echo x - makemsc
sed 's/^@//' > "makemsc" <<'@//E*O*F makemsc//'
#----------------------------------------------------------------------
#  MAKEFILE for PREP, msc version, (Kneller make)
#-----------------------------------------------------------------------

LINKFLAGS = /stack:10000
LIBS      = c:\lib\\

COBJS     = prep.obj flow.obj vec.obj misc.obj

@.SUFFIXES :
@.SUFFIXES : .exe .obj .c

prep.exe :: $(COBJS) macro.obj
    @link $<, $@, NUL, $(LIBS) $(LINKFLAGS)

@.c.obj :
    msc $* /AS;

$(COBJS) :: prep.h  prepdf.h $*.c

macro.obj :: prep.h prepdf.h macro.h $*.c
@//E*O*F makemsc//
chmod u=rw,g=r,o=r makemsc

echo x - prep.c
sed 's/^@//' > "prep.c" <<'@//E*O*F prep.c//'
/* Program PREP.C
 *
 * Preprocessor for FORTRAN 77.
 * Adds the additional features:
 *
 *  1) Vector arithmetic:
 *     a(#,#,1) = b(#,#) + 1
 *
 *   [ a(#) = b(#)*c(#) - 100
 *     x = y
 *     d(#) = e(#)         ]
 *
 *  2) Case construct:
 *     case ( exp1 )
 *     of   ( exp2 )  line of code
 *                    line of code
 *                    continue_case
 *     of   ( exp3 )  line of code
 *     default        line of code
 *                    line of code
 *     end_case
 *
 *  3) do i = 1, 10
 *        line of code
 *        line of code
 *     leave_do (optional expression)
 *        line of code
 *     continue_do (optional expression)
 *        line of code
 *     end_do
 *
 *  4) forth style begin/while/until/again construct:
 *     begin ... again
 *     begin ... while (exp1) ... again
 *     begin ... until (exp1)
 *     leave (optional expression) to exit current level
 *     continue (optional expression) to go back to beginning
 *
 *  5) Vector loop unrolling to any depth, for loops
 *     that can be expressed as in #1 above.
 *
 *  6) Macro processing, defined a macro "name" with:
 *     : name(a,b,c)    a = a + func( c, d ) ;
 *
 *  7) Included files:
 *     #include "filename"
 *
 *    The nesting limit for all loops is defined by the constant
 * NESTING in file prepdefs.h.  All underline characters are removed,
 * as are comments if com_keep is NULL.
 *    Any delimeters (){}[]'" may be used in the logical expressions
 * ( i.e.  leave [i .eq. 1] ).
 *    The flow control directives are permitted inside vector
 * loops, but since they will inhibit Cray vectorization of those
 * loops it may be best to avoid this.  One of the reasons for
 * using the vector shorthand is that it encourages programming
 * in a style that can be easily vectorized.
 *    Some attempts have been made to avoid ratfor syntax to that
 * both preprocessors can be used, but this has never been checked.
 *    The number of parameters allowed in a macro is set by the constant
 * MAX_MAC_PARMS in file prepdefs.h (20 is probably more than enough).
 *    Although the syntax is similar to forth, the spirit of
 * forth is totally absent.  The macros are really macros,
 * not colon definitions, and recursive macro definitions will cause
 * an error during expansion.  Postfix notation would only cause
 * confusion, being in conflict with fortran conventions, and is
 * not used.
 *    The macro processor can be considered a pre-preprocessor.  The
 * order of translation is:
 *
 *    1) file inclusion
 *    2) macro processing
 *    3) flow control extensions
 *    4) vector statements
 *
 * Note that because of this the flow control syntax can be modified
 * at the macro level.
 *
 * Switches:
 *   -c        keep comments (truncated at column 72)
 *   -u        keep underline characters
 *   -m        only do macro substitution (==> -c and -u as well, and
 *        prevents file includes (except -i switch).
 *   -i    <file>    include <file> before processing
 *   -U n    unroll vector loops to depth n
 *   -L n    unroll loops with n or fewer lines
 *   -?        write message about allowed switches
 *
 * P. R. OVE  11/9/85
 */

#define    MAIN    1
#include "prep.h"

main( argc, argv )
int    argc ;
char    *argv[] ;
{
int     i, j, maxlength, lines ;
char    *text ;


init() ;
parmer( argc, argv ) ;    /* process command line switches */

/* copyright notice */
fprintf( stderr,
    "PREP  Copyright (C) 1985,1986 P.R.Ove.  All rights reserved\n" ) ;

/* Main loop, loop until true end of file */
while ( 1 ) {

    /* get the next record */
    if ( NULL == get_rec() ) break ;

    /* comment and blank line filtering */
    if ( (*in_buff == 'c') | (*in_buff == 'C') | NOT (IN_BUFF_FULL) ) {
        if ( com_keep ) {
            if ( NOT macro_only ) in_buff[72] = NULL ;
            put_string( in_buff ) ;
        }
        continue ;
    }

    /* handle file inclusion if not in macro_only mode */
    if ( NOT macro_only ) {
        preproc( rec_type( 0 ) ) ;
        if ( NOT (IN_BUFF_FULL) ) continue ;
    }

    /* expand macros in in_buff, result pointed to by text */
    if ( NULL == (text = mac_proc()) ) continue ;    /* NULL ==> macro def */

    /* output text here if only doing macro expansion */
    if ( macro_only ) {
        put_string( text ) ;
        free( text ) ;
        continue ;
    }

    /* count lines in text, delimit with NULLs, and find the longest line */
    for ( maxlength=0, i=0, j=0, lines=1;; i++, j++ ) {
        if ( text[i] == '\n' ) {
            text[i] = NULL ;
            if ( j>maxlength ) maxlength = j ;
            j = -1 ;
            lines++ ;
            continue ;
        }
        if ( text[i] == NULL ) {
            if ( j>maxlength ) maxlength = j ;
            break ;
        }
    }

    /* if necessary expand the output buffer size */
    if ( maxlength > allocation ) {
        allocation = maxlength + maxlength/10 ;
        if ( NULL == (in_buff = realloc( in_buff, allocation )) )
            abort( "reallocation failed" ) ;
        if ( NULL == (out_buff = realloc( out_buff, 4*allocation )) )
            abort( "reallocation failed" ) ;
    }

    /* send each line through the passes */
    for ( j=0, i=0; j<lines; j++, i+=strlen(&text[i])+1 ) {
        strcpy( in_buff, &text[i] ) ;
        passes() ;
    }

    /* free the storage created by mac_proc */
    free( text ) ;
}

fclose( out ) ;
}



/* Do preprocessor passes 1, 2, and 3 on text in in_buff.  Output is
 * also done here.
 */
passes()
{

/* process the statement until it is NULL */
while ( IN_BUFF_FULL ) {

    preproc( rec_type( 1 ) ) ;

    preproc( rec_type( 2 ) ) ;

    preproc( rec_type( 3 ) ) ;
}
}



/* initialization */
init() {
int    i ;

/* do loop counter variables and flags */
for ( i = 0; i < NESTING; i++ ) {
    sprintf( var_name[i], "i%03d", i ) ;
    leave_do_flag[i] = FALSE ;
}

/* Allocate some space for the buffers */
allocation = DEF_BUFFSIZE ;
GET_MEM( in_buff, allocation ) ;
GET_MEM( out_buff, 4*allocation ) ;
}



/* error exit */
abort( string )
char    *string ;
{
    fprintf( stderr, "%s\n", string ) ;
    fprintf( out, "%s\n", string ) ;
    fclose( out ) ;
    exit() ;
}
@//E*O*F prep.c//
chmod u=rw,g=r,o=r prep.c

echo x - macro.c
sed 's/^@//' > "macro.c" <<'@//E*O*F macro.c//'
/* MACRO.c
 *
 *   The routines in this file support the macro processing facilities
 * of PREP.  The style is similar to that of c #define macros, except
 * that : is used instead of #define and ; terminates the macro.
 * This is done to allow both PREP macros and ratfor macros in the
 * same program.
 *   Recursive definitions are permitted, but will cause an abort
 * (and possibley a memory allocation error) on expansion.  For each
 * line submitted to expand_macros, a count of is kept for each
 * stored macro indicating how many times it has been expanded in
 * the current line.  When this exceeds MAX_CALLS, the program
 * assumes a macro definition is recursive and stops.  Macros
 * are expanded starting with the one with the longest name, so that
 * if the definitions
 *
 * : >=        .ge. ;
 * : >        .gt. ;
 *
 * are in effect, >= will be changed to .ge. rather than .gt.=.  This
 * is only a potential problem when macro names are not fully
 * alphanumeric, since "arg" will not be flagged if "r" is defined.
 *
 * 11/4/86 P.R.OVE
 */

#include "macro.h"


/* Macro processor.
 *
 *   This routine defines and expands macros.  The definition phase
 * is invoked when a leading : is found in the record.  Text is
 * then taken until the terminating ; is found.  Text following the
 * ; is ignored.  Multiline macros are permitted: they will be
 * converted to at least as many lines in the fortran program.
 * Failure to have a terminating ; will define the entire program
 * to be a macro.
 *   A NULL pointer is returned if a macro has been defined.  Otherwise
 * a pointer to the buffer with the expanded text is returned (even if
 * no macros have been expanded).  The buffer is temporary and should
 * be eliminated by the caller.
 */

char    *mac_proc()
{
int    i, j, size ;
char    *text, *def ;


/* see if this is a definition (look for leading :) */
for ( i=0, text=NULL; in_buff[i] != NULL; i++ ) {
    if ( in_buff[i] == BLANK | in_buff[i] == TAB ) continue ;
    if ( in_buff[i] == ':' ) text = &in_buff[i] ;
    break ;
}

if ( text == NULL ) {
/* expand macro if not a definition */
    if ( defined_macros == 0 ) {
        GET_MEM( text, strlen(in_buff) ) ;
        strcpy( text, in_buff ) ;
        return( text ) ;
    }
    else return( expand_macros( in_buff ) ) ;

}
else {

/* macro definition, get characters until ; */
    GET_MEM( def, strlen(text)+10 ) ;
    strcpy( def, text ) ;
    for ( j=1;; j++ ) {

        switch ( def[j] ) {

        case ';'  :{    def[j+1] = NULL ;
                define_macro( def ) ;
                free( def ) ;
                return( NULL ) ;
            }

        case NULL :{
                def[j] = '\n' ;
                def[j+1] = NULL ;
                if ( NULL == get_rec() )
                    abort("MACRO: EOF in macro def") ;
                size = strlen(def) + strlen(in_buff) + 10 ;
                if ( NULL == (def=realloc(def,size)) )
                    abort("MACRO: realloc error") ;
                strcat( def, in_buff ) ;
            }
        }
    }
}
}




/* Process the macro definition in the argument string.
 * A macro has the form:
 *
 * : name( parm1, parm2, ... )    text with parms ;
 *
 * In a definition the delimeter must follow the name
 * without whitespace.  In the source code this requirement is
 * relaxed.  Alphanumeric macros must be not be next to an alpha or
 * number character or they will not be recognized.
 *
 * This routine puts the macro string into a more easily handled
 * structure, replacing parms in the text with n, where n is a
 * binary value (128 to 128+MAX_TOKENS).
 *
 * The macro is placed in a structure of the form:
 *
 *    struct mac {
 *    char *name ;        macro id tag
 *    char *text ;        encoded macro text
 *    int  parmcount ;    number of arguments
 *    int  callcount ;    recursion check
 *    } macro[MAX_MACROS] ;
 *
 * where the text string has binary symbols where the parms were.
 * Returns the macro index.  The number of macros defined is stored
 * in global variable defined_macros.
 *
 * The macros are entered in order of their name length, so that
 * the macro expander will expand those with long names first.
 */

int    define_macro(string)
char    *string ;
{
char    *pntr, *pntr1, *name, *parms[MAX_TOKENS], *parm, *text,
    *open_parens, *close_parens ;
int    i, j, l, parmcount ;

/* macrop is a pointer to the macro structure that will be used */
    if ( defined_macros >= MAX_MACROS ) {
        sprintf(errline,"DEFINE_MACRO: too many macros: %s",string);
        abort( errline ) ;
    }
    macrop = ¯o[defined_macros] ;
    defined_macros++ ;

/* get the name */
    name = strtokp( string, ":; \n\t(" ) ;    /* pointer to the name */
    GET_MEM( macrop->name, strlen(name) ) ;
    strcpy( macrop->name, name ) ;

/* get the parameters */
    for ( i=0; i<MAX_TOKENS; i++ ) parms[i] = NULL ;
    open_parens = strmatch(string,name) + strlen(name) ;
    if ( NULL == line_end( open_parens ) ) {
        sprintf( errline, "DEFINE_MACRO: unterminated: %s", string ) ;
        abort( errline ) ;
    }

    /* get the text storage here to avoid memory allocation tangles */
    text = open_parens ;
    GET_MEM( macrop->text, strlen(text) ) ;

    if ( strchr( "([{\'\"", *open_parens ) ) {
        if ( NULL == ( close_parens = mat_del( open_parens ) ) ) {
            sprintf(errline,"DEFINE_MACRO: missing delimeter: %s",
                string ) ;
            abort( errline ) ;
        }
        text = close_parens + 1 ;
        i = (int)(close_parens - open_parens) - 1 ;
        pntr = open_parens + 1 ;
        *close_parens = NULL ;
        for ( i=0, pntr1 = pntr; i<MAX_TOKENS; i++, pntr1 = NULL ) {
            if ( NULL == ( parm = strtokp( pntr1, ", \t" ) ) )
                break ;
            GET_MEM( parms[i], strlen(parm) ) ;
            strcpy( parms[i], parm ) ;
        }
    }


/* get the text, plugging in binary codes for parameters */

    /* remove leading whitespace */
    if ( NULL == (text=line_end( text )) ) {
        sprintf( errline, "DEFINE_MACRO: unterminated: %s", string ) ;
        abort( errline ) ;
    }

    /* remove the trailing ';' but NOT whitespace */
    for ( i=strlen(text)-1; i>=0; i-- ) {
        if ( text[i] == ';' ) { text[i] = NULL ; break ; }
    }

    strcpy( macrop->text, text ) ;
    text = macrop->text ;

    for ( i=0; i<MAX_TOKENS & NULL != (parm = parms[i]); i++ ) {

        /* replace parm by code, if not next to an alpha or number */
        l = strlen(parm) ;
        for ( pntr=text;NULL != (pntr1=strmatch(pntr,parm));
        pntr=pntr1+1 ) {
            if ( !( isalnum(*(pntr1-1)) && isalnum(*pntr1) ) &
                 !( isalnum(*(pntr1+l-1)) && isalnum(*(pntr1+l)))) {
                     *pntr1 = i + 128 ;
                strcpy( pntr1 + 1, pntr1 + strlen(parm) ) ;
            }
        }
    }


/* count parms and free up temporary storage */
    macrop->parmcount = 0 ;
    for ( i=0; i<MAX_TOKENS & NULL != parms[i]; i++ ) {
        free( parms[i] ) ;
        macrop->parmcount++ ;
    }

/* rearrange the macro table so it is sorted by name length */
    name = macrop->name ;
    text = macrop->text ;
    parmcount = macrop->parmcount ;
    l = strlen( name ) ;
    for ( i=0; i<defined_macros-1; i++ ) {
        if ( l < strlen( macro[i].name ) ) {
            for ( j=defined_macros-1; j>i; j-- ) {
                macro[j].name = macro[j-1].name ;
                macro[j].text = macro[j-1].text ;
                macro[j].parmcount = macro[j-1].parmcount ;
            }
            macro[i].name = name ;
            macro[i].text = text ;
            macro[i].parmcount = parmcount ;
            break ;
        }
    }

/* return the index of the new macro */
    return(i) ;
}



/* Expand the macros in the argument string.  Returns a pointer
 * to the expanded string, which is likely to be huge.  The memory
 * should be freed as soon as possible.  The macros are expanded
 * starting with the one with the highest index.  Recursive macro
 * definitions will be flagged, but may cause a termination due to
 * allocation failure before doing so.  Caution must be exercised
 * to avoid accidental recursive definitions involving
 * more than one macro:
 *    : h    i+x ;
 *    : i(y)    func(y) ;
 *    : func    h ;
 * This will generate the successive strings (from a = func(x)):
 *    a = h(x)
 *    a = i+x(x)
 *    a = func()+x(x)
 *    a = h()+x(x) .... and so on.  Beware.
 * The string is deallocated by this routine.
 */

/* macros to check for being next to an alpha */
#define FIRSTCHAR ( (pntr1!=text) && (isalnum(*(pntr1-1))&&isalnum(*pntr1)) )
#define LASTCHAR  ( isalnum(*(pntr1+l-1)) && isalnum(*(pntr1+l)) )
#define NEXT_TO_ALPHA    ( FIRSTCHAR || LASTCHAR )

char    *expand_macros(string)
char    *string ;
{
char    *pntr, *pntr1, *name, *text ;
int    i, hit, l ;

/* Allocate some initial storage */
    GET_MEM( text, strlen(string) ) ;
    strcpy( text, string ) ;

/* clear the recursion check counters */
    for ( i=0; i<defined_macros; i++ ) macro[i].callcount = 0 ;

/* search for macros */
    do {
    for ( i=defined_macros-1, hit=0; i>=0; i-- ) {

    /* See if macro[i] is in the present string.  If the "edges"
     * of the macro name are alphanumeric, don't accept the string
     * if the adjacent character is also alphanumeric.  This avoids
     * having variables such as "sin" flagged if "s" is defined.
     * Potential macros are also rejected if quoted with '.
     */
        name = macro[i].name ;
        l = strlen(name) ;
        for ( pntr=text; NULL != (pntr1=strmatch(pntr,name));
        pntr=pntr1+1 ) {
            if ( !quoted( pntr1, text ) && !NEXT_TO_ALPHA ) {
                hit = 1 ;            /* got one */
                text = mac_expand( text, pntr1, i ) ;
                break ;
            }
        }
        if ( hit != 0 ) break ;    /* start over if one was found */
    }
    } while( hit != 0 ) ;


    return( text ) ;
}



/* Expand a single macro in a text string, freeing the old storage
 * and returning * a pointer to the new string.  Name points to the
 * macro in the string and index is the macro index.
 */

char    *mac_expand( text, name, index )
char    *text, *name ;
int    index ;
{
char    *pntr, *newtext, *parm, *parms[MAX_TOKENS], *temp,
    *open_parens, *close_parens, *rest_of_text ;
int    i, j, size ;
unsigned char     c ;

    macrop = ¯o[index] ;
    if ( macrop->callcount++ > MAX_CALLS ) {
        sprintf( errline,
        "MAC_EXPAND: possible recursion involving: \'%s\' in\n%s",
            macrop->name, in_buff ) ;
        abort( errline ) ;
    }


/* get the parameters if there are any for this macro */
    for ( i=0; i<MAX_TOKENS; i++ ) parms[i] = NULL ;
    rest_of_text = &name[ strlen( macrop->name ) ] ;
    if ( macrop->parmcount != 0 ) {
        open_parens = &rest_of_text[ strspn( rest_of_text, " \t" ) ] ;
        if ( (NULL != strchr( "([{\'\"", *open_parens )) &
             (NULL != *open_parens )) {
            if (NULL == (close_parens=mat_del(open_parens)) ) {
                sprintf( errline,
                "MAC_EXPAND: missing delimeter: %s", in_buff ) ;
                abort( errline ) ;
            }
            i = (int)(close_parens - open_parens) - 1 ;
            pntr = open_parens + 1 ;
            c = *close_parens ;        /* save *close_parens */
            *close_parens = NULL ;        /* make parm block a string */
            i = tokenize( pntr, parms ) ;    /* break out the parms */
            *close_parens = (char)c ;     /* restore text */
            rest_of_text = close_parens + 1 ;
        }
    }


/* find out how much memory we will need, then allocate */
    size = strlen(text) ;
    if ( NULL != ( pntr = macrop->text ) ) size += strlen(pntr) ;
    for ( i=0; NULL != (c=pntr[i]); i++ ) {
        if ( c > 127 & parms[c-128] != NULL )
            size += strlen(parms[c-128]) ;
    }
    GET_MEM( newtext, size ) ;


/* copy up to macro verbatim */
    *name = NULL ;
    strcpy( newtext, text ) ;

/* expand the macro itself if there is text */
    if ( NULL != (pntr = macrop->text) ) {
        for ( i=0, j=strlen(newtext); NULL != (c=pntr[i]); i++, j++ ) {
            if ( c > 127 ) {
                if ( parms[c-128] != NULL ) {
                    strcat( newtext, parms[c-128] ) ;
                    j += strlen( parms[c-128] ) - 1 ;
                }
                else j-- ;
            }
            else {        /* keep null terminated */
                newtext[j] = c ;
                newtext[j+1] = NULL ;
            }
        }
    }


/* finish off trailing text */
    strcat( newtext, rest_of_text ) ;

/* free up temporary storage and return pointer to new allocation */
    for ( i=0; i<MAX_TOKENS & NULL != parms[i]; i++ ) free( parms[i] ) ;
    free( text ) ;
    return( newtext ) ;
}




/* isalnum: returns nonzero value if the character argument belongs to the
 * sets { a-z, A-Z, 0-9 }.
 */

int    isalnum( c )
char    c ;
{
    if ( c >= 97 & c <= 122 ) return (1) ;    /* a-z */
    if ( c >= 65 & c <= 90 ) return (2) ;    /* A-Z */
    if ( c >= 48 & c <= 57 ) return (3) ;    /* 0-9 */
    return(0) ;                /* miss */
}




/* Return TRUE is the pointer is quoted in the string (pntr marks
 * a position in the string).  The quote character the apostrophe.
 * If pntr is not in the the result will be meaningless.
 */

int    quoted( pntr, string )
char    *pntr, *string ;
{
int    i, quote=FALSE ;

    for ( i=0; NULL != string[i] && &string[i] < pntr; i++ )
        if ( string[i] == '\'' ) quote = !quote ;

    return( quote ) ;
}
@//E*O*F macro.c//
chmod u=rw,g=r,o=r macro.c

echo x - vec.c
sed 's/^@//' > "vec.c" <<'@//E*O*F vec.c//'
/* Routines related to vector shorthand extensions */

#include "prep.h"




/* Function CSQB_PROC.C
 *
 * Process close square brackets.  Abort if called while
 * not in a vector loop, else finish off vector loop processing
 * with a call to end_vec.
 *
 * P. R. OVE  11/9/85
 */

csqb_proc()
{
int    i, quote=1 ;

/* if vec_flag not set this call is an error */
if ( NOT vec_flag ) {
    sprintf( errline, "CSQB: not in vector loop: %s", in_buff ) ;
    abort( errline ) ;
}

/* see what in_buff contains and replace unquoted ] by NULL */
for ( i = 0; in_buff[i] != NULL; i++ ) {
    switch ( in_buff[i] ) {

    case '\'' :    quote = -quote ;
            break ;
    case ']' :    if ( quote == 1 ) {
                in_buff[i] = NULL ;
                i-- ;        /* force termination */
                break ;
            }
    }
}

dump( in_buff ) ;    /* --> mem_store */
end_vec();        /* terminate vector loop */

IN_BUFF_DONE ;
}




/* Function DO_LIMITS_PROC
 *
 * Process do_limits statements: Parse variable string.
 *
 * P. R. OVE  11/9/85
 */

char    *tokens[MAX_TOKENS] ;

do_limits_proc()
{
int    i, j, k ;
char    *temp[MAX_TOKENS], *open_parens, *close_parens ;

/* free allocation from previous call */
free_loop_vars() ;

/* find the open and close delimeters */
open_parens = &in_buff[ strcspn( in_buff, "[({\'\"" ) ] ;
if ( NULL == ( close_parens = mat_del( open_parens ) ) ) {
    sprintf( errline, "DO_LIMITS: missing delimeter: %s", in_buff ) ;
    abort( errline ) ;
}
*close_parens = NULL ;    /* make arg string null terminated */


/* get the (initial,limit,increment) triples */
var_count = tokenize( open_parens+1, tokens ) ;

/* handle wierd numbers of tokens */
if ( var_count <= 0 ) abort( "ERROR: no variables found" ) ;
for ( i = NESTING; i < var_count; i++ ) {
    var_count = NESTING ; free( tokens[i] ) ; }


/* At this stage the tokens are strings like
 *
 *  "(initial , limit , increment)  ==>  do i = initial, limit, increment.
 *
 * If one is missing it is assumed to be the increment.  If two are
 * missing the single item is assumed to be the limit.  The parens are
 * unnecessary if there is only the limit.
 *
 * break out the tokens (delimeted by commas)
 */
alloc_loop_vars() ;
for ( i = 0; i < var_count; i++ ) {

    /* find the open and close delimeters if present, and handle them*/
    open_parens = &tokens[i][ strcspn( tokens[i], "[({\'\"" ) ] ;
    if ( NULL != ( close_parens = mat_del( open_parens ) ) ) {
        *close_parens = NULL ;
        *open_parens = BLANK ;
    }

    k = tokenize( tokens[i], temp ) ;

    /* case of too many tokens, ignore trailers */
    for ( j = 3; j < k; j++ ) { k = 3 ; free( temp[j] ) ; }

    switch ( k ) {
    case 1:    strcpy(initial_name[i], "1") ;
        sprintf(limit_name[i], "(%s)", temp[0]) ; free( temp[0] ) ;
        strcpy(increment_name[i], "1") ;
        break;

    case 2:    sprintf(initial_name[i], "(%s)", temp[0]) ; free( temp[0] ) ;
        sprintf(limit_name[i], "(%s)", temp[1]) ; free( temp[1] ) ;
        strcpy(increment_name[i], "1") ;
        break;

    case 3:    sprintf(initial_name[i], "(%s)", temp[0]) ; free( temp[0] ) ;
        sprintf(limit_name[i], "(%s)", temp[1]) ; free( temp[1] ) ;
        sprintf(increment_name[i], "(%s)", temp[2]) ; free( temp[2] ) ;
        break;

    default:strcpy(initial_name[i], "1") ;
        sprintf(limit_name[i], "(%s)", "undefined" ) ;
        strcpy(increment_name[i], "1") ;
        break;
    }
}

IN_BUFF_DONE
}

/* release allocation from previous call */
free_loop_vars() {
int    i ;

for ( i = 0; i < var_count; i++ ) {
    free( tokens[i] ) ;
    free( initial_name[i] ) ;
    free( limit_name[i] ) ;
    free( increment_name[i] ) ;
}
}

/* allocate space for do loop variables */
alloc_loop_vars() {
int    i, size ;

for ( i = 0; i < var_count; i++ ) {
    size = strlen( tokens[i] ) + 10 ;
    GET_MEM( initial_name[i], size ) ;
    GET_MEM( limit_name[i], size ) ;
    GET_MEM( increment_name[i], size ) ;
}
}




/* Function END_VEC.C
 *
 * This routine is called when a cluster of vector arithmetic
 * is ready to be terminated (a closing ] has been found
 * or the statement was a single line vector * statement.  The
 * core of the loop has by now been pushed into MEM_STORE and
 * will now be extracted and processed.  On completion MEM_STORE
 * is released.
 *
 * P. R. OVE  11/9/85
 */

end_vec()
{
int    i, j ;

/* reset the flag */
vec_flag = FALSE ;

make_do() ;    /* write the initial do loop statements */

if ( NOT UNROLLING ) {
    /* process all of the pushed statements through transvec */
    for ( i = 0; i < mem_count; i++ )
        transvec( mem_store[i], 0 ) ;

    make_continue() ;    /* write continue statements */
}

else {
    /* process the statements though transvec unroll_depth times */
    for ( j = 0; j < unroll_depth; j++ ) {
        for ( i = 0; i < mem_count; i++ )
            transvec( mem_store[i], j ) ;
    }
    make_continue() ;

    /* write the clean up part of the unrolled loop */
    make_labels() ;
    make_clean_do() ;
    for ( i = 0; i < mem_count; i++ )
        transvec( mem_store[i], 0 ) ;
    make_continue() ;
}

/* release the memory held by MEM_STORE and return to main level */
while ( push(NULL) >= 0 ) ;
IN_BUFF_DONE
}




/* Make the initial do statements */
make_do() {
int    i ;

/* outermost do statement is different if unrolling is on */
i = var_count - 1 ;

if ( UNROLLING ) {
/* This section unrolls: do i = a, b, c   (depth = d)   into
 *
 *             b-a+c
 * do i = a, (-------)*(c*d) + a - c, c*d
 *              c*d
 *
 * for the outermost loop.  Inner loops are unchanged.
 */
    sprintf( out_buff,
    "      do %s %s=%s,int((1.0*(%s-%s+%s))/(%s*%d))*%s*%d+%s-%s,%s*%d",
        label[i], var_name[i], initial_name[i],
        limit_name[i], initial_name[i], increment_name[i],
        increment_name[i], unroll_depth,
        increment_name[i], unroll_depth,
        initial_name[i], increment_name[i],
        increment_name[i], unroll_depth ) ;
    dump( out_buff ) ; }
else {
    sprintf( out_buff, "      do %s %s = %s, %s, %s",
        label[i], var_name[i],
        initial_name[i], limit_name[i], increment_name[i] ) ;
    dump( out_buff ) ; }

/* handle the rest of the do statements */
for ( i = var_count-2; i >= 0; i-- ) {
    sprintf( out_buff, "      do %s %s = %s, %s, %s",
        label[i], var_name[i],
        initial_name[i], limit_name[i], increment_name[i] ) ;
    dump( out_buff ) ; }
}




/* make the do statements for the clean up part of the unrolled loop */
make_clean_do() {
int    i ;

/* make the outer do statement.
 * This section unrolls: do i = a, b, c   (depth = d)   into
 *
 *          b-a+c
 * do i = (-------)*(c*d) + a, b, c
 *           c*d
 *
 * for the outermost loop.  Inner loops are unchanged.  The initial
 * value is the first element that missed the main do loop */
i = var_count - 1 ;
sprintf( out_buff,
    "      do %s %s=int((1.0*(%s-%s+%s))/(%s*%d))*%s*%d+%s,%s,%s",
    label[i], var_name[i],
    limit_name[i], initial_name[i], increment_name[i],
    increment_name[i], unroll_depth,
    increment_name[i], unroll_depth,
    initial_name[i], limit_name[i], increment_name[i] ) ;
dump( out_buff ) ;

/* make the remaining do statements */
for ( i = var_count-2; i >= 0; i-- ) {
    sprintf( out_buff, "      do %s %s = %s, %s, %s",
        label[i], var_name[i],
        initial_name[i], limit_name[i], increment_name[i] ) ;
    dump( out_buff ) ;
}
}


/* make the continue statements */
make_continue() {
int    i ;

for ( i = 0; i < var_count; i++ ) {
    sprintf( out_buff, "%s continue", label[i] ) ;
    dump( out_buff ) ; }
}




/* Function MAKE_LABELS.C
 *
 * Make var_count labels, starting with label_count
 * + 10000.
 *
 * P. R. OVE  11/9/85
 */

make_labels()
{
int    i, count ;

for ( i = 0; i < var_count; i++ ) {

    count = 10000 + label_count ;
    label_count++ ;
    if ( count > 12499 ) {
        sprintf( errline, "MAKE_LABELS: too many labels: %s", in_buff ) ;
        abort( errline ) ;
    }
    sprintf( label[i], "%d", count ) ;
}
}



/* Function OSQB_PROC.C
 *
 *   Process open square brackets.  This routine will be
 * called when an open square bracket is found in the
 * record (start cluster of vector arithmetic).  It sets
 * up the labels and sets vec_flag so that dump will direct
 * output to mem_store instead of the output file.
 *   The initial do statements are not written here, so that
 * unrolling can be turned off if there are too many lines
 * ( > line_limit ) in the loop.  Endvec will write them.
 *   If a closing ] is also found in the same record then
 * the statement is passed through transvec immediately, since
 * it has already been processed by the rest of the preprocessor.
 *
 * P. R. OVE  11/9/85
 */

osqb_proc()
{
int    i, quote=1 ;

/* if default loop limits have not been set abort here */
if ( var_count <= 0 ) {
    sprintf( errline, "Vector loop without default limits set: %s", in_buff ) ;
    abort( errline ) ;
}

make_labels() ;        /* get a list of labels */

vec_flag = TRUE ;    /* now force output --> mem_store */

/* see what in_buff contains and replace unquoted [] by blanks */
for ( i = 0; in_buff[i] != NULL; i++ ) {

    switch ( in_buff[i] ) {

    case '\'' :    quote = -quote ;
            break ;
    case '[' :    if ( quote == 1 ) {
                in_buff[i] = BLANK ;
                break ;
            }
    case ']' :    if ( quote == 1 ) {
                vec_flag = FALSE ;
                in_buff[i] = BLANK ;
                break ;
            }
    }
}

/* if there is a closing ] process the line now */
if ( NOT vec_flag ) {
    vec_flag = TRUE ;    /* force line to mem_store */
    dump( in_buff ) ;
    end_vec() ;        /* flag will be reset here */
}
else dump( in_buff ) ;        /* this will go to mem_store */

IN_BUFF_DONE ;
}




/* Function TRANSVEC.C
 *
 * Translate a record of vectored arithmetic and expand
 * out the # signs.  The resulting expanded record is
 * placed in out_buff and dumped.  The second argument
 * is related to unrolling, and is the amount to be
 * added to the index of the outermost loop.  This
 * should be zero if unrolling is off.  Quoted characters
 * are ignored ( ' is the fortran quote character ).
 *
 * P. R. OVE  11/9/85
 */

/* copy character verbatim to the output buffer */
#define    VERBATIM    out_buff[i_out] = string[i_in] ;\
            out_buff[i_out + 1] = NULL ;    \
            i_out++ ;


transvec( string, outer_loop_inc )
char    *string ;
int    outer_loop_inc ;
{
int    i_in, i_out = 0, i_var = 0, quote = 1 ;
char    *pntr ;

/* make string version of loop counter increment */
if ( UNROLLING ) {
    GET_MEM( pntr, strlen(increment_name[var_count-1])
             + abs(outer_loop_inc) + 10 ) ;
    sprintf( pntr, "+%s*%d", increment_name[ var_count - 1 ],
        outer_loop_inc ) ;
}

/* loop over the input record */
for ( i_in = 0; string[i_in] != NULL; i_in++ ) {

/* pass characters straight through if quoted */
if ( string[i_in] == '\'' ) quote = -quote ;
if ( quote == -1 ) {
    VERBATIM ;
    continue ;
}

switch( string[i_in] ) {

    /* replace #'s with variable names */
    case '#' :    strcat( out_buff, var_name[i_var] ) ;
            i_out += 4 ;
            i_var++ ;
            if ( i_var >= var_count ) {
                i_var = 0 ;
                if (UNROLLING & outer_loop_inc != 0) {
                    strcat( out_buff, pntr ) ;
                    i_out += strlen( pntr ) ;
                }
            }
            break ;

    /* reset variable counter */
    case ')' :    out_buff[i_out] = ')' ;
            out_buff[i_out + 1] = NULL ;
            i_out++ ;
            i_var = 0 ;
            break ;

    /* copy character verbatim */
    default :     VERBATIM ;

}
}

if (UNROLLING) free( pntr ) ;
dump( out_buff ) ;

IN_BUFF_DONE ;
}




/* Function UNROLL_PROC
 *
 * Change the unrolling depth.  If depth is less than 2 unrolling is off.
 *
 * P. R. OVE  6/18/86
 */

unroll_proc()
{
int    n ;
char    *open_parens, *close_parens ;

/* get the expression delimeters */
open_parens = line_end( first_nonblank + name_length ) ;
close_parens = mat_del( open_parens ) ;

/* if there is stuff on the line (open_parens != NULL) and no            */
/* open parens (close_parens == NULL) assume variable name like UNROLLit */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;

/* get the depth if it is there (error ==> depth = 0 (OFF)) */
if (open_parens != NULL) {
    n = close_parens - open_parens - 1 ;
    *close_parens == NULL ;
    unroll_depth = atoi( open_parens + 1 ) ;
}
else {    unroll_depth = DEF_UNROLL_DEPTH ; }

IN_BUFF_DONE
}




/* Function VEC_PROC.C
 *
 * This routine's functions when a "naked"
 * (with out surrounding [ ]) vector statement is found.
 * The action depends on whether vec_flag is set or not.
 * If set:
 *   The record is dumped (to mem_store).
 * If not:
 *   It is handled by placing a [ at the beginning and a
 * ] at the end and then starting over.  OSQB_PROC will
 * then trap it and pass it to END_VEC to be processed.
 *
 * P. R. OVE  11/9/85
 */

vec_proc()
{
int    i, length ;

/* if default loop limits have not been set abort here */
if ( var_count <= 0 ) {
    sprintf( errline, "Vector loop without default limits set: %s", in_buff ) ;
    abort( errline ) ;
}

if ( vec_flag ) {
    dump( in_buff ) ;    /* --> mem_store */
    IN_BUFF_DONE ;
}
else {
    length = strlen( in_buff ) ;
    for ( i = length - 1; i >= 0; i-- ) in_buff[i+1] = in_buff[i] ;
    in_buff[ length + 1 ] = ']' ;
    in_buff[ length + 2 ] = NULL ;
    in_buff[ 0 ] = '[' ;
}
}
@//E*O*F vec.c//
chmod u=rw,g=r,o=r vec.c

echo x - str.c
sed 's/^@//' > "str.c" <<'@//E*O*F str.c//'
/* A few string functions missing from the Sun unix library */

#include <stdio.h>
#include "string.h"

/* Find the first occurrence of c in string */
char    *strchr( s, c )
char    *s, c ;
{
int    length, i ;
    length = strlen(s) ;

    for ( i=0; i<=length; i++ ) if ( s[i] == c ) return( &s[i] ) ;
    return( NULL ) ;
}

/* find the index of the first char in s1 that is not in s2 */
int    strspn( s1, s2 )
char    *s1, *s2 ;
{
int    i ;

    for ( i=0 ; s1[i] != NULL ; i++ ) {
        if ( NULL == strchr(s2,s1[i]) ) break ;
        }
    return(i) ;
}


/* find the index of the first char in s1 that is in s2 */
int    strcspn( s1, s2 )
char    *s1, *s2 ;
{
int    i ;

    for ( i=0 ; s1[i] != NULL ; i++ ) {
        if ( NULL != strchr(s2,s1[i]) ) break ;
        }
    return(i) ;
}
@//E*O*F str.c//
chmod u=rw,g=r,o=r str.c

echo Inspecting for damage in transit...
temp=/tmp/shar$$; dtemp=/tmp/.shar$$
trap "rm -f $temp $dtemp; exit" 0 1 2 3 15
cat > $temp <<\!!!
     607    4325   25859 prep.doc
      16      40     236 Makefile
      21      55     503 makemsc
     225    1067    5831 prep.c
     433    2228   12268 macro.c
     544    2302   12944 vec.c
      40     168     728 str.c
    1886   10185   58369 total
!!!
wc  prep.doc Makefile makemsc prep.c macro.c vec.c str.c | sed 's=[^ ]*/==' | diff -b $temp - >$dtemp
if [ -s $dtemp ]
then echo "Ouch [diff of wc output]:" ; cat $dtemp
else echo "No problems found."
fi
exit 0