silvert@dalcs.UUCP (Bill Silvert) (08/19/88)
Posting-number: Volume 4, Issue 33 Submitted-by: "Bill Silvert" <silvert@dalcs.UUCP> Archive-name: fxref This pair of utilities facilitate Fortran programming. flink generates various displays of the linkages between subprogram units, while fxref constructs a cross reference map. fxref is an update to a program I posted aobut two yeears ago. Warning -- these expect all Fortran expressions to be in upper case. Please don't flame me about this, we write standard Fortran. However, since I have no idea how many group readers use upper case, I haven't made the effort to write a manual -- run the programs and see how they work if you are interested. flink has all kinds of options (type flink -h for a summary), fxref doesn't. They both expect to be fed a list of Fortran source files. You will need lex(1) to create C source code from the *.l files. The only routine needed from -ll is yywrap(), so that is provided -- you can use lex on a Unix system and then compile on any machine with a C compiler. If you don't have lex, I can mail you flink.c and fxrefa.c, but these are BIG files. ------------------------------ cut here -------------------------- #!/bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #!/bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Makefile # flink.l # fxref # fxrefa.l # fxrefb.c # error.c # yywrap.c # This archive created: Fri Aug 19 09:39:42 1988 # By: Bill Silvert (Habitat Ecology Div., Bedford Inst. of Oceanography) export PATH; PATH=/bin:$PATH if test -f 'Makefile' then echo shar: over-writing existing file "'Makefile'" fi cat << \SHAR_EOF > 'Makefile' # makefile for fxref, the f77 xref program from Bourne 8.2.2 CFLAGS = -O all: make fxrefa fxrefb flink flink: flink.c error.o yywrap.o cc -O -o flink flink.c error.o yywrap.o fxrefa: fxrefa.c yywrap.o cc -O -o fxrefa fxrefa.c yywrap.o fxrefb: fxrefb.c cc -O -o fxrefb fxrefb.c flink.c: flink.l lex flink.l mv lex.yy.c flink.c fxrefa.c: fxrefa.l lex fxrefa.l mv lex.yy.c fxrefa.c clean: rm -f flink.c fxrefa.c lex.yy.c Make.rec cd SCCS; sccsclean .. SHAR_EOF if test -f 'flink.l' then echo shar: over-writing existing file "'flink.l'" fi cat << \SHAR_EOF > 'flink.l' /* flink -- f77 call mapper -- from Bourne's C xref, p. 204 */ /* Written by Bill Silvert, August 1988 */ %k 100 %a 1000 %o 1000 %n 200 %e 200 %p 1000 %{ #undef ECHO static char SCCSID[] = "@(#)flink.l Ver. 1.17, 88/08/17 10:11:33"; char *progname, *filename="-"; #define FWORD 8 #define ESIZE 10 #define SKIP 0 #define PROG 1 #define SUBR 2 #define FUNC 3 #define BLKD 4 #define ENTR 5 #define CALL 9 int status = SKIP; /* flags to define level of name */ char *routine[] = { "", "PROGRAM", "SUBROUTINE", "FUNCTION", "BLOCK DATA", "ENTRY", "", "", "", "CALL" }; #define OPTTBL 0 #define OPTCAL 1 #define OPTDEP 2 #define OPTENT 3 #define OPTFIL 4 #define OPTBLK 5 #define OPTUNU 6 #define OPTUNS 7 #define OPTSUB 8 int option = OPTTBL; char *select = NULL; /* name selected as option */ int verbose=1; int entered=0, linked=0; /* initialization flags */ char unit[FWORD]; typedef struct element { char name[FWORD]; char *file; int level; int hit; int class; struct element *next; } ELEMENT; typedef struct matrix { ELEMENT *i; ELEMENT *j; struct matrix *next; } MATRIX; /* arrays for data and pointers -- first element of each array is useless */ ELEMENT entry[ESIZE], *lentry=entry+ESIZE-1, *current, *rec; ELEMENT *newrecord(), *altrecord(), *addrecord(); MATRIX link[ESIZE], *llink=link+ESIZE-1, *index=link; int type[10]; /* how many subprograms of each type? */ main(argc,argv) int argc; char *argv[]; { extern int optind; extern char *optarg; int count, ocount; progname = argv[0]; strcpy(entry->name, "------"); /* safety defaults */ entry->next = NULL; link->next = NULL; for(count=0; count<10; count++) type[count] = 0; while((count = getopt(argc, argv, "bcdefqstuvxC:D:F:h")) != EOF) switch(count) { case 'b': option = OPTBLK; break; case 'C': select = optarg; case 'c': option = OPTCAL; break; case 'D': select = optarg; case 'd': option = OPTDEP; break; case 'e': option = OPTENT; break; case 'F': select = optarg; case 'f': option = OPTFIL; break; case 'q': verbose=0; break; case 's': option = OPTSUB; break; case 't': option = OPTTBL; break; case 'u': option = OPTUNU; break; case 'x': option = OPTUNS; break; case 'v': verbose=2; break; case 'h': default: fprintf(stderr, "%s [-bcdefqtuvx] [-CDF name] file ...\n", progname); fprintf(stderr, "\tb\tBLOCK DATA\n\tc\tCALLs\n\td\tDependencies (reverse of CALLs)\n\te\tENTRY points\n\tf\tFiles in which subprograms occur\n\tq\tQuiet mode\n\tt\tTabular output (default)\n\tu\tUnused subroutines\n\tv\tVerbose mode\n\tx\tunsatisfied eXternals\n\tC name\tCALLs from <name>\n\tD name\tDependencies on <name> (what CALLs it)\n\tF name\tFile in which <name> occurs\n"); exit(1); } if(optind >= argc) { strcpy(unit, "------"); yylex(); if(current && verbose) fprintf(stderr, "Missing END statement at end of %s %s\n", routine[current->class], current->name); } else { for(; optind < argc; optind++) { if(freopen(argv[optind],"r",stdin)==NULL) { fprintf(stderr,"%s: %s: cannot open\n", progname, argv[optind]); } else { filename=argv[optind]; yylineno=1; strcpy(unit, "------"); yylex(); if(current && verbose) { fprintf(stderr, "Missing END statement at end of %s %s in file %s\n", routine[current->class], current->name, filename); current = NULL; } } } } /* Now find all of the dependencies */ switch(type[PROG]) { case 0: /* no main PROGRAM defined */ status = 1; /* flag */ count = 0; /* test for blank input */ for(rec = entry; rec->class != SUBR; rec = rec->next) { if(! rec->next) { /* oops -- made it to end */ if(! count) error_("No program units in input"); /* at this stage, display what we have */ status = 0; break; } else count++; /* keep track of input */ } if(status) rec->level = 1; /* process first subroutine */ else if(verbose) fprintf(stderr, "No PROGRAM or SUBROUTINE in input\n"); break; case 1: /* usual case */ break; default: if(verbose) fprintf(stderr, "There are %d PROGRAM units\n\n", type[PROG]); } count = type[PROG] + type[FUNC]; status = 1; /* change the use of status to a counter */ do { ocount = count; if(verbose>1) printf("Level %d, count=%d\n", status-1, count); status++; for(index = link;;index=index->next) { if(index->i->level && !index->j->level) { index->j->hit = status; } if(! index->next) break; } for(rec=entry;;rec=rec->next) { if(rec->hit && ! rec->level) { rec->level = rec->hit; count++; } if(! rec->next) break; } } while(count > ocount); if(! entered) error_("No subprograms encountered"); /* now generate output */ switch(option) { case OPTTBL: tabulate(); break; case OPTCAL: if(! linked) error_("No linkages found"); calls(); break; case OPTDEP: if(! linked) error_("No linkages found"); depends(); break; case OPTENT: if(! linked) error_("No linkages found"); enters(); break; case OPTFIL: file(); break; case OPTBLK: blocks(); break; case OPTUNU: unused(); break; case OPTUNS: external(); break; case OPTSUB: default: errord("Option %d not implemented", option); } exit(0); } tabulate() { printf("\nSubroutines called:\nName\tLevel\tFile\n"); for(rec=entry;;rec=rec->next) { int recl; recl = rec->class; if(rec->file && rec->level && recl != ENTR && recl != FUNC) printf("%s\t%d\t%s\n", rec->name, rec->level-1,rec->file); if(! rec->next) break; } if(type[FUNC]) { printf("\nFunctions:\nName\tFile\n"); for(rec=entry;;rec=rec->next) { if(rec->file && rec->class == FUNC) { printf("%s\t%s\n", rec->name, rec->file); rec->level++; /* don't list as unused */ } if(! rec->next) break; } } if(type[ENTR]) { printf("\nAlternate entry points:\nName\tFile\n"); for(rec=entry;;rec=rec->next) { if(rec->file && rec->class == ENTR) { printf("%s\t%s\n", rec->name, rec->file); rec->level++; /* don't list as unused */ } if(! rec->next) break; } } if(type[BLKD]) { printf("\nBLOCK DATA subprograms:\nName\tFile\n"); blocks(); } printf("\nUnused subprograms:\nName\tFile\n"); if(! unused()) printf("(none)\n"); printf("\nUnsatisfied externals:\nName\tLevel\n"); if(! external()) printf("(none)\n"); /* CALLS to subroutines called by unused subprograms are ignored */ } blocks() { for(rec=entry;;rec=rec->next) { if(rec->file && rec->class == BLKD) { printf("%s\t%s\n", rec->name, rec->file); rec->level++; /* don't list as unused */ } if(! rec->next) break; } } unused() { int k = 0; for(rec=entry;;rec=rec->next) { if(rec->file && ! rec->level) { printf("%s\t%s\n", rec->name, rec->file); k++; } if(! rec->next) break; } return k; } external() { int k = 0; for(rec=entry;;rec=rec->next) { if(rec->level && ! rec->file) { printf("%s\t%d\n", rec->name, rec->level-1); k++; } if(! rec->next) break; } return k; } calls() { if(verbose>1) printf("Name\tSubroutine called\n"); for(index = link;;index=index->next) { if(index->i->class != ENTR) if(!select || !strcmp(index->i->name, select)) printf("%s\t%s\n", index->i->name, index->j->name); if(! index->next) break; } } depends() { if(verbose>1) printf("Name\tCalling subroutine\n"); for(index = link;;index=index->next) { if(index->i->class != ENTR) if(!select || !strcmp(index->j->name, select)) printf("%s\t%s\n", index->j->name, index->i->name); if(! index->next) break; } } enters() { if(verbose>1) printf("Name\tAlternate ENTRY\n"); for(index = link;;index=index->next) { if(index->i->class == ENTR) /* if(!select || !strcmp(index->j->name, select)) */ printf("%s\t%s\n", index->j->name, index->i->name); if(! index->next) break; } } file() { if(verbose>1) printf("Name\tFile\n"); for(rec=entry;;rec=rec->next) { if(rec->file) { if(!select || !strcmp(rec->name, select)) printf("%s\t%s\n", rec->name, rec->file); } if(! rec->next) break; } } ELEMENT *newrecord(recname) /* encounter a new program unit */ char *recname; { if(current&& verbose) fprintf(stderr, "%s %s starts before %s %s ends\n", routine[status], recname, routine[current->class], current->name); return altrecord(recname); } ELEMENT *altrecord(recname) /* identify program unit or entry point */ char *recname; { ELEMENT *newrec; newrec = addrecord(recname); if(newrec->file) errors("Duplicate declaration of %s", recname); newrec->file = filename; newrec->class = status; return newrec; } ELEMENT *addrecord(recname) /* find or create matching entry */ char *recname; { ELEMENT *add; if(entered) { ELEMENT *next; for(add=entry;;add=add->next) { if(! strcmp(recname, add->name)) return add; if(! add->next) /* end of list? */ break; } if(add < lentry) next = add + 1; else { next = (ELEMENT *) calloc(ESIZE,sizeof(ELEMENT)); lentry += ESIZE; } add->next = next; add = next; } else { entered = 1; add = entry; } strcpy(add->name, recname); add->file = NULL; add->level = 0; add->hit = 0; add->class = 0; add->next = NULL; return add; } connect(i, j) ELEMENT *i, *j; { if(linked) { MATRIX *next; if(index < llink) next = index + 1; else { next = (MATRIX *) calloc(ESIZE, sizeof(MATRIX)); llink += ESIZE; } index->next = next; index = next; } else { linked = 1; index = link; } index->i = i; index->j = j; index->next = NULL; } %} %% ^[C*].*\n ; /* skip comments */ ^[ \t]*PROGRAM status=PROG; ^[ \t]*SUBROUTINE status=SUBR; FUNCTION status=FUNC; ^[ \t]*ENTRY status=ENTR; ^[ \t]*BLOCK[ \t]*DATA status=BLKD; ^[ \t]*END[ \t]*\n { strcpy(unit, "------"); current = NULL; } CALL status=CALL; ^[ \t]*EXTERNAL ; [0-9.]*[ED][-+0-9]* ; /* skip floating point numbers */ [A-Z][A-Z0-9]* { switch(status) { case PROG: /* program definition */ strcpy(unit, yytext); current = newrecord(unit); current->level = 1; break; case SUBR: /* subroutine */ case BLKD: /* block data */ strcpy(unit, yytext); current = newrecord(unit); break; case FUNC: /* function */ strcpy(unit, yytext); current = newrecord(unit); current->level = 1; /* assume function is used */ break; case ENTR: /* entry point */ strcpy(unit, yytext); connect(altrecord(unit), current); break; case CALL: /* call */ if(current) connect(current, addrecord(yytext)); else errors("CALL %s with no current subprogram", yytext); break; default: break; } ++type[status]; status = SKIP; } . ; \n status=SKIP; SHAR_EOF if test -f 'fxref' then echo shar: over-writing existing file "'fxref'" fi cat << \SHAR_EOF > 'fxref' : # f77 xref based on Bourne 8.2.2 LIB=/usr/local/etc # The following is for testing: LIB=. case $# in 0) ;; *) case $1 in -w*) arg=$1 ; shift ;; -*) echo "`basename $0: do not understand $1`" ; exit 1 ;; *) arg= ;; esac esac $LIB/fxrefa $* | sort -ut: +0 -1 +1 -2 +2n -3 | $LIB/fxrefb $arg SHAR_EOF chmod +x 'fxref' if test -f 'fxrefa.l' then echo shar: over-writing existing file "'fxrefa.l'" fi cat << \SHAR_EOF > 'fxrefa.l' /* xref.a -- f77 cross reference mapper -- from Bourne's C xref, p. 204 */ %k 100 %a 5000 %o 5000 %n 1000 %e 1500 %p 5000 %{ #undef ECHO static char SCCSID[] = "@(#)fxrefa.l Ver. 2.17, 88/08/10 15:11:25"; char *filename="-"; char flag, oldflag, equals; char firstname[8]; /* where the first name encountered gets stored */ main(argc,argv) int argc; char *argv[]; { register int rc=0; flag = ' '; oldflag = ' '; if(argc <= 1) { yylex(); } else { while(argc > 1) { if(freopen(argv[1],"r",stdin)==NULL) { fprintf(stderr,"%s: %s: cannot open\n", argv[0],argv[1]); rc++; } else { filename=argv[1]; yylineno=1; yylex(); } argc--; argv++; } } return(rc); } %} %% AIMAG\ *"(" ; AINT\ *"(" ; CABS\ *"(" ; CCOS\ *"(" ; CEXP\ *"(" ; CLOG\ *"(" ; CMPLX\ *"(" ; CONJG\ *"(" ; CSIN\ *"(" ; CSQRT\ *"(" ; DABS\ *"(" ; DATAN\ *"(" ; DATAN2\ *"(" ; DBLE\ *"(" ; DCOS\ *"(" ; DEXP\ *"(" ; DLOG\ *"(" ; DLOG10\ *"(" ; DMAX1\ *"(" ; DMIN1\ *"(" ; DMOD\ *"(" ; DSIGN\ *"(" ; DSIN\ *"(" ; DSQRT\ *"(" ; IABS\ *"(" ; IDIM\ *"(" ; IDINT\ *"(" ; ALOG\ *"(" ; ALOG10\ *"(" ; AMAX0\ *"(" ; AMAX1\ *"(" ; AMIN0\ *"(" ; AMIN1\ *"(" ; AMOD\ *"(" ; COMPLEX flag = 'C'; DOUBLE\ *PRECISION flag = '#'; IMPLICIT.*\n oldflag=flag='\0'; ISIGN\ *"(" ; MAX0\ *"(" ; MAX1\ *"(" ; MIN0\ *"(" ; MIN1\ *"(" ; ^[C*].*\n ; /* skip comments */ FORMAT.*\n oldflag=flag='\0'; /* and ignore FORMAT statements */ "\'" { while(yyinput() != '\''); /* skip quoted material */ } ^" "[^ ] flag=oldflag; /* continuation line */ ABS\ *"(" ; ".AND." ; ATAN\ *"(" ; ATAN2\ *"(" ; BACKSPACE ; BLOCK\ *DATA flag = 'h'; CALL flag = '@'; CHAR\ *"(" ; ICHAR\ *"(" ; CHARACTER flag = '$'; CLOSE\ *"(" ; COMMON flag = 'c'; CONTINUE ; COS\ *"(" ; ACOS\ *"(" ; DATA flag = 'i'; DIMENSION flag = 'd'; DO\ [0-9 \t,]* flag = 'D'; ELSE\ *IF[ \t]*"(" flag = '?'; ELSE ; END\ *FILE ; END\ *IF ; END ; ENTRY flag = 'h'; ".EQ." ; EQUIVALENCE\ *"(" flag = '~'; EXP\ *"(" ; EXTERNAL flag = 'x'; ".FALSE." ; FILE ; FLOAT\ *"(" ; FUNCTION flag = 'h'; ".GE." ; GO\ *TO ; ".GT." ; IF\ *"(" flag = '?'; IFIX\ *"(" ; INDEX\ *"(" ; INT\ *"(" ; NINT\ *"(" ; INTEGER flag = '%'; INTERNAL flag = 'p'; ".LE." ; LEN\ *"(" ; LGE\ *"(" ; LGT\ *"(" ; LLE\ *"(" ; LLT\ *"(" ; LOG\ *"(" ; LOG10\ *"(" ; LOGICAL flag = 'L'; ".LT." ; MAX\ *"(" ; MIN\ *"(" ; MOD\ *"(" ; ".NE." ; ".NOT." ; ".OR." ; OPEN\ *"(" flag = 'o'; PARAMETER\ *"(" flag = 'p'; PRINT flag = '>'; PROGRAM flag = 'h'; READ flag = '<'; REAL flag = '!'; REC ; RECL ; RETURN ; REWIND\ *"(" ; SAVE ; SIGN\ *"(" ; SIN\ *"(" ; SQRT\ *"(" ; STOP ; SUBROUTINE flag = 'h'; TANH\ *"(" ; THEN ; TO ; ".TRUE." ; WRITE\ *"(" flag = '>'; [0-9.]*[ED][-+0-9]* ; /* skip floating point numbers */ [A-Z][A-Z0-9]* { if(flag) /* at last we come to variable names! */ if(*firstname) printf("%s\t%s\t%03d%c\n", yytext, filename, yylineno, flag); else strcpy(firstname, yytext); } = equals++ ; . ; \n { if(*firstname) { if(equals) printf("%s\t%s\t%03d=\n", firstname, filename, yylineno-1); else printf("%s\t%s\t%03d%c\n", firstname,filename,yylineno-1,flag); *firstname = '\0'; } oldflag = flag; flag = ' '; equals = 0; } SHAR_EOF if test -f 'fxrefb.c' then echo shar: over-writing existing file "'fxrefb.c'" fi cat << \SHAR_EOF > 'fxrefb.c' /* second part of f77 xref program. Developed from Bourne p. 207 */ #include <stdio.h> static char SCCSID[] = "@(#)fxrefb.c Ver. 2.4, 88/08/08 15:53:37"; #define MAXW 256 char lastw[MAXW]; /* last word read */ char lastc; main(argc,argv) int argc; char *argv[]; { char f1[MAXW], f2[MAXW]; char first=0; int width, col=0; switch(argc) { case 1: width=80; /* default */ break; case 2: if(sscanf(argv[1], "-w%d", &width) == 1) { width = 5 * (width / 5); break; } default: printf("%s: illegal argument\n", argv[0]); exit(1); } f1[0]=0; f2[0]=0; printf("\t\t\tFlags mean:\n"); printf("h\tprogram unit header \t"); printf("p\tPARAMETER definition \n"); printf("c\tCOMMON statement \t"); printf("~\tEQUIVALENCE \n"); printf("d\tDIMENSION statement \t"); printf("$\tCHARACTER declaration\n"); printf("L\tLOGICAL declaration \t"); printf("%%\tINTEGER declaration \n"); printf("!\tREAL declaration \t"); printf("#\tDOUBLE PRECISION declaration\n"); printf("C\tCOMPLEX declaration \t"); printf("i\tDATA initialization \n"); printf("x\tEXTERNAL \t"); printf("@\tCALL \n"); printf("D\tDO loop control \t"); printf("?\tIF test \n"); printf("=\tassignment statement \t"); printf("o\tOPEN statement \n"); printf("<\tinput \t"); printf(">\toutput \n"); while(word() != EOF) { if(lastw[0] != first) { first = lastw[0]; printf("\n"); col=0; } if(col >= width) { printf("\n "); col=20; } if(strcmp(lastw, f1) == 0) { word(); if( ! strcmp(lastw, f2) == 0) { printf("\n %-10s", lastw); col=20; strcpy(f2, lastw); } } else { strcpy(f1, lastw); printf("\n%-10s", f1); col=10; word(); strcpy(f2, lastw); printf("%-10s", f2); col += 10; } if(lastc != '\n') { word(); printf("%5s", lastw); col += 5; } lastc = 0; } printf("\n"); exit(0); } int word() { register char *p=lastw; register int c; if(lastc != '\n') { while((c = getchar()) != '\t' && c != '\n' && c != EOF) { if(p < &lastw[MAXW]) *p++ = c; } lastc=c; } *p++ = 0; return(lastc); } SHAR_EOF if test -f 'error.c' then echo shar: over-writing existing file "'error.c'" fi cat << \SHAR_EOF > 'error.c' #include <stdio.h> #include <ctype.h> extern char *progname; #define PROG if(progname)fprintf(stderr,"%s: ",progname) /* This is the original version: extern int errno, sys_nerr; extern char *sys_errlist[]; #define DIE if(errno>0&&errno<sys_nerr)fprintf(stderr," (%s)",sys_errlist[errno]);fprintf(stderr,"\n");exit(1) */ #define DIE fprintf(stderr,"\007\n");exit(1) error_(s) /* print error message and die -- from K&P p. 207 */ char *s; { PROG; fprintf(stderr, s); DIE; } errord(s, d) char *s; int d; { PROG; fprintf(stderr, s, d); DIE; } errors(s1, s2) char *s1, *s2; { PROG; fprintf(stderr, s1, s2); DIE; } SHAR_EOF if test -f 'yywrap.c' then echo shar: over-writing existing file "'yywrap.c'" fi cat << \SHAR_EOF > 'yywrap.c' yywrap() { /* required for all LEX programs without -ll */ return(1); /* cf. section 9 of Lesk & Schmidt */ } /* if -ll is available, this comes later */ SHAR_EOF # End of shell archive exit 0