prove@batcomputer.UUCP (03/31/87)
# This is a shell archive. Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by tralfaz!ove on Mon Mar 30 18:37:21 PST 1987
# Contents: Makefile makemsc prep.c vec.c misc.c prep.h string.h
echo x - Makefile
sed 's/^@//' > "Makefile" <<'@//E*O*F Makefile//'
CFLAGS = -c -O
PROF = # -pg for gprof, -g for dbx
LIBS =
OBJS = prep.o flow.o vec.o misc.o str.o macro.o ifdef.o
@.SUFFIXES :
@.SUFFIXES : .o .c
prep :: $(OBJS)
cc $(PROF) -o prep $(OBJS) $(LIBS)
@.c.o :
cc $(CFLAGS) $(PROF) $*.c
$(OBJS) : prep.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 ifdef.obj macro.obj
@.SUFFIXES :
@.SUFFIXES : .exe .obj .c
prep.exe : $(COBJS)
@link $<, $@, NUL, $(LIBS) $(LINKFLAGS)
@.c.obj :
msc $* /AS;
$(COBJS) : prep.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, define a macro "name" with:
* : name(a,b,c) a = a + func( c, d ) ;
*
* 7) Included files:
* #include "filename"
*
* 8) Conditional compilation:
* #ifdef, #ifndef, #else, #endif
*
* 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 & conditional compilation
* 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
* -d <name> define <name> as a macro, using :name 1;
* -r n unroll vector loops to depth n
* -l n unroll loops with n or fewer lines
* -(other) 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, *semi ;
init() ;
parmer( argc, argv ) ; /* process command line switches */
/* copyright notice */
fprintf( stderr,
"PREP: Copyright P.R.Ove.\n" ) ;
/* Main loop, loop until true end of file */
while ( NULL != get_rec() ) {
/* if an #ifdef has turned off processing, keep looking for #endif.. */
if ( ignore_flag ) {
if (NULL != (semi = strchrq(in_buff,';'))) *semi = NULL ;
preproc( rec_type(0) ) ;
continue ;
}
if ( comment_filter() ) continue ; /* TRUE ==> nothing left */
/* if only doing macro expansion: */
if ( macro_only ) {
if ( NULL != (text = mac_proc()) ) { /* NULL ==> macro def */
put_string( text ) ;
free( text ) ;
}
continue ;
}
/* handle file inclusion & #ifdefs */
if ( NULL == preproc(rec_type(0))) continue ;
/* expand macros in in_buff, result pointed to by text */
if ( NULL == (text = mac_proc()) ) continue ; /* NULL ==> macro def */
/* 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 ) ; /* SVS seems to need this explicit close */
}
/* 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 (1) {
if ( NULL == preproc( rec_type(1) ) ) break ;
if ( NULL == preproc( rec_type(2) ) ) break ;
if ( NULL == preproc( rec_type(3) ) ) break ;
}
}
/* initialization */
init() {
flow_init() ;
vec_init() ;
/* 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(1) ;
}
@//E*O*F prep.c//
chmod u=rw,g=r,o=r prep.c
echo x - vec.c
sed 's/^@//' > "vec.c" <<'@//E*O*F vec.c//'
/* Routines related to vector shorthand extensions */
#include "prep.h"
char *initial_name[NESTING] ; /* do loop initial values */
char *limit_name[NESTING] ; /* do loop limits */
char *increment_name[NESTING] ; /* do loop increments */
char label[NESTING][6] ; /* label storage (vector loops) */
char var_name[NESTING][6] ; /* do counter names */
int var_count = 0 ; /* number of vars used in do loops */
int label_count = 0 ; /* label = label_count + 10000 */
/* VEC_INIT
*
* Initialize the vec routines
*/
vec_init()
{
int i ;
for ( i = 0; i < NESTING; i++ ) sprintf( var_name[i], "i%03d", i ) ;
}
/* 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 - misc.c
sed 's/^@//' > "misc.c" <<'@//E*O*F misc.c//'
/* misc routines */
#include "prep.h"
/* Function DUMP.C
*
* Send a string to the output stream. The string is a
* fortran record constructed by PREP, which may be
* longer than 72 characters after processing. It is
* broken up into pieces before output. The string
* must be null terminated. The string is not affected
* by this routine, so it is safe to do
* dump( "explicit text" ) ;
*
* If inside a vector loop (vec_flag==TRUE) the record is
* not broken up and is sent to mem_store rather than a file.
*
* P. R. OVE 11/9/85
*/
dump( string )
char *string ;
{
char record[73], *pntr ;
int i_str, i_rec = 0, i, i_tab, quote_flag = 0 ;
/* ignore empty lines sent here */
if ( NULL == line_end( string ) ) return ;
/* if in a vector loop write the string to mem_store */
if ( vec_flag ) {
push( string ) ;
return ;
}
/* loop until end of record */
for ( i_str = 0;; i_str++ ) {
/* wrap up on end of line */
if ( line_end( &string[i_str] ) == NULL ) {
record[i_rec] = NULL ;
put_string( record ) ;
break ; }
/* break string if necessary */
if ( i_rec >= 72 ) {
record[i_rec] = NULL ;
put_string( record ) ;
strcpy( record, " *" ) ;
i_str-- ;
i_rec = 6 ;
continue ;
}
/* toggle quote flag on quotes */
if ( string[i_str] == '\'' ) quote_flag = ! quote_flag ;
/* underline filtering */
if ( (string[i_str]=='_') && (!underline_keep) && (!quote_flag) )
continue ;
/* tab handling */
if ( string[i_str] == TAB ) {
if ( i_rec >= 70 - tab_size ) {
record[i_rec] = NULL ;
put_string( record ) ;
strcpy( record, " *" ) ;
i_rec = 6 ; }
else { /* replace tab by blanks */
i_tab = ( ( i_rec + 1 )/tab_size )
* tab_size - i_rec + tab_size - 1 ;
for ( i = 0; i < i_tab; i++ ) {
record[i_rec] = BLANK ;
i_rec++ ; }
}
continue ;
}
/* default action */
record[i_rec] = string[i_str] ;
i_rec++ ;
}
}
/* GET_RECORD
*
* Get a record from the input stream, making sure that the buffer
* does not overflow by increasing its size as necessary. The
* string in_buff will contain the record on return. In_buff will
* always contain about ten percent of its default length in trailing
* blanks to play with. Out_buff will have space allocated for it
* as well, 4 times that of in_buff. Returns a pointer to the
* terminating NULL character. On EOF the previous input file
* (assuming the present one was an include file) will be restored as
* the input file. If the filestack is empty return NULL.
*/
char *get_rec()
{
int i, j ;
char *pntr, *area ;
/* fill the in_put buffer, enlarging it when nearly full in
* increments of DEF_BUFFSIZE. On end of file the previous file
* handle is popped from the include stack (if present).
*/
pntr = in_buff ;
i = 0 ;
while(1) {
for (; i < allocation - DEF_BUFFSIZE/10 ; i++, pntr++ ) {
*pntr = getc(in) ;
if ( *pntr == EOF || *pntr == 0x1A ) {
fclose(in) ;
if ( NULL == popfile(&in) ) return( NULL ) ;
pntr = in_buff-1 ;
i = -1 ;
continue ;
}
if ( *pntr == '\n' ) {
*pntr = NULL ;
return( pntr ) ;
}
}
/* if control falls through to here, increase buffer sizes. */
allocation += DEF_BUFFSIZE ;
if ( NULL == ( in_buff = realloc( in_buff, allocation ) ) )
abort( "Reallocation failed" ) ;
if ( NULL == ( out_buff = realloc( out_buff, 4*allocation ) ) )
abort( "Reallocation failed" ) ;
}
}
/* Function LINE_END
*
* Return a NULL pointer if the string contains only
* blanks and tabs or if it is a NULL string. Else
* return a pointer to the first offending character.
*
* P. R. OVE 11/9/85
*/
char *line_end( string )
char *string ;
{
for (; *string != NULL; string++ )
if ( (*string != BLANK) && (*string != TAB) ) return(string) ;
return( NULL ) ;
}
/* Function MAT_DEL
*
* Given pointer to a delimeter this routine finds its
* partner and returns a pointer to it. On failure a
* NULL pointer is returned. The supported delimeters
* are:
*
* ' " ( ) [ ] { } < >
*
* ' and " are supported only in the forward direction
* and no nesting is detected.
* In all cases the search is limited to the current
* line (bounded by NULLs).
*
* P. R. OVE 11/9/85
*/
char *mat_del( pntr )
char *pntr ;
{
int nest_count = 0, i, direction ;
char target ;
if ( pntr == NULL ) return( NULL ) ;
/* get the target character and direction of search */
switch( *pntr ) {
case '(' : { target = ')' ;
direction = 1 ;
break ; }
case ')' : { target = '(' ;
direction = -1 ;
break ; }
case '[' : { target = ']' ;
direction = 1 ;
break ; }
case ']' : { target = '[' ;
direction = -1 ;
break ; }
case '{' : { target = '}' ;
direction = 1 ;
break ; }
case '}' : { target = '{' ;
direction = -1 ;
break ; }
case '<' : { target = '>' ;
direction = 1 ;
break ; }
case '>' : { target = '<' ;
direction = -1 ;
break ; }
case '\'': { target = '\'' ;
direction = 1 ;
break ; }
case '\"': { target = '\"' ;
direction = 1 ;
break ; }
default: return( NULL ) ;
}
/* find the match */
for ( i = direction; pntr[i] != NULL; i += direction ) {
if ( pntr[i] == target ) {
if ( nest_count == 0 ) {
break ; }
else {
nest_count-- ;
continue ; }
}
if ( pntr[i] == pntr[0] ) nest_count++ ;
}
if ( &pntr[i] == NULL ) return( NULL ) ;
return( &pntr[i] ) ;
}
/* PARMER
*
* Processes the command line parameters.
*/
int parmer ( argc, argv )
int argc ;
char *argv[] ;
{
int i ;
/* default io streams */
in = stdin ;
out = stdout ;
/* use in_buff to hold file inclusion command if found (1 only) */
IN_BUFF_DONE ; /* clear the buffer */
for ( i = 1; i < argc; i++ ) {
/* assume data file name if not a switch */
if ( argv[i][0] != '-' ) {
sprintf( dataf, "%s.p", argv[i] ) ;
if ( NULL != ( in = fopen( dataf, "r" ) ) ) {
sprintf( dataf, "%s.f", argv[i] ) ;
out = fopen( dataf, "w" ) ;
}
else in = stdin ;
}
else {
/* switches */
switch ( argv[i][1] ) {
case 'c' : case 'C' :
com_keep = TRUE ; break ;
case 'u' : case 'U' :
underline_keep = TRUE ; break ;
case 'r' : case 'R' :
i++ ;
if ( i < argc ) {
if ( argv[i][0] == '-' ||
NULL == sscanf(argv[i],"%d",&unroll_depth)) {
unroll_depth = DEF_UNROLL_DEPTH ;
i-- ;
break ;
}}
else unroll_depth = DEF_UNROLL_DEPTH ;
break ;
case 'l' : case 'L' :
i++ ;
if ( i < argc ) {
if ( argv[i][0] == '-' ||
NULL == sscanf(argv[i],"%d",&line_limit)) {
line_limit = DEF_LINE_LIMIT ;
i-- ;
break;
}}
else line_limit = DEF_LINE_LIMIT ;
break ;
case 'm' : case 'M' :
macro_only = TRUE ;
underline_keep = TRUE ;
com_keep = TRUE ;
break ;
case 'i' : case 'I' :
i++ ;
if ( i < argc && *in_buff != '#' ) {
sprintf(in_buff,
"#include \"%s\"", argv[i] ) ;
break ;
}
else goto ERROR ;
case 'd' : case 'D' :
i++ ;
if ( i < argc ) {
sprintf(out_buff, ":%s 1;", argv[i] ) ;
define_macro( out_buff ) ;
break ;
}
ERROR:
default:fprintf( stderr, "\nUnrecognized switch: %s\n", argv[i]);
fprintf( stderr,
"\nAllowed switches:\n\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n",
" -c keep comments",
" -u keep underline characters",
" -m expand macros only",
" -i <file> include <file> before processing (1 only)",
" -d <name> define <name> as a macro ( :name 1; )",
" -r n unroll vector loops to depth n",
" -l n unroll loops with n or fewer lines only",
"All items must be separated by blanks"
) ;
abort( "\n" ) ;
}
}
}
/* process the file include statement if present */
preproc( rec_type(0) ) ;
}
/* Function PREPROCESS.C
*
* The guts of the preprocessor PREP. Variable tipe
* contains the type of record code:
*
* BEGIN statement
* AGAIN statement
* WHILE statement
* UNTIL statement
* CONTINUE statement
* LEAVE statement
*
* CASE statement
* OF statement
* DEFAULT statement
* CONTINUE_CASE statement
* END_CASE statement
* DO_LIMITS statement
* UNROLL statement
*
* DO statement
* LEAVE_DO statement
* CONTINUE_DO statement
* END_DO statement
*
* [ (start of clustered vector arithmetic)
* ] ( end " " " " )
* # vectored arithmetic statement
* normal (normal fortran statement)
*
* INCLUDE files
* conditional compilation:
* #ifdef, #ifndef, #else, #endif
*
* Returns 1 if the buffer is still full, else 0. The individual
* routines are expected to clear the buffer (in_buff) to signal
* that no more processing is required.
*
* P. R. OVE 11/9/85
*/
int preproc(tipe)
int tipe ;
{
switch ( tipe ) {
case unknown : break ;
case normal : strcpy( out_buff, in_buff ) ;
dump( out_buff ) ;
in_buff[0] = NULL ;
break ;
case type_begin : begin_proc() ; break ;
case type_again : again_proc() ; break ;
case type_while : while_proc() ; break ;
case type_until : until_proc() ; break ;
case type_continue : continue_proc() ; break ;
case type_leave : leave_proc() ; break ;
case type_case : case_proc() ; break ;
case type_of : of_proc() ; break ;
case type_default : default_proc() ; break ;
case type_continue_case:continue_case_proc() ; break ;
case type_end_case : end_case_proc() ; break ;
case type_do_limits : do_limits_proc() ; break ;
case type_unroll : unroll_proc() ; break ;
case type_do : do_proc() ; break ;
case type_end_do : end_do_proc() ; break ;
case type_leave_do : leave_do_proc() ; break ;
case type_continue_do : continue_do_proc() ; break ;
case type_osqb : osqb_proc() ; break ;
case type_vec : vec_proc() ; break ;
case type_csqb : csqb_proc() ; break ;
case type_include : include_proc() ; break ;
case type_ifdef : ifdef_proc() ; break ;
case type_ifndef : ifndef_proc() ; break ;
case type_else : else_proc() ; break ;
case type_endif : endif_proc() ; break ;
}
return( line_end( in_buff ) != NULL ) ;
}
/* PUSH
*
* Push a string onto the MEM_STORE. Space is allocated for it and
* a pointer kept in the array mem_store (array of pointers). The
* index to mem_store at which the current string is stored is returned.
* If the input string is a NULL pointer the last entry is removed.
* Global variable mem_count keeps track of the total number of pointers
* in use.
*/
int push( string )
char *string ;
{
int i ;
if ( string != NULL ) {
if ( mem_count >= STORE_SIZE - 1 ) {
sprintf( errline, "PUSH out of memory pointers: %s", in_buff ) ;
abort( errline ) ;
}
GET_MEM( mem_store[ mem_count ], strlen( string ) ) ;
strcpy( mem_store[ mem_count ], string ) ;
mem_count++ ;
return( mem_count - 1 ) ;
}
if ( mem_count > 0 ) {
mem_count-- ;
free( mem_store[ mem_count ] ) ;
return( mem_count - 1 ) ;
}
/* already empty if it gets here */
return( -1 ) ;
}
/* Function REC_TYPE.C
*
* Determine the type of a record.
*
* P. R. OVE 11/9/85
*/
char *strchrq() ;
int rec_type( group )
int group ;
{
char combuff[16], *string ;
int i ;
if (in_buff[0] == NULL) return((int)unknown) ;
string = in_buff ;
/* go to first nonblank character, save a pointer to it */
while ( *string != NULL ) {
if ( *string != TAB && *string != BLANK ) {
first_nonblank = string ;
break ;
}
string++ ;
}
/* copy the initial characters into combuff */
for ( i = 0; (i < 15) && (*string != NULL); i++ ) {
combuff[i] = string[i] ;
}
combuff[15] = NULL ;
strupr( combuff ) ; /* convert to upper case */
/* check for commands by group */
switch ( group ) {
/* group 0 commands: file includes & conditional compilation */
case 0 : {
if ( MATCH( "#INCLUDE" ) ) return((int)type_include) ;
if ( MATCH( "#IFDEF" ) ) return((int)type_ifdef) ;
if ( MATCH( "#IFNDEF" ) ) return((int)type_ifndef) ;
if ( MATCH( "#IF" ) ) return((int)type_ifdef) ;
if ( MATCH( "#ELSE" ) ) return((int)type_else) ;
if ( MATCH( "#ENDIF" ) ) return((int)type_endif) ;
return((int)unknown) ;
}
/* group 1 commands: case's OF and DEFAULT commands are done first so
that it is legal to have: of ( 'a' ) leave_do, for instance.
*/
case 1 : {
if ( MATCH( "OF" ) ) return((int)type_of) ;
if ( MATCH( "DEFAULT" ) ) return((int)type_default) ;
return((int)unknown) ;
}
/* group 2 commands: flow control extensions and parameter changes */
case 2 : {
if ( MATCH( "DO_LIMITS" ) ) return((int)type_do_limits) ;
if ( MATCH( "DO LIMITS" ) ) return((int)type_do_limits) ;
if ( MATCH( "DO" ) ) return((int)type_do) ;
if ( MATCH( "END_DO" ) ) return((int)type_end_do) ;
if ( MATCH( "END DO" ) ) return((int)type_end_do) ;
if ( MATCH( "ENDDO" ) ) return((int)type_end_do) ;
if ( MATCH( "LEAVE_DO" ) ) return((int)type_leave_do) ;
if ( MATCH( "LEAVE DO" ) ) return((int)type_leave_do) ;
if ( MATCH( "CONTINUE_DO")) return((int)type_continue_do) ;
if ( MATCH( "CONTINUE DO")) return((int)type_continue_do) ;
if ( MATCH( "CASE" ) ) return((int)type_case) ;
if ( MATCH( "END_CASE" ) ) return((int)type_end_case) ;
if ( MATCH( "END CASE" ) ) return((int)type_end_case) ;
if (MATCH("CONTINUE_CASE")) return((int)type_continue_case) ;
if (MATCH("CONTINUE CASE")) return((int)type_continue_case) ;
if ( MATCH( "BEGIN" ) ) return((int)type_begin) ;
if ( MATCH( "AGAIN" ) ) return((int)type_again) ;
if ( MATCH( "WHILE" ) ) return((int)type_while) ;
if ( MATCH( "UNTIL" ) ) return((int)type_until) ;
if ( MATCH( "LEAVE" ) ) return((int)type_leave) ;
if ( MATCH( "CONTINUE" ) ) return((int)type_continue) ;
if ( MATCH( "UNROLL" ) ) return((int)type_unroll) ;
return((int)unknown) ;
}
/* group 3 commands: vector processing */
case 3: {
if ( MATCH( "[" ) ) return((int)type_osqb) ;
if ( strchrq( string, ']' ) != NULL ) return((int)type_csqb) ;
if ( strchrq( string, '#' ) != NULL ) return((int)type_vec) ;
return((int)normal) ;
}
} /* end switch case */
/* control should never get here */
sprintf( errline, "REC_TYPE: invalid group %d", group ) ;
abort( errline ) ;
return((int)unknown) ; /* here to avoid compiler warning (Gould) */
}
/* Comment and blank line filtering.
*
* This routine also trims off characters after a ";", so that
* this symbol is can be used for comments on the same line. If
* the first character on the line is ":" this is not done, since
* removing the trailing semicolon would cause a macro def error.
* The macro definition routine will eliminate anything after the
* ";" anyway. Blank lines are also killed off here. Returns a
* 1 if the line was entirely a comment and processed, else 0.
*/
int comment_filter()
{
char *start, *semi ;
start = line_end( in_buff ) ;
/* handle lines with comment character in 1st column, and blank lines */
if ( (*in_buff == 'c') || (*in_buff == 'C') ||
(*in_buff == ';') || (start == NULL) ) {
if ( com_keep ) {
if ( NOT macro_only ) in_buff[72] = NULL ;
if ( *in_buff == ';' ) *in_buff = 'c' ;
put_string( in_buff ) ;
}
return(1) ;
}
/* trim off text after ; if not a macro def */
if ( NOT macro_only && *start != ':' ) {
if ( NULL != ( semi = strchrq( in_buff, ';' ) ) ) *semi = NULL ;
}
return(0) ;
}
/* Look for unquoted character in string, where ' is the fortran quote char.
* Returns a pointer to the character, or a NULL pointer if not present.
*/
char *strchrq( string, c )
char *string, c ;
{
int i, quote=1 ;
for ( i = 0; string[i] != NULL; i++ ) {
if ( string[i] == '\'' ) {
quote = -quote ;
continue ;
}
if ( string[i] == c && quote == 1 ) return( &string[i] ) ;
}
return( NULL ) ; /* not found */
}
/* STRMATCH: find the first occurrence of string2 in string1, return pointer
* to the first character of the match. Returns NULL pointer if no match.
* This routine is fairly slow and should not be used where speed is
* critical.
*/
#define NULL 0
char *strmatch( string1, string2 )
char *string1, *string2 ;
{
char *pntr1, *pntr2 ;
for ( pntr1 = string1, pntr2 = string2 ; *pntr1 != NULL; pntr1++ ) {
if ( *pntr1 == *pntr2 ) {
pntr2++ ;
if ( *pntr2 == NULL ) return( pntr1 - strlen(string2) + 1 ) ;
}
else pntr2 = string2 ;
}
/* failure if control reaches this point */
return( NULL ) ;
}
/* function STRTOKP
Like Strtok, except that the original string is preserved (strtok
puts null in there to terminate the substrings). This routine
uses mallocs to allow storage for the token. The memory is
reallocated for each new string. Use just like strtok:
Successively returns the tokens in string1, using the delimeters
defined by string2. If string1 is NULL (a NULL pointer) the
routine returns the next token in the string from the previous call.
Otherwise the first token is returned. A NULL pointer is returned
on failure (no more tokens in the current string).
*/
char *strtokp( string1, string2 )
char *string1, *string2 ;
{
static char *spntr, *tpntr, *token ;
static int called = NULL ; /* called=NULL ==> initialize */
int i ;
/* initialize on first call */
if ( called == NULL ) {
called = 1 ;
GET_MEM( token, strlen(string1) ) ;
}
/* if string1 is not NULL reset the routine */
if ( string1 != NULL ) {
spntr = string1 ;
if ( NULL == ( token = realloc( token, strlen(string1)+1 )))
abort("STRTOKP: reallocation error") ;
}
if ( *spntr == NULL ) return( NULL ) ; /* end of original string */
/* skip initial delimeter characters */
for (; NULL != strchr( string2, *spntr ); spntr++ ) ;
/* copy characters to token until the next delimeter */
tpntr = &token[0] ;
for (; *spntr != NULL; spntr++ ) {
if ( NULL != strchr( string2, *spntr ) ) break ;
*tpntr = *spntr ;
tpntr++ ;
}
*tpntr = NULL ;
/* return result to caller */
if ( token[0] == NULL ) return( NULL ) ;
return( &token[0] ) ;
}
/* strupr: convert a string to upper case.
*/
char *strupr( string )
char *string ;
{
int i ;
for ( i=0; i<strlen( string ); i++ )
if ( string[i] > 96 && string[i] < 123 ) string[i] -= 32 ;
return( string ) ;
}
/* Tokenize
*
* Break out arguments from a string. Pntr is the argument string
* and tokens is an array of pointers which will be assigned memory and have
* the arguments returned. The function returns the number of arguments
* found. Pairwise characters are monitored to ensure that expressions
* are sexually balanced. Unused parm pointers are returned NULL.
* MAX_TOKENS determines the dimension of the array of pointers.
* Commas are the only delimiters allowed to distinquish tokens.
*/
int tokenize( pntr, tokens )
char *pntr, *tokens[] ;
{
int square = 0, curl = 0, parens = 0, apost = 1, quote = 1 ;
int i, j, quit ;
char *text, *txt ;
/* clear the pointers and make a copy of the string */
for ( i=0; i<MAX_TOKENS; i++ ) tokens[i] = NULL ;
GET_MEM( text, strlen(pntr) ) ;
strcpy( text, pntr ) ;
for ( i=0, j=0, quit=FALSE, txt=text; quit==FALSE; j++ ) {
switch( text[j] ) {
case '[' : square += 1 ; break ;
case ']' : square -= 1 ; break ;
case '{' : curl += 1 ; break ;
case '}' : curl -= 1 ; break ;
case '(' : parens += 1 ; break ;
case ')' : parens -= 1 ; break ;
case '\'' : apost = -apost; break ;
case '\"' : quote = -quote; break ;
case NULL :
GET_MEM( tokens[i], strlen(txt) ) ;
strcpy( tokens[i], txt ) ;
quit = TRUE ;
break ;
case ',' : if (!square && !curl && !parens &&(apost==1)&&(quote==1)){
text[j] = NULL ;
GET_MEM( tokens[i], strlen(txt) ) ;
strcpy( tokens[i], txt ) ;
i += 1 ;
txt = &text[j+1] ;
}
}
}
free( text ) ;
return( i+1 ) ;
}
@//E*O*F misc.c//
chmod u=rw,g=r,o=r misc.c
echo x - prep.h
sed 's/^@//' > "prep.h" <<'@//E*O*F prep.h//'
#include "stdio.h"
#include "string.h"
/* define C compiler here */
#define CRAY 0 /* Cray C 1.0 under CTSS */
#define SVS 0 /* Silicon Valley C */
#define BLANK ' '
#define TAB '\t'
#define TRUE 1
#define FALSE 0
#define NOT !
#define DEF_UNROLL_DEPTH 8
#define DEF_LINE_LIMIT 1
#define DEF_BUFFSIZE 200
#define STORE_SIZE 1000
#define NESTING 10
#define MAX_TOKENS 2*NESTING /* tokens and macro args */
#define exp expression /* used exp as a variable */
#define min(x,y) ((x) < (y) ? (x) : (y))
#define max(x,y) ((x) > (y) ? (x) : (y))
#define IN_BUFF_DONE in_buff[0] = NULL ;
#define UNROLLING ( ( unroll_depth > 1 ) && \
( mem_count <= line_limit ) && \
( var_count > 1 ) )
#define GET_MEM(S,A)\
if ( NULL == (S = malloc(A+1)) ) {\
abort( "Memory allocation failed") ; }
#define MATCH(S) ( strncmp( combuff, S, (name_length=strlen(S)) ) == 0 )
#define put_string(s) fputs( s, out ) ; putc( '\n', out ) ;
/* enumeration of command types */
enum Command {
type_begin, type_again, type_while, type_until, type_leave, type_continue,
type_case, type_of, type_default, type_end_case, type_continue_case,
type_do_limits, type_osqb, type_csqb, type_vec, type_unroll,
type_do, type_end_do, type_leave_do, type_continue_do,
type_include,
type_ifdef, type_ifndef, type_else, type_endif,
normal, unknown
} ;
#if CRAY
/* the cray considers characters to be unsigned */
#undef EOF
#define EOF 255
/* a few macros to adapt to cray namelength limitations */
#define continue_proc cont_proc
#define continue_do_proc cont_do_proc
#define leave_do_proc le_do_proc
#define include_proc inc_proc
#endif
#if SVS
#define fopen fopena /* cr-lf and ^Z conversion */
#endif
/* function type declarations */
char *mat_del(), *line_end(), *get_rec(), get_a_char(),
*malloc(), *calloc(), *realloc(), *strtokp(),
*mac_proc(), *strupr(), *strtok(), *strchrq() ;
#ifdef MAIN
/* Included stuff for main routine of program PREP */
/* global pointers & storage */
char *in_buff, *out_buff ; /* text buffer pointers */
char *first_nonblank ; /* first nb char in in_buff */
char *mem_store[STORE_SIZE] ; /* pointers to malloc areas */
char errline[2*DEF_BUFFSIZE] ; /* error message line */
char dataf[DEF_BUFFSIZE] ; /* data file name */
long allocation ; /* current size of in_buff */
int tab_size = 7 ; /* size of the tab in blanks */
int unroll_depth = 0 ; /* do loop unroll depth, 0 for no unrolling */
int line_limit = 1000 ; /* unroll loops if # lines <= line_limit */
int mem_count = 0 ; /* mem_store external counter */
int include_count = 0 ; /* index of filestack (for includes) */
int name_length = 0 ; /* current command name length */
int vec_flag = FALSE ; /* TRUE if in vector loop */
int com_keep = FALSE ; /* TRUE to keep comments */
int underline_keep=FALSE; /* TRUE to keep underline characters */
int macro_only = FALSE ; /* TRUE to do only macro expansion */
int ignore_flag = FALSE ; /* conditional compilation flag */
FILE *in, *out, *filestack[NESTING] ;
#else
/* Header stuff for the functions of program PREP */
/* global pointers & storage */
extern char *in_buff, *out_buff, *mem_store[],
*first_nonblank, dataf[], errline[] ;
extern int tab_size, unroll_depth, line_limit, com_keep, vec_flag,
mem_count, underline_keep, include_count, macro_only,
name_length, ignore_flag ;
extern long allocation ;
extern FILE *in, *out, *filestack[] ;
#endif
@//E*O*F prep.h//
chmod u=rw,g=r,o=r prep.h
echo x - string.h
sed 's/^@//' > "string.h" <<'@//E*O*F string.h//'
/* @(#)strings.h 1.1 85/12/18 SMI; from UCB 4.1 83/05/26 */
/*
* External function definitions
* for routines described in string(3).
*/
char *strcat();
char *strncat();
int strcmp();
int strncmp();
char *strcpy();
char *strncpy();
int strlen();
char *index();
char *rindex();
char *strchr();
int strspn();
int strcspn();
@//E*O*F string.h//
chmod u=rw,g=r,o=r string.h
exit 0