prove@batcomputer.tn.cornell.edu (Roger Ove) (12/16/86)
# 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 newton!ove on Mon Dec 15 21:11:16 CST 1986
# Contents: flow.c misc.c fix.h macro.h prep.h prepdf.h prepmac.h string.h
# vecdem.h demo.p sieve.p vecdem.p vecdemo.p
echo x - flow.c
sed 's/^@//' > "flow.c" <<'@//E*O*F flow.c//'
/* Flow control extensions and related routines */
#include "prep.h"
/* Function AGAIN_PROC
*
* Process again statements.
* 3/2/86
*/
again_proc()
{
/* on missing begin statement, abort */
if ( begin_count <= 0 ) {
sprintf( errline, "Again: no matching begin: %s", in_buff ) ;
abort( errline ) ;
}
/* construct the goto statement back to begin */
sprintf( out_buff, " goto %s", blabel[begin_count] ) ;
dump( out_buff ) ;
/* construct label statement */
sprintf( out_buff, "%s continue", alabel[begin_count] ) ;
dump( out_buff ) ;
begin_count-- ;
IN_BUFF_DONE
}
/* Function BEGIN_PROC.C
*
* Process begin statements. Construct a label for the
* while, until, and again statements to branch to. The
* label for again is created here as well.
*
* P. R. OVE 3/2/86
*/
begin_proc()
{
int count ;
/* keep track of the nesting */
begin_count++ ;
if ( begin_count >= NESTING ) {
sprintf( errline, "Begin: nesting too deep: %s", in_buff ) ;
abort( errline ) ;
}
/* make up a label (for begin) and store it in blabel[begin_count] */
count = 17500 + blabel_count ;
blabel_count++ ;
if ( count > 19999 ) {
sprintf( errline, "Begin: too many labels: %s", in_buff ) ;
abort( errline ) ;
}
sprintf( blabel[begin_count], "%d", count ) ;
/* make up a label (for again) and store it in alabel[begin_count] */
count = 15000 + alabel_count ;
alabel_count++ ;
if ( count > 17499 ) {
sprintf( errline, "Begin: too many labels: %s", in_buff ) ;
abort( errline ) ;
}
sprintf( alabel[begin_count], "%d", count ) ;
/* construct and dump the output record */
sprintf( out_buff, "%s continue", blabel[begin_count] ) ;
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function CASE_PROC
*
* Process again statements.
* 11/9/85
*/
case_proc()
{
int n, count ;
char *open_parens, *close_parens ;
/* get the comparison expression */
open_parens = line_end( first_nonblank + name_length ) ;
close_parens = mat_del( open_parens ) ;
/* if char after case is not a blank, tab, or delimeter assume a */
/* variable name beginning with case */
if ((close_parens == NULL) & (open_parens == first_nonblank + name_length))
return ;
/* keep track of the nesting */
case_count++ ;
if ( case_count >= NESTING ) {
sprintf( errline, "Case: nesting too deep: %s", in_buff ) ;
abort( errline ) ;
}
/* get logical expression, set to NULL if it is missing */
if ( open_parens == NULL ) {
case_exp[ case_count ][0] = NULL ;
}
else {
if ( close_parens == NULL ) {
sprintf( errline, "Case: missing delimeter: %s", in_buff ) ;
abort( errline ) ;
}
n = close_parens - open_parens - 1 ;
GET_MEM( case_exp[case_count], n+5 ) ;
case_exp[case_count][0] = '(' ;
strncpy( case_exp[case_count] + 1, open_parens + 1, n ) ;
case_exp[case_count][n+1] = ')' ;
case_exp[case_count][n+2] = NULL ;
}
/* make label for continue to return to, store it in clabel[case_count] */
count = 20000 + clabel_count ;
clabel_count++ ;
if ( count > 22499 ) {
sprintf( errline, "Case: too many labels: %s", in_buff ) ;
abort( errline ) ;
}
sprintf( clabel[case_count], "%d", count ) ;
/* construct and dump the output record */
sprintf( out_buff, "%s continue", clabel[case_count] ) ;
dump( out_buff ) ;
/* signal that in_buff is empty */
IN_BUFF_DONE
}
/* Function CONTINUE_CASE_PROC
*
* Process continue_case statements (part of case construct).
*
* P. R. OVE 10/10/86
*/
continue_case_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
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 */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
/* on missing case statement, abort */
if ( case_count <= 0 ) {
sprintf( errline, "CONTINUE_CASE: no matching CASE: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression if there is one */
if (open_parens != NULL) {
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
}
/* construct and dump the jump back to the case statement */
if (open_parens != NULL) {
strcpy( out_buff, " if " ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, " goto " ) ;
strcat( out_buff, clabel[case_count] ) ;
free( exp ) ;
}
else {
strcpy( out_buff, " goto " ) ;
strcat( out_buff, clabel[case_count] ) ;
}
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function CONTINUE_DO_PROC
*
* Process continue_do statements (part of do/end_do construct).
*
* P. R. OVE 11/13/86
*/
continue_do_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
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 CONTINUE_DOit */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
/* on missing do statement, abort */
if ( do_count <= 0 ) {
sprintf( errline, "CONTINUE_DO: not in do/end_do loop: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression if there is one */
if (open_parens != NULL) {
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
}
/* construct and dump the jump to the end_do label */
if (open_parens != NULL) {
strcpy( out_buff, " if " ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, " goto " ) ;
strcat( out_buff, dlabel[do_count] ) ;
free( exp ) ;
}
else {
strcpy( out_buff, " goto " ) ;
strcat( out_buff, dlabel[do_count] ) ;
}
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function CONTINUE_PROC
*
* Process continue statements (part of begin construct).
*
* P. R. OVE 10/10/86
*/
continue_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
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 CONTINUEit */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
/* on missing begin statement, abort */
if ( begin_count <= 0 ) {
sprintf( errline, "CONTINUE: no matching BEGIN: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression if there is one */
if (open_parens != NULL) {
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
}
/* construct and dump the back to the begin statement */
if (open_parens != NULL) {
strcpy( out_buff, " if " ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, " goto " ) ;
strcat( out_buff, blabel[begin_count] ) ;
free( exp ) ;
}
else {
strcpy( out_buff, " goto " ) ;
strcat( out_buff, blabel[begin_count] ) ;
}
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function DEFAULT_PROC
*
* Process default statements.
*
* P. R. OVE 11/9/85
*/
default_proc()
{
char *pntr ;
if ( case_count <= 0 ) {
sprintf( errline, "DEFAULT: no matching CASE: %s", in_buff ) ;
abort( errline ) ;
}
dump( " else" ) ;
/* eliminate "default" from the input buffer */
pntr = line_end( first_nonblank + name_length ) ;
if ( pntr != NULL ) {
strcpy( in_buff, "\t" ) ;
strcat( in_buff, pntr ) ;
}
else { IN_BUFF_DONE }
}
/* Function DO_PROC
*
* Process do statements. If there is a label (ala
* fortran) just dump it to the output. If no label
* exists make one up in anticipation of an eventual
* end_do statement.
*
* P. R. OVE 11/9/85
*/
do_proc()
{
char *after_do, *pntr ;
int count ;
/* return without processing if the first nonblank char after DO is a label
or if there is no blank/tab after the DO */
pntr = first_nonblank + name_length ;
after_do = line_end( pntr ) ;
if ( ( strchr( "0123456789", *after_do ) != NULL ) |
( after_do == pntr ) ) return ;
/* keep track of the nesting */
do_count++ ;
if ( do_count >= NESTING ) {
sprintf( errline, "DO: nesting too deep: %s", in_buff ) ;
abort( errline ) ;
}
/* make up a label and store it in dlabel[do_count] */
count = 12500 + dlabel_count ;
dlabel_count++ ;
if ( count > 14999 ) {
sprintf( errline, "DO: too many labels: %s", in_buff ) ;
abort( errline ) ;
}
sprintf( dlabel[do_count], "%d", count ) ;
/* make label for leave_do to jump to and store it in elabel[do_count] */
count = 22500 + elabel_count ;
elabel_count++ ;
if ( count > 24999 ) {
sprintf( errline, "DO: too many labels: %s", in_buff ) ;
abort( errline ) ;
}
sprintf( elabel[do_count], "%d", count ) ;
/* construct and dump the output record */
sprintf( out_buff, " do %s %s", dlabel[do_count], after_do ) ;
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function END_CASE_PROC
*
* Process end_case statements.
*
* P. R. OVE 11/9/85
*/
end_case_proc()
{
of_count[ case_count ] = 0 ;
free( case_exp[ case_count ] ) ;
case_count-- ;
IN_BUFF_DONE
if ( case_count < 0 ) {
case_count = 0 ;
return ; }
dump( " end if" ) ;
}
/* Function END_DO_PROC
*
* Process end_do statements. Use the label indexed
* by the current value of do_count (the do nesting
* index).
*
* P. R. OVE 11/9/85
*/
end_do_proc()
{
/* signal error if no matching do has been found */
if ( do_count <= 0 ) {
sprintf( errline, "END_DO: no matching do: %s", in_buff ) ;
abort( errline ) ;
}
/* construct and dump the normal do loop continue statement */
sprintf( out_buff, "%s continue", dlabel[do_count] ) ;
dump( out_buff ) ;
/* construct and dump the leave_do label if needed */
if ( leave_do_flag[do_count] == TRUE ) {
sprintf( out_buff, "%s continue", elabel[do_count] ) ;
dump( out_buff ) ;
leave_do_flag[do_count] = FALSE ;
}
do_count -= 1 ;
IN_BUFF_DONE
}
/* Function LEAVE_DO_PROC
*
* Process leave_do statements.
*
* P. R. OVE 3/2/86
*/
leave_do_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
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 LEAVE_DOit */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
/* on missing do statement, abort */
if ( do_count <= 0 ) {
sprintf( errline, "LEAVE_DO: not in do/end_do loop: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression if there is one */
if (open_parens != NULL) {
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
}
/* construct and dump the jump out of the loop */
if (open_parens != NULL) {
strcpy( out_buff, " if " ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, " goto " ) ;
strcat( out_buff, elabel[do_count] ) ;
free( exp ) ;
}
else {
strcpy( out_buff, " goto " ) ;
strcat( out_buff, elabel[do_count] ) ;
}
leave_do_flag[do_count] = TRUE ;
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function LEAVE_PROC
*
* Process leave statements.
*
* P. R. OVE 3/2/86
*/
leave_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
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 LEAVEit */
if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
/* on missing begin statement, abort */
if ( begin_count <= 0 ) {
sprintf( errline, "LEAVE: no matching begin: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression if there is one */
if (open_parens != NULL) {
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
}
/* construct and dump the jump to again */
if (open_parens != NULL) {
strcpy( out_buff, " if " ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, " goto " ) ;
strcat( out_buff, alabel[begin_count] ) ;
free( exp ) ;
}
else {
strcpy( out_buff, " goto " ) ;
strcat( out_buff, alabel[begin_count] ) ;
}
dump( out_buff ) ;
IN_BUFF_DONE
}
/* Function OF_PROC
*
* Process of statements.
*
* P. R. OVE 11/9/85
*/
of_proc()
{
int n ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
open_parens = line_end( first_nonblank + name_length) ;
close_parens = mat_del( open_parens ) ;
/* if no open parens assume variable name like OFile */
/* (no open parens <==> close_parens will be NULL) */
if ( close_parens == NULL ) return ;
/* abort on missing case statement */
if ( case_count <= 0 ) {
sprintf( errline, "OF: missing CASE statement: %s", in_buff ) ;
abort( errline ) ;
}
/* keep track of "of's" for each case level */
of_count[ case_count ] += 1 ;
/* get the logical expression */
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
/* construct the "if" or "if else" statement. If there is a case */
/* logical expression us .eq. to determine the result */
if ( case_exp[ case_count ][0] == NULL ) {
if ( of_count[ case_count ] != 1 ) {
strcpy( out_buff, " else if " ) ; }
else {
strcpy( out_buff, " if " ) ; }
strcat( out_buff, exp ) ;
strcat( out_buff, " then " ) ; }
else {
if ( of_count[ case_count ] != 1 ) {
strcpy( out_buff, " else if (" ) ; }
else {
strcpy( out_buff, " if (" ) ; }
strcat( out_buff, case_exp[ case_count ] ) ;
strcat( out_buff, ".eq." ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, ") then " ) ; }
dump( out_buff ) ;
/* eliminate "of stuff" from the input buffer */
pntr = line_end( close_parens + 1 ) ;
if ( pntr != NULL ) {
strcpy( in_buff, "\t" ) ;
strcat( in_buff, pntr ) ;
}
else { IN_BUFF_DONE }
free( exp ) ;
}
/* Function UNTIL_PROC
*
* Process until statements.
*
* P. R. OVE 3/2/86
*/
until_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
open_parens = line_end( first_nonblank + name_length ) ;
close_parens = mat_del( open_parens ) ;
/* if no open parens assume variable name like UNTILon */
/* (no open parens <==> close_parens will be NULL) */
if ( close_parens == NULL ) return ;
/* on missing begin statement, abort */
if ( begin_count <= 0 ) {
sprintf( errline, "UNTIL: no matching begin: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression */
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
/* construct and dump the conditional jump to begin */
sprintf( out_buff, " if (.not.%s) goto %s",
exp, blabel[begin_count] ) ;
dump( out_buff ) ;
/* construct a label statement (for leave to jump to) */
sprintf( out_buff, "%s continue", alabel[begin_count] ) ;
dump( out_buff ) ;
begin_count-- ;
free( exp ) ;
IN_BUFF_DONE
}
/* Function WHILE_PROC
*
* Process while statements.
*
* P. R. OVE 3/2/86
*/
while_proc()
{
int n, count ;
char *pntr, *open_parens, *close_parens ;
/* get the comparison expression */
open_parens = line_end( first_nonblank + name_length ) ;
close_parens = mat_del( open_parens ) ;
/* if no open parens assume variable name like WHILEon */
/* (no open parens <==> close_parens will be NULL) */
if ( close_parens == NULL ) return ;
/* on missing begin statement, abort */
if ( begin_count <= 0 ) {
sprintf( errline, "WHILE: no matching begin: %s", in_buff ) ;
abort( errline ) ;
}
/* get the logical expression */
n = close_parens - open_parens - 1 ;
GET_MEM( exp, n+5 ) ;
exp[0] = '(' ;
strncpy( exp + 1, open_parens + 1, n ) ;
exp[n+1] = ')' ;
exp[n+2] = NULL ;
/* construct and dump the output record */
strcpy( out_buff, " if (.not." ) ;
strcat( out_buff, exp ) ;
strcat( out_buff, ") goto " ) ;
strcat( out_buff, alabel[begin_count] ) ;
dump( out_buff ) ;
free( exp ) ;
IN_BUFF_DONE
}
@//E*O*F flow.c//
chmod u=rw,g=r,o=r flow.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 ) {
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 == realloc( in_buff, allocation ) )
abort( "Reallocation failed" ) ;
if ( NULL == realloc( out_buff, 4*allocation ) )
abort( "Reallocation failed" ) ;
}
}
/* Include_proc
*
* Handle file inclusion
*
* P. R. OVE 11/9/85
*/
include_proc()
{
char *pntr, *open_parens, *close_parens, *name ;
/* get the file name */
open_parens = line_end( first_nonblank + name_length ) ;
if ( NULL == ( close_parens = mat_del( open_parens ) ) ) {
sprintf( errline, "INCLUDE: syntax: %s", in_buff ) ;
abort( errline ) ;
}
name = open_parens+1 ;
*close_parens = NULL ;
/* push the old input file handle onto the filestack */
if ( NULL == pushfile(&in) ) {
sprintf( errline, "INCLUDE: nesting too deep: %s", in_buff ) ;
abort( errline ) ;
}
/* open the new file */
if ( NULL == ( in = fopen( name, "r" ) ) ) {
sprintf( errline, "INCLUDE: can't open file: %s", name ) ;
abort( errline ) ;
}
IN_BUFF_DONE ;
}
/* push a file handle onto the filestack. return NULL on error. */
int pushfile(handleaddress)
FILE *(*handleaddress) ;
{
if ( include_count >= NESTING ) return(NULL) ;
filestack[include_count] = *handleaddress ;
include_count++ ;
return(1) ;
}
/* pop a file handle from the filestack. return NULL on error */
int popfile(handleaddress)
FILE *(*handleaddress) ;
{
if ( include_count <= 0 ) return(NULL) ;
include_count-- ;
*handleaddress = filestack[include_count] ;
return(1) ;
}
/* 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 */
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' : com_keep = TRUE ; break ;
case 'u' : underline_keep = TRUE ; break ;
case 'U' : 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' : 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' : macro_only = TRUE ;
underline_keep = TRUE ;
com_keep = TRUE ;
break ;
case 'i' : i++ ;
if ( i < argc ) {
sprintf(in_buff,"#include \"%s\"", argv[i] ) ;
break ;
}
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",
" -c keep comments",
" -u keep underline characters",
" -m expand macros only",
" -i <file> include <file> before processing",
" -U n unroll vector loops to depth n",
" -L n unroll loops with n or fewer lines only"
) ;
abort( "\n" ) ;
}
}
}
/* process the file include statement if present */
if ( IN_BUFF_FULL ) preproc( rec_type(0) ) ;
return(1) ;
}
/* 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
* MACRO expansion
*
* P. R. OVE 11/9/85
*/
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 ;
}
}
/* 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 ) ;
}
}
/* 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(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 */
case 0 : {
if ( MATCH( "#INCLUDE" ) ) return(type_include) ;
return(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(type_of) ;
if ( MATCH( "DEFAULT" ) ) return(type_default) ;
return(unknown) ;
}
/* group 2 commands: flow control extensions and parameter changes */
case 2 : {
if ( MATCH( "DO_LIMITS" ) ) return(type_do_limits) ;
if ( MATCH( "DO LIMITS" ) ) return(type_do_limits) ;
if ( MATCH( "DO" ) ) return(type_do) ;
if ( MATCH( "END_DO" ) ) return(type_end_do) ;
if ( MATCH( "END DO" ) ) return(type_end_do) ;
if ( MATCH( "LEAVE_DO" ) ) return(type_leave_do) ;
if ( MATCH( "LEAVE DO" ) ) return(type_leave_do) ;
if ( MATCH( "CONTINUE_DO")) return(type_continue_do) ;
if ( MATCH( "CONTINUE DO")) return(type_continue_do) ;
if ( MATCH( "CASE" ) ) return(type_case) ;
if ( MATCH( "END_CASE" ) ) return(type_end_case) ;
if ( MATCH( "END CASE" ) ) return(type_end_case) ;
if (MATCH("CONTINUE_CASE")) return(type_continue_case) ;
if (MATCH("CONTINUE CASE")) return(type_continue_case) ;
if ( MATCH( "BEGIN" ) ) return(type_begin) ;
if ( MATCH( "AGAIN" ) ) return(type_again) ;
if ( MATCH( "WHILE" ) ) return(type_while) ;
if ( MATCH( "UNTIL" ) ) return(type_until) ;
if ( MATCH( "LEAVE" ) ) return(type_leave) ;
if ( MATCH( "CONTINUE" ) ) return(type_continue) ;
if ( MATCH( "UNROLL" ) ) return(type_unroll) ;
return(unknown) ;
}
/* group 3 commands: vector processing */
case 3: {
if ( MATCH( "[" ) ) return(type_osqb) ;
if ( strchrq( string, ']' ) != NULL ) return(type_csqb) ;
if ( strchrq( string, '#' ) != NULL ) return(type_vec) ;
return(normal) ;
}
} /* end switch case */
}
/* 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.
*/
#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 - fix.h
sed 's/^@//' > "fix.h" <<'@//E*O*F fix.h//'
: .eq. ==; file for imbedding a few macros in a fortran program
: .ge. >=;
: .gt. >; to use do: prep -m -i fix.h <file >output
: .lt. <;
: .le. <=;
: .ne. !=;
: ** ^;
: .and. &;
: .or. |;
: .not. !;
: .true. TRUE;
: .false. FALSE;
@//E*O*F fix.h//
chmod u=rw,g=r,o=r fix.h
echo x - macro.h
sed 's/^@//' > "macro.h" <<'@//E*O*F macro.h//'
/* macro related stuff */
#include "prep.h"
#define MAX_MACROS 1000
#define MAX_CALLS 100 /* if exceeded, assume recursive */
/* macro structure */
struct mac {
char *name ;
char *text ;
int parmcount ;
int callcount ;
} macro[MAX_MACROS], *macrop ;
int defined_macros = 0 ; /* number of defined macros */
/* function types */
char *expand_macros(), *mac_expand(), *strmatch() ;
int define_macro() ;
@//E*O*F macro.h//
chmod u=rw,g=r,o=r macro.h
echo x - prep.h
sed 's/^@//' > "prep.h" <<'@//E*O*F prep.h//'
#ifdef MAIN
/*
Included stuff for main routine of program PREP
*/
#include "stdio.h"
#include "string.h"
#include "prepdf.h"
/* global pointers & storage */
char *in_buff, *out_buff ; /* text buffer pointers */
char *phys_ibuff ; /* physical input buffer */
char *phys_obuff ; /* physical output buffer */
char *mem_store[STORE_SIZE] ; /* pointers to malloc areas */
char *initial_name[NESTING] ; /* do loop initial values */
char *limit_name[NESTING] ; /* do loop limits */
char *increment_name[NESTING] ; /* do loop increments */
char *case_exp[NESTING] ; /* case expression storage */
char *exp ; /* general expression storage pointer */
char *first_nonblank ; /* first nb char in in_buff */
char label[NESTING][6] ; /* label storage (vector loops) */
char alabel[NESTING][6] ; /* again label storage */
char blabel[NESTING][6] ; /* begin label storage */
char clabel[NESTING][6] ; /* case label storage */
char dlabel[NESTING][6] ; /* do/end_do label storage */
char elabel[NESTING][6] ; /* leave_do label storage */
char var_name[NESTING][6] ; /* do counter names */
char dataf[DEF_BUFFSIZE] ; /* data file name */
char errline[2*DEF_BUFFSIZE] ; /* error message line */
long allocation ; /* current size of in_buff */
int of_count[NESTING] ; /* counters for of statements */
int leave_do_flag[NESTING] ; /* marks if leave_do in current loop */
int var_count = 0 ; /* number of variables used in do loops */
int label_count = 0 ; /* label = label_count + 10000 */
int alabel_count = 0 ; /* alabel = alabel_count + 15000 */
int blabel_count = 0 ; /* blabel = blabel_count + 17500 */
int clabel_count = 0 ; /* clabel = clabel_count + 20000 */
int dlabel_count = 0 ; /* dlabel = dlabel_count + 12500 */
int elabel_count = 0 ; /* elabel = elabel_count + 22500 */
int do_count = 0 ; /* nesting counter for do/end_do */
int begin_count = 0 ; /* nesting counter for begin ... loops */
int case_count = 0 ; /* case nesting level */
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 */
FILE *in, *out, *filestack[NESTING] ;
/* function declarations */
char *get_rec(), *mac_proc(), *malloc(), *realloc() ;
#else
/* Header file for the functions of program PREP */
#include "stdio.h"
#include "string.h"
#include "prepdf.h"
/* global pointers & storage */
extern char *in_buff, *out_buff, *phys_ibuff, *phys_obuff,
*mem_store[],
*initial_name[], *limit_name[], *increment_name[],
*case_exp[], *exp, *first_nonblank,
label[][6],
alabel[][6], blabel[][6], clabel[][6], dlabel[][6], elabel[][6],
var_name[][6],
dataf[], errline[] ;
extern int var_count, tab_size, unroll_depth, line_limit,
com_keep, vec_flag, label_count,
alabel_count, blabel_count, clabel_count,
dlabel_count, elabel_count,
case_count, of_count[], do_count, begin_count,
mem_count, underline_keep, include_count, macro_only,
name_length, leave_do_flag[] ;
extern long allocation ;
extern FILE *in, *out, *filestack[] ;
/* function type declarations */
char *mat_del(), *line_end(), *get_rec(), get_a_char(),
*malloc(), *calloc(), *realloc(), *strtokp(),
*mac_proc(), *strupr() ;
#endif
@//E*O*F prep.h//
chmod u=rw,g=r,o=r prep.h
echo x - prepdf.h
sed 's/^@//' > "prepdf.h" <<'@//E*O*F prepdf.h//'
/* #define CRAY 1 */
#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 PHYS_IBUFF_SIZE 10000
#define PHYS_OBUFF_SIZE 0 /* not used, uses sys output buffer */
#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 IN_BUFF_DONE in_buff[0] = NULL ;
#define IN_BUFF_FULL line_end( in_buff ) != 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, by hand because of svs c enum bug */
#define type_begin 0
#define type_again 1
#define type_while 2
#define type_until 3
#define type_leave 4
#define type_case 5
#define type_of 6
#define type_default 7
#define type_end_case 8
#define type_do_limits 9
#define type_do 10
#define type_end_do 11
#define type_osqb 12
#define type_csqb 13
#define type_vec 14
#define type_unroll 15
#define type_continue 16
#define type_leave_do 17
#define type_continue_do 18
#define type_continue_case 19
#define normal 20
#define type_include 21
#define unknown 22
#ifdef 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
@//E*O*F prepdf.h//
chmod u=rw,g=r,o=r prepdf.h
echo x - prepmac.h
sed 's/^@//' > "prepmac.h" <<'@//E*O*F prepmac.h//'
c Some standard macros for prep.
c logical stuff
: == .eq. ;
: >= .ge. ;
: > .gt. ;
: < .lt. ;
: <= .le. ;
: != .ne. ;
: <> .ne. ;
: ! .not. ;
: | .or. ;
: & .and. ;
: TRUE .true. ;
: FALSE .false. ;
: ^ ** ;
c flow control redefinitions
: enddo end_do ;
: ->begin continue ;
: ->case continue_case ;
: ->do continue_do ;
@//E*O*F prepmac.h//
chmod u=rw,g=r,o=r prepmac.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
echo x - vecdem.h
sed 's/^@//' > "vecdem.h" <<'@//E*O*F vecdem.h//'
c macros defs for vec demo
#include "prepmac.h"
: XLIM 81 ; hard dimensions of arrays are from 0 --> ?lim
: YLIM 81 ;
: SCRNX 320 ; geodesic drawing screen dimensions
: SCRNY 200 ;
: PHOTONS 64 ; number of photons
: SMALL 1.e-20 ;
: BIG 1.e+20 ;
: include(x) use x ; cray specific file include
: PERIODIC(x) call periodic( mx, my, x ) ;
c default do limits
do_limits = [ (XLIM-1), (YLIM-1) ]
@//E*O*F vecdem.h//
chmod u=rw,g=r,o=r vecdem.h
echo x - demo.p
sed 's/^@//' > "demo.p" <<'@//E*O*F demo.p//'
c Demo code segment to illustrate some PREP facilities. This is
c just a preprocessor demo and will not compile without adding
c a lot of variable declarations.
#include "prepmac.h"
c flag to call alternate window filler if window size = array size
: PIXIE_FLAG (((xpix1-xpix0+1) == nrows) & ((ypix1-ypix0+1) == ncols))) ;
include 'tencomn'
c open the input data file and initialize the device
call init
c skip over skip0 data sets
call skipdat( skip0 )
if (eoflag) call exodus
c enter the menu
call menu
c read data tables from the input file and plot until empty
begin
c clear the record numbers
do j = 1, 10
record( j ) = 0
end_do
do j = 1, 10
icount = j
call getdat
record( icount ) = first_record
leave_do (eoflag)
c on first dataset of a group reset background
if ( icount .eq. 1 ) then
call vsbcol(dev, backcol)
call vclrwk(dev)
end if
c weed the data to make it fit in the window
call compact
c clear a window and label it
call windower
c Plot the data table , 1st arg is absolute first dim of buffer
if ( PIXIE_FLAG ) then
call pixie( HARD_X_DIM, nrows, ncols,
* xpix0, PHYS_HEIGHT - 1 - ypix1,
* buffer )
else
call winfill( HARD_X_DIM, nrows, ncols,
* xpix0, xpix1,
* PHYS_HEIGHT - 1 - ypix1,
* PHYS_HEIGHT - 1 - ypix0,
* buffer )
end if
c see if the user is tired and wants to quit
status = vsmstr( dev, ten, zero, echoxy, dummy)
if ( status .gt. 0 ) then
case [ upper( dummy(1:1) ) ]
of ( 'Q' ) call exodus
of ( 'R' ) leave_do
of ( 'B' ) leave_do
end_case
end if
end_do
c skip over skip data sets
call skipdat( skip )
c Delay and wait for keystroke. Quit on Q,q; continue on cr; enlarge
c on keys 1,2,3,...9,0 (0 --> 10); make a dump file on D, d.
c If in movie mode, skip this input section, make a dump, and continue
if ( movie_mode ) then
if (eoflag) call exodus
call dump
else
c stay in this loop if end of file has been reached.
begin
case ( last_key )
last_key = key(dev)
of ( 'D' ) call dump
continue_case
of ( 'Q' ) call exodus
of ( 'R' ) call restart
of ( 'B' ) call pop( recn )
recn = max0( recn, 1 )
eoflag = .false.
default call push( max0( record(1), 1 ) )
call enlarger
end_case
while ( eoflag )
again
end if
again
c Restore the video mode and turn off the device
call exodus
end
@//E*O*F demo.p//
chmod u=rw,g=r,o=r demo.p
echo x - sieve.p
sed 's/^@//' > "sieve.p" <<'@//E*O*F sieve.p//'
c sieve benchmark in fortran
#include "prepmac.h"
: S 8190 ;
: WHILE(l) begin
while (l) ;
do limits [ (0, S) ]
integer f(S+1), i, p, k, c, n
do n = 1, 10
c = 0
f(#) = 1
[ if ( f(#) != 0 ) then
p = # + # + 3
k = # + p
WHILE ( k <= S )
f(k) = 0
k = k + p
again
c = c + 1
end if
]
enddo
write(*,*) c, ' primes'
stop
end
@//E*O*F sieve.p//
chmod u=rw,g=r,o=r sieve.p
echo x - vecdem.p
sed 's/^@//' > "vecdem.p" <<'@//E*O*F vecdem.p//'
c Demo to demonstrate some PREP facilities. This program is a demo
c only and will not compile without a lot of variable definitions.
#include "vecdem.h"
subroutine w_accel_l(psi, lin_fac, source, omega)
include "ellipdim"
if (w_bypass) return
w_error = FALSE
c Set up the basis consisting of past iterates
[ basis(#,#,1) = psi(#,#)
basis(#,#,2) = psi(#,#) - psi_alt(#,#,1)
basis(#,#,3) = psi(#,#) - 2*psi_alt(#,#,1) + psi_alt(#,#,2)
basis(#,#,4) = 1 ]
PERIODIC( basis1 )
PERIODIC( basis2 )
PERIODIC( basis3 )
PERIODIC( basis4 )
c Calculate the matrix and the source vector
do i = 1, w_dim
ii = i
do j = i, w_dim
jj = j
call make_mat_l(psi, lin_fac, source, omega, i, j)
end_do
end_do
do i = 1, w_dim
w_source(i) = 0
w_source(i) = source(#,#)*basis(#,#,i) + w_source(i)
end_do
c invert the symmetric matrix
call linsys(w_matrix, w_dim, w_dim, w_source, w_coeff, ising, lfirst,
* lprint, work)
if (ising == 1) then
write(*,*) ' WARNING: W_matrix is singular '
w_error = TRUE
return
endif
c calculate the improved solution
psi(#,#) = 0
do i = 1, w_dim
psi(#,#) = psi(#,#) + w_coeff(i)*basis(#,#,i)
end_do
c output section for error checking
do i = 1, w_dim
write(*,100) i, .5*w_matrix(i,i) - w_source(i),
* i, w_coeff(i)
end_do
do_limits = { w_dim }
action = 0
do i = 1, w_dim
action = action + w_matrix(i,#)*w_coeff(i)*w_coeff(#)
end_do
action = action/2
action = action - w_source(#)*w_coeff(#)
write(*,*) ' new action = ',action
return
100 format(' action(',i1')= ',g16.9,' w_coeff(',i1,')= ', g16.9)
end
@//E*O*F vecdem.p//
chmod u=rw,g=r,o=r vecdem.p
echo x - vecdemo.p
sed 's/^@//' > "vecdemo.p" <<'@//E*O*F vecdemo.p//'
c***********************************************************************
c *
c subroutine W_ACCEL_LIN *
c *
c Do the Wachspress accelleration. *
c The solution is expressed as a linear combination of the previous *
c iterate and the lowest order fourier modes and the coefficients *
c are found so as to minimize the error. *
c *
c P.R.OVE 7/6/85 *
c***********************************************************************
subroutine w_accel_l(psi, lin_fac, source, omega)
use ellipdim
do_limits = { mx, my }
if (w_bypass) return
w_error = FALSE
c**********************************************************************
c Set up the basis consisting of past iterates *
c**********************************************************************
[ basis(#,#,1) = psi(#,#)
basis(#,#,2) = psi(#,#) - psi_alt(#,#,1)
basis(#,#,3) = psi(#,#) - 2*psi_alt(#,#,1) + psi_alt(#,#,2)
basis(#,#,4) = 1 ]
call periodic( mx, my, basis1 )
call periodic( mx, my, basis2 )
call periodic( mx, my, basis3 )
call periodic( mx, my, basis4 )
c**********************************************************************
c Calculate the Wachspress matrix and the source vector *
c**********************************************************************
do i = 1, w_dim
ii = i
do j = i, w_dim
jj = j
call make_mat_l(psi, lin_fac, source, omega, i, j)
end_do
end_do
do i = 1, w_dim
w_source(i) = 0
w_source(i) = source(#,#)*basis(#,#,i) + w_source(i)
end_do
c**********************************************************************
c invert the symmetric matrix and improve the solution psi. *
c**********************************************************************
call linsys(w_matrix, w_dim, w_dim, w_source, w_coeff,
* ising, lfirst, lprint, work)
if (ising == 1) then
c write(*,*) ' WARNING: W_matrix is singular '
w_error = TRUE
goto 99
endif
c calculate the improved solution
psi(#,#) = 0
do i = 1, w_dim
psi(#,#) = psi(#,#) + w_coeff(i)*basis(#,#,i)
end_do
c**********************************************************************
c output section for error checking (optional) *
c**********************************************************************
go to 99
do i = 1, w_dim
write(*,100) i, .5*w_matrix(i,i) - w_source(i),
* i, w_coeff(i)
100 format(' action(',i1')= ',g16.9,' w_coeff(',i1,')= ',
* g16.9)
end_do
do_limits = { w_dim }
action = 0
do i = 1, w_dim
action = action + w_matrix(i,#)*w_coeff(i)*w_coeff(#)
end_do
action = action/2
action = action - w_source(#)*w_coeff(#)
write(*,*) ' new action = ',action
99 return
end
@//E*O*F vecdemo.p//
chmod u=rw,g=r,o=r vecdemo.p
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 <<\!!!
750 2967 17527 flow.c
807 3353 18498 misc.c
13 55 243 fix.h
23 65 414 macro.h
97 566 3740 prep.h
74 268 1826 prepdf.h
22 81 326 prepmac.h
18 46 326 string.h
19 80 408 vecdem.h
113 441 3190 demo.p
30 91 402 sieve.p
71 241 1870 vecdem.p
87 316 3336 vecdemo.p
2124 8570 52106 total
!!!
wc flow.c misc.c fix.h macro.h prep.h prepdf.h prepmac.h string.h vecdem.h demo.p sieve.p vecdem.p vecdemo.p | 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