⟦922c36a2e⟧

TextFile

/* 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 ) ;
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦922c36a2e⟧ TextFile

Derivation

TextFile
