VAX Fortran to Fortran 77 translator

V A X Fortran to Fortran 77 translator RICHARD E. HESSEL and STEPHEN B. C H I C O Mechanical and Industrial Engineering Department, Clarkson University, Potsdam, N Y 136 76, USA

A Fortran preprocessor is described which maps VAX Fortran into standard Fortran 77. Supported extensions include long variable names, DO WHILE loops, ENDDO loop terminations, Vax Fortran tab convention, INCLUDE f'de processing, and a MODULE facility to limit the access of external programs to subprogram and common block names. The software is available in 'standard' Pascal and Software Tools Pascal form. INTRODUCTION The Fortran language is much maligned, especially by those in computer science circles, for its deficiencies compared to more modern programming languages. ~'~ We agree with these criticisms. However, as a practical matter almost all engineering software is written in Fortran. The extensive libraries o f high quality mathematical software alone are a great incentive to use Fortran in our computations. 3 While Fortran 77 made a significant step in improving the language, Fortran still suffers from many serious flaws. The next version of the language, Fortran 8x, should remove most of these flaws. 4 In the mean time we are faced with a situation similar to that o f the 1970's when many compiler writers supplemented Fortran IV with extensions to overcome its deficiencies. Several computer vendors, for example DEC and Gould, have extended their Fortran 77 compilers. The DEC VAX Fortran is a particularly attractive version of Fortran 77. 5 The extensions it supports include long variable names, end of line comments, a general DO-WHILE loop, and an ENDDO statement to eliminate the need for statement numbers as the objects of DO loops. Also included is an IMPLICIT NONE statement which requires the type of every variable to be explicitly declared. Experience with this compiler has shown that use of these extensions, especially the long variable names, result in ~nuch more readable programs. However, such programs suffer from lack of portability. In the spirit of the multitude of Fortran IV preprocessors, 6'7 w e combined some o f our old programs for detecting long variable names and translating DO-WHILE loops to produce input for the macro processor from Software Tools in Pascal by Kernighan and Plaguer a to create a new translator which maps VAX Fortran into Fortran 77. The features of this translator include : Long names: The program assumes that IMPLICIT NONE has been used (or at least that all variable names that are six characters or longer have been declared in type statements). The program will then attempt to truncate Accepted January 1985. Discussion closes September 1985

names which are longer than six characters to a readable six character name. If the name cannot be shortened without conflict then a unique name is generated. DO loops: DO-WHILE loops of the form: DO WHILE (condition)

ENDDO are translated into appropriate IF's and GOTO's. Conventional DO loops which are terminated with ENDDO's instead of a line with a statement number are translated into the legal Fortran 77 form with statement numbers. End o f line comments: Any text which appears between an exclamation point (!) which is not in a quoted string and the end o f the line is considered to be a comment. These comments are moved to the line preceding the current line as standard Fortran comments. The program understands Fortran continuation lines. Include statements: The source file may contain 'C$INCLUDE file' statements which are replaced by the contents of the file before any other processing is done. These statements may be nested, i.e. the included file may contain other include statements. Include statements are used to build source files comprised of many routines in separate files. Common block declarations can be stored in a file and included when needed to avoid typing errors. Modules: Fortran 77 supports only one level of global name. This makes it difficult to hide implementation details from users of library routines. Using this option, all global names, i.e. subprogram and common block names, are mapped into special inaccessible names except for those names which the user selects to be 'visible'. The writer of a 'module' would specify that certain routines or common blocks could be accessed by other routines outside of the module. All other global names would be transformed into a four letter module name and a two character sequence to form a unique six character name.

IMPLEMENTATION OF THE TRANSLATOR The translator is implemented in Pascal. Two versions are available: one using 'standard' Pascal and one using the Pascal environment developed in ref. 8. The programs were written for portability with carefully isolated system dependent sections, e.g. opening flies. The output o f the translator is fed to a general purpose macro processor to perform long variable name substitution. A suitable macro processor is 'define' from ref. 8. All of the progra~ns described in ref. 8 are available frown the publisher for a nominal charge. A 'standard' Pascal version is supplied with the translator software. The translator makes several passes over the program text. the passes are: 0141-1195/85/030142-15 $2.00

142

Adv. Eng. Software, 1985, Vol. 7, No. 3

© 1985 CML Publications

Pass 1 : All C$INCLUDE file statements are replaced by the contents of the named file. Pass 2: The DO WHILE, ENDDO, and DO without a statement number are translated into IF's, CONTINUE's, and GOTO's. End o f line comments are moved in this pass and the VAX Fortran tab convention is converted to blanks. Pass 3: Long variable, subprogram, and common block names are mapped into unique names. CSMODULE and CSVISIBLE statements control the visibility of global names. Pass 4: The define statements produced in pass 3 to drive the macro processor are merged at the beginning of the program source and are passed to the macro processor. Command procedures are provided to illustrate how to implement the translator on VAX/VMS and Unix operating systems. Detailed usage instructions may be found in the manual pages. Extensive prologue comments in the code aid in implementing the program on the users system.

USING THE TRANSLATOR The module aspects of the translator are especially useful in writing large programs. The program could be broken into logical sections and written by different programmers. Each program section could access only those subprograms and common blocks of another section which had been made visible. Thus each programmer could use descriptive names for internal .subprograms and common blocks without worrying about possible conflict with other sections of the program. Visible names should not be longer than six characters to work properly with most Fortran compilers and linkers. Other subprogram and common block names will be processed the same way as long variable names. The translator requires that all variable names which are six characters in length or longer be explicitly declared. Six character names are needed to determine if a long name can safely be truncated to its first six characters. If it cannot then a unique six-letter name is generated. We recommend that all variable names be declared.

THE PROGRAMS Two versions o f each program are provided. One uses the Software Tools s primatives while the other is in 'standard' Pascai. The Software Tools version has been tested on VAX/VMS. The 'standard' Pascal version has been tested on VAX/VMS and Unix. Command procedures are supplied for each of these operating systems. A version of the define program from ref. 8 in 'standard' Pascal is included. A prospective user can port the primatives described in ref. 8 to his or her system and use the Software Tools version and the other tools described in ref. 8. This version is especially useful to users who already are using Software Tools. An alternative is to use the 'standard' Pascal versions. These programs should compile without modification on most Pascal compilers. The programs include extensive prologue comments w/rich describe in detail the programs. Limitations and possible extensions are enumerated.

Sample Fortran programs are included to test the programs when they have been installed on a prospective user's computer:

Program VF2F77 - VAX Fortran to Fortran 77 translator Usage VF2F77 infile outfile

Function VF2F77 reads VAX Fortran source code and outputs commands for a macro processor and translated code. After being processed by a macro processor, the output is standard Fortran 77 code. VAX DO WHILE ( c o n d i t i o n ) . . . ENDDO and DO index = il, i2, i3 ... ENDDO are translated. Text following an unquoted exclamation point (!) is moved to the preceding line as a comment. IMPLICIT NONE statements are changed into comments. All lower case letters not in quoted strings are mapped into upper case. A tab character in columns 1 through 6 causes the next character to logically be in column 7 if the character is alphabetic. If the character is a number other than zero (0) it is placed in column 6 to indicate a continuation line. All variable names greater than or equal to six characters should be declared in type statements. A list of macro processor commands will be generated to map names longer than six characters into six character names by truncation, if possible, or by generating a unique name. The following translator directives are supported: C$ INCLUDE 'filename' This line will be replaced by the contents of the file 'filename'. Include statements may be nested as deeply as desired. CSMODULE xxxx Marks the beginning o f module xxxx. Global names (subprogram and common block names) which the user wishes to be hidden are mapped into 'hidden names' which begin with xxxx. If xxxx is no longer than four characters it will be truncated. If there is no CSMODULE directive global names will follow the same rules as variable names. All global names are hidden unless they appear in a CSVISIBLE statement, cSVISIBLE namel [ n a m e 2 . . . ] . The global names listed in this statement are to be unchanged by the translator. These are the global names visible to the rest of the program. As many CSVISIBLE statements as required may be used. Names on the CSVISIBLE statement are separated by blanks, tabs, or commas.

Bugs Underscore characters ( _ ) are not supported in variable names because most macro processors do not recognize them as characters. Modifications to VF2F77 are documented if your macro processor treats them properly. An exclamation point in a Hollerith field, e.g. 5HBUG!, will be treated as an end of line comment indicator. Hollerith fields are not officially part of Fortran 77. 9 Multiple common blocks are not allowed in the same COMMON statement. E.G. COMMON/BLK1/A,B,C/BLK2/ X,Y.

Adv. Eng. Software, 1985, Vol. 7, No. 3

143

REFERENCES 1 Dijkstra, E. W. How do we tell troths that might hurt?, Selected Writings on Computing: A Personal Perspective, Springer-Verlag, New York, 1982 2 Wilson, K. G. Planning for the Future of US Scientific and Engineering Computing, CA CM 1984, 27(4) 3 IMSL Library General Information, International Mathematical and Statistical Libraries, Inc, Houston, TX, 1983 4 Smith, B. T. Status Report on Fortran 8x as of August 1983, SIGNUM Newsletter 1983, 18(4) 5 VAX Fortran Reference Manual 3.0, Digital Equipment Corporation, 1983 6 Kernighan, B. W. RatJbr - A Preprocessor for a Rational Fortran, Unix Programmer's Manual, Vol. 2B, Bell Telephone Laboratories, Inc., Murray Hill, NJ, 1979 7 Cook, A. J. and Shustek, L. J. A User's Guide to Mortran 2, Stanford Linear Accelerator Center, California 94305, 1975 8 Kernighan, B. W. and Plauger, P. J. Software Tools in Pascal. Addison Wesley, 1981 9 American National Standard Programming Language FORTRAN,

ANSI X3.1978

DIRECTORY OF PROGRAMS The first two programs are used to obtain the source and destination files, and send them through the translator programs. The actual program names used in the two driver routines will have to be modified to be compatible with the environment the translator is implemented in. For example: 'USER1 : [C 100.STEVE.TRANS.STAND] DEFINE.EXE' Programs with the .PAS extension are written in 'standard' Pascal, those with the .SFT extention are designed to use the software tools primitives. All the following programs read from standard input and write to standard output : V F 2 F 7 7 . C O M - V A X / V M S command procedure used to run the translator programs. U N I X . S C R - U n i x shell script to run the translator programs. I N C L U D E . P A S - U s e d to include external files into the main source code. Note: Pascal File 1/O is system dependent and may have to be modified, currently set up for VAX/VMS operating system. W H 2 S T D . P A S - C o n v e r t s non-standard do loops into a form compatible with standard F O R T R A N 77, plus processes end o f line comments, VAX tab conventions, and maps text not in quotes to upper case. L O N G N M . P A S - Creates a list of define statements to redefine long variable names. The list should be affixed to the beginning of the output from WH2STD.PAS for use with the define program. D E F I N E . P A S - R e a d s from standard input and replaces every occurrence of ' s t r l ' with 'str2' following the define command: define(strl, str2). The following programs perform the same functions as those above, but are designed to work in the software tools environment: INCLUDE.SFT WH2STD.SFT LONGNM.SFT DEFINE.SFT The next programs are used as test programs. TEST.F is the source, MATADD.SUB, and MATMULT.SUB are separate subroutines that are included with the include program:

144

A d v . Eng. S o f t w a r e , 1985, Vol. 7, No. 3

T E S T . F - Main program that calls MATADD.SUB and MATMULT.SUB. MATADD.SUB - Subroutine that adds two matricies together. MATMULT.SUB - Subroutine that multiples two matricies together. XX.OUT-The translated output from the three test programs.

VF2F77.COM VAX/VMS command procedure to run translator programs $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $ $

~ VAX/VMS comand procedure to dr,ve tile translat,~! ! The source code is passed through the followin~ l,rogram~ ! include -- includes external source files. I wh2std -- translates while loops I longnm -- processes long variable n a m e s [ define -- processes the define statements generaL~,d by Iongnm t ! clear the directory of possible conflicting file:~ if fSsearch("temp*.txq;*") .nes. "" then $ delet!, lemp*.tKq; ~ ~ I get input and output fires infile =~ pl outfile ~= p2 if infile .eqs. "" then $ inquire inlile "source £~le" if outfile .eqs. "" then $ inquire outfile "output file" ~ ! if a n output file is not mpecified then the output will ! go to ~tandard output and no output file will be saved ~ ! connect standard input and output to the appropriate files assign/user_mode "infile" sys$input [ input file spec as~ign/umer_mode templ.txq sys$output [ output from include run userl : IclO0.~teve.trans.stand] include .exe ~ assign/umer._~ode templ.txq sys$input [ output from include assign/u~er_mode temp2.txq sys$output [ output from wh2std run userl:[cl00.steve.trans.stand]wh2std.exe ~ delete te~p.~l.~txq;*

$ ~

$ assign/u~er_mode temp2.txq sys$input I Output from while $ assign/user_mode temp3.txq sys$output I output from flung $ run userl : [cl00.steve.trans.stand] longnm.exe $ ~ $ I append the result of wh2std to the define table $ ~ check if t h e r e w a s shy output from the long name p r o g r a m $ ~ $ if fSsearch("temp3.txq;*") .eqs. ~'" then goto lablel $ append temp2.txq temp3.txq $ assign/user temp3.txq sys$input S goto fable2 $1ablel: $ assign/user_mode temp2.txq sys$input $1able2: $ if outfile .nes. "" then guru fable3 $ des ssign sys$output $ guru fable4 $1able3: $ assign/user "outfile" sys$output $1able4: $ run [clO0.steve.trans.stamd]define.exe $ t $ I delete the work files $ delete te~p*.txq;*

UNIX.SCR Unix shell script to run the translator programs ~ Transf77 - shell script to run the programs ~ necessary to t r a n s l a t e VAX/V~L~ FORTRAN into # s t a n d a r d F o r t r a n 77 # # useage: tran~f77 infile.f outfile.f # # process includes a n d p i p e to "twhile" include <$I I twhile > txqpl # # create list of defines in txpq2 longnm < txqpl > txqp2 # # put list of defines on top of output from "twhile" # and pipe to the "define" p r o g r a m cat txqp2 txqpl I define >$2 # ~ remove temporary files rm txqpl rm txqp2

INCLUDE.SFT Copies external files into the main file

incl[gJ := ord('e'); incl[10] :" ENDSTR; finclude(STDIN) end; begin

INCLUDE P R O G R A M ( a f t ) include -- replace c$include "file" by contents of file input is from standard input. output is to standard output. Both input and output are redirected to be the appropriate files This version is designed to run in the Software tools environment. The file l/O is isolated in "include" and "finclude" REFERENCE Kernighan & Plauger, "Software Tools in Pascal " 198! Addison-Wesley Publishing Company, Reading, HA

( wrapper (CU) -- this is the wrapper for all the software tools { Rename this ~ile "name.pan", where name is the name of the tool. { F o r example: rename it filter.pan ( This next li~e inherits all the global definitions that go along {_ with the software tools.

[inherit('userl:[bllb.softtool.environ]globdefs.env')] program wrapped(input,output); { Include your program here. For example:

~incIude "filter.prc" )

{ wrapper }

iaitio; end.

{ Call program here. For example: filter } include { wrapper }

WH2STD.SFT Processes nonstandard do loops, etc. W~I2STD PROGRAM (sft) Program Overview This program is used to convert some of the nice features of VAX FORTRAN into a form compatible with standard FORTRAN 77 The particular features handled in this program are: DOWHILE ( c o n d i t i o n is true) : block of statements : ENDDO

{ include -- replace c$include "file" by contents of file } procedure vat

DO i n d e x v a t = l o w e r , u p p e r , s t e p : block of statements : ENDDO

include; incl : string;

{ value is "cSinclude ~

{ lower --return "a" in l o w e r c a s e } FUNCTION lower( a : CRARACTER ) : C l i n C h E R ; { return~ ~ in lower ca~e } { a ~ m a e ~ difference between upper & lower cmse xs a constant } VAR c h : c h a r a c t e r ; Begin { l o w e r } if a i~ [ o r d ( ' A ' ) . . o r d ( ' Z ' ) ] then c h :ffia + ord('a') - ord('A') e l s e c h :" a ; lower := c h ; End; {lower) { equal -- test two strings for equality } { modified t o e e g l e e t c a s e of t h e strings ) function equal (vat strl, sir2 : string) : boolean; vat i : integer; begin i :- 1; while ( l o w e r ( s t r l [ i ] ) = lower(str2[i])) and (strl[i] i := i + i; equal :~ (lower(strl[i]) - lower(stri[i])) end; {

VAX t a b c o n v e n t i o n s which is a tab in the £irst 6 columns followed by a d i g i t (I..9) is a continuation of the previous line. It is processed into: 5 blanks, the digit,TARS[ZE-6 blanks, and the text End of line comments are signified by a n " ! " . The t e x t b e t w e e n the "~" and the end of the line is a comment. It is processed i n t o a n o r m a l Comment a n d p l a c e d b e f o r e i t s l i n e o f o r i g i n I M P L I C I T NONE s t a t e m e n t s Iongname program.

are

commented out.

There are two run time options comment cards in the source option key words.

<> ENDSTR) do

finclude -- includes the file desc f } p r o c e d u r e f~nclude ( f : f i l e d e s c ) ; vat line, sir : string; loc, i : integer; fl : filedesc; { getword -- get word £rom s[i] into out ) function getword (vat s : string; i : integer; vat out : string) : integer; vat j : integer; begin while (sli] in [BLANK, TAg, NEWLINE~) do i := i + i; j :~ 1; while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin out[j] := s[i]; i :~ i + i; j := j + 1 end; out[j] := ENDSTR; if (~[i] - ENDSTR) then getword :- 0 else getword := i end; begin while (getline(line, f, MAXSTR)) do begin foe :~ getword(line, l, s i r ) ; if ( n o t e q u a l ( a r t , incl)) then putstr~line, STDO~T) else begin l o c := g e t w o r d ( [ i n e , Ioc, sir); str[length(str)] := ENDSTR; { remove quotes } for i :- I to length(sir) do str[i] := str[i+l]; fl := mustopen(str, IOREAD); finclude(fl); closef(fl) end end end; begin { setstring(incl, "c$include'); incl[l] := o r d ( ' c ' ) ; incl[2] := o r d ( ' $ ' ) ; incl[31 : = o r d ( ' i ' ) ; incl[4] := o r d ( ' n ' ) ; incl[5] := o r d ( ' c ' ) ; incl[6] := ord('l'); incl[7] :" ord('u'); incl[8] := o r d ( ' d ' ) ;

cSUPPER t r u e flase C$DEBUG t r u e false U s e : cSUPPER

This

available to the code. Spaces are

is

for

use with

the

user implemented as not allowed in the

--> maps all text not in quotes to upper ease. --> does not change case. Default = true. --> outputs diagnostics to standard output. - - > no d i a g n o s t i c s are output. Default ~ false. false Flow of

the

Program

A buffer is filled with all the text necessary to obtain a complete FORTRAN s t a t e m e n t including all continued lines and any blank lines or comments that are interspersed in the code. This is where the end of line comments and tab conventions are processed out From this buffer a string "stmt.t×t" is obtaine~. This contains all the relevant FORTRAN t e ~ t o f t h e e n t i r e This string is formed so that the procedures testing statement do not have to know about column structure continued lines.

string statement. the or

If a nonstandard "DO" structure is found then the buffer is processed (by the procedure "pr_do") as follows: The "DO WNILE" statements are mapped into 3 lines: IF( .NOT." & (original "DOWRILE" argument)" -- Remains the same & )into xxxxx -- Is added to the end of the stmt. The DO/ENDDO loops are maped into: DO xxxxx" & ..... rest of the original "DO" Note: The statements are broken up to prevent them from being pushed past column 72 when the additional characters are added. Nested "DO" structures are processed recursivly. The procedure "pr_do" repe~ts the process of getting a statement and testing it for do types until it finds an "ENDDO". If another nonstandard do structure is found while looking for the "ENDDO" "pr_do" then recursivly calls its self to process the new found do structure When an "RNDDO" is found it is processed as follows: When associated with a "DOkrHILE '' the keyword "ENDDO" is mapped into 2 lines: GOTO yyyyy" "xxxxx CONTINUE" For a DO / ENDDO loop the "ENDDO" is maped into: "xxxxx CONTINUE" For both cases if the "ENDDO" is labeled a continue statement with the original label is inserted before either of the two above enddo cases are processed.

Adv. Eng. Software, 1985, Vol. 7, No. 3

14$

STRUCTURE:

PROGKAM

--

kndentatio[~

:n~tcates

iev,,J

c,t

buffer b u f f ct

nestkng

PROGRAM w h 2 s t C main routine ~DN. l o w e r returns a char:Iciest ill 1 ~wt t ~ t s e I'RO. p r v a × t a b -- RiOt,s> v a x t ~b ( ( ) n v , ' i [ 1o12 FUN. real strut d , t , i m l n : ~ i f s~ l i r w i ;t r e a l stml. FUN. all blanks al! blank lane trm~; PRO. flush buffer dumps butler COllt('I [ s t o " d e s t l n " PRO. change case - changes text to capitol lettel PRO. put_in buff puts a line in the buffer PRO. stripcom takes off end of line comments PRO. dumpexcess -- dnmps excess comments

{ STRING constanLs ~ CAP_C : CHARACTER; dowH, scontznue, s,fnot, line : STRING;

NOTES : * * * * * * * * * * * *

Spaces in The words statement Only

mark marker

~n a q u o t e d

~trtng

ks

xgnored

as

t h e "DO W H I L E " a n d t h e "END DO" s t a t e m e n t tDemselves can not be continued, but the can be spl~t as desired.

single

quotes

mark

a

q.oted

an

are rest

scorees scores thiei

rewritten

with

extentton8

{ wrapper (CU) -- this zs { This next line ~nherits { with the s o f t w a r e { ~nherit ('user i : [bllb. soft PROGRAM

of

string.

ires ann cbarecte: By K e r n i g h a n and

a~e

by

Dkck Hansel Steve Oh[co

s+,t d # ~ w ' l o p e d Plauger.

January Foburary

an

tools go along

w r a p p e r { input ,out put) ;

CDNST coustants - 1; - 2; - 3; - 4; - 5; = 6; - 7; 8; - 9; i0; - 72;

} CDL COL COL COL COL COL COl, COL COL COL

11 12 13 14 15 16 17 18 19 20

-

1i ; 12; 13; 14; - 15; - 16; - 17; = IR; "- 1 9 ; 20;

VAR

146

let l~ne line

: integer; flag: boolean; hum : integer;

:

> 0 then begin 1 to (tabpos

{ k~eps tr~ck o f ~* o : ] l n , , s in stm~ } { inHicates end ol fiie when tals~ ) { line number (created a.~ p r o g r a m ) )

Adv. Eng. Software, 1985, Vol. 7, No. 3

in

1)

do

t

lineiJ]

:

[ord(*l')..ord('9")}

(COl

k := k+i; t_line[j] := line[k!; until {line[k] = ENDSTR) l~ne :- t_l~ne; end; { if tabpos > 0 } end; { if .of a comment } End; { pr_v~tab }

Begin if

{ real stmt } ( (iinT[i] in rs := false else rs :- true; real stmt := IS; End; { Teal stmt }

TABSIZE = 8; S T A R T I N G L I N E RUM - l O 0 0 0 ; { s1~r~ ins number for created stmts. CONTINUE CHAR - AMPER; { " & " } MAX STMT LENGTH - 1 3 2 0 ; { 20 lines x 66 char/lin< } MAX B U f F LENGTH - 1 0 0 ; { buffer can hold I00 lines ot text } BUFF PROTECT 95; { prevents overflow of the buffer }

t buff line = I . . M A X B U F F _ L E N G T I I ; t _ t e x t - A R R A Y [ I . . M A R S T M T L E N G T H ] OF C R A R A C T E R ~ t strut - R E C O R D txt : t text; { actual text u: the ~tatem~nt txt__len : i..~4a×.ST~r LENGTH; { l e n g t h ot statement END; { s t m t r e c o r d } t of_do ( D O W R I L E , D O NN,ENDDO,NORM D O , N { 7)~),

a cunstant

}

} } } }

+

vtc)

or

(k

H~, t

line[l]; tDen

linv[il

) text

taTAR,CAP

{ 1 ********* flush_buff PROCEDURE f l u s h . _ b u f f e r ; VAR i , j : integer; line : STRING;

C,letc])

**************

vtc

:

:-

1

BI~NK;

>= M A X S T R ) ;

{ 1 ****** real stmt ******* } FUNCTION r e a l _ s t m t ( l i n e : STRING) : boolean; VAR r s : b o o l e a n ; { 2 ****** all blanks ******* } FUNCTION a l l b~anks(VAR l~ne : STRING) : boolean; VAR i : i n t e g e r ; Hi : b o o l e a n ; { all blanks flag } Begin i :- 0; bf := true; repeat i :- ; + 1; if not(line[i] in [BI&NK,TAB,NEWLINE,ENDSTR]) bf : false; until ( bf = false) or (l~ne[i] = ENDSTR); all blanks :- bf; End; { all blanks }

PROCEHURE wh~le! 77 ;

{ column COL I COL 2 COL 3 COL 4 COL 5 (;Ol. 6 COL 7 (OL 8 COL 9 COh l 0 COL 7 2

tabpos for j

for j :- tabpos to j : - (COl, 6 vtc); k :- tabpos; repeat ~ := j+l;

the

8, 1983 19~

the wrapper for all tl~e s o i t w a r e all the global definiti{ms that tools. tool . e n v i r o n l g l o b d e f s .env')]

is

{ 1 ********* pr_vaxtab ********* } { processes lines continued with v a x TAB c o n v e n t i o n s { uses the original tab character and replaces the first tab { with the number of spaces needed to put the first character { in column 7, or column 6 if it is a continuion line PROCEDURE p r v a x t a b ( V A R line : STRING}; VAR t _ l i n e : STRING; j,k : integer; vtc : integer; { vax tab continuation ofset } tabpos : integer; { tab position }

if

ar{ ~ used througbt tbc ,od( t o ll:tHr~vt' r e a d k b l l k t > a r e m~[ s t a n d a r d t a s c a l s c i f y.)u~ ( o m p i l e r d o ~ , s lkOt use they can b' /el(ttA ~llh ] tilt, r ~ r s~l: c a l l [ t i t

TDe p r o g r a m usps the prla/at "Softwaro Tools ~n P a s c a l "

: STR!NG;

{1 * * * * l o w e r * * * * } FUNCTION l o w e r { a : CHARACTER ) : CHARACTER; { returns a in lower case } ( assumes difference between upper & lower case VAR c h : c h a r a c t e r ; Begin {lower} if a tn [ord('A')..ord('Z')] then ch :- a + ord('a') - ord('A*) else ch := a; lower :- oh; End; {lower}

legal. of the

in

zn the b u r f o r )

t_stmt; boolean; : boolean; { true => a l l upper : false -> don't change} : array[O..4] of integer; { powers of 10 } : F1LEDESC; { original vax source code with "whiles" } : FILEDESC; {"while loops" replaced with standard f77 code}

~f Iine[tabpos+l} else vtc :- 0;

The only [ii~( normal text is changer around is wHeu there a lot of comments. In order Io prevent bullet overflow they are dumped out saving only the real statement lines buffer. ( see prncedure "dump ex;ogs" in "put in bull") Under Under auport

end

sgoto,send

STRING; # of ]ini!s

Begin { prvaxtab } j :=0; tabpos := 0; { if a comment line then gore end and return } if not(line[COL 1 ] i n [CAP C , L E T C , S T A R I ) then beg~n repeat j :=j+t; if line[j] - TAB t h e n tabpos :- j; until (tabpos <> 0 ) o r ( j > - COl, 6 ) ;

THe p r o g r a m knows nothing of Holorith iield and would consider an "~" in such a field as an end of fine co~e~t. It would also change the case of letters in a ttolertth format ~f the change case mode is actiw,. An e x c l a m a t i o n line co~ent

stmt : DEBUG : case_flag ten source de~tin

~

PRO. pr option -- processes option comment cards FUN. find true - - .-> t r u e if "true" lollows tile opti{~n PRO. f i l l buff -- fills buff with entire statement PRO. is continued determtns if the line ts cont. PRO. i n i t i a l i z e -- initializes strings and files PRO. g e t s t m t - - g e t s a FORT~N statement from the buffer. FUN. begining_of text -- -> pos of 1st cDar. of l£~e PRO. get_txt -- gets relevant fortran stmt. text PRO. p r s t : m r - processes a statement FUN. find do_type -- ltnds t h e t y p e o f d o => d o t y p e FNR. ~s~enddo -- zl strut, i s a n e n d d o => t r u e FUN. is dowh~le -- tf stmt. is a dowhile -> ~rue FUN. do. loop_type .... > do type FUN. find rparen - - => r i g h t parenthesis posktion PRO. pr do -- processes a do statement PRO. insert -- inserts a line in the buffer FHN. f~nddo~os - => b u f f e r line with do s t a t m e n t PRO. cb to sir converts integer knto a cbr string FUN. has_a number if stmt. is laaeled -> true PRO. pr_dowhile - processes a dowhile statement PRO. pr_do nn processes a do without a label PRO. pr enddo -- processes an enddo statement PRO. hlde_~mp_none -- comments out impliczt none strut. ***~**********

: arrayIl..MAX B U F F _ L E N G T R ] of : i n t e g e r ~ { k e e p s track of the

OR a f I _ b l a n k s ( l i n e )

tilen

)

then

}

{ 2 ******** changeca~e ******** } PROCEDURE c h a n g e _ c a s e ( v a t l~ne : STRING}; { changes all lower case letters to upper case ~f t h e y a r e n o t { quotes. Assumes that the difference Between upper and lower case { ~s a c o n s t a n t VAR i : i n t e g e r ; ,nquote : boolean; Begin { change case } inquote : false; i :- 0; repeat i :- i + i; i f 1 ~ n e [ i ] - SQUOTE t h e n knquote :- not :nquote ; if (line[i] in [ord('a')..ord('z~}]) and (not inquote) then Iine[il := ]ine[i] + (ord('A') {~rd(*a'))

} } }

for i := I to buff ct do begin if case_flag then change_case(buffer[it); putstr(buffer[i],destin); end; { for i } buff_ct := O; End; { flush_buffer }

End;

{ 2 ******** strip_tom ********* } PROCEDURE strip_com(VAR line : STRING); { used to convert end of line c o ~ e n t s to standard form } { Also used to test if the length of non-comment lines is V~dR inquote : boolean; endline : integer; i,j : integer; comstr : STRING;

} } } } }

} NOTE: the comments are dumped to the destination file first} which will change the order of the comments in relation to } the statement lines. This is only done when the buffer } count reaches BUFF_PROTECT (95) } VAR i , h r e a l : integer; Begin { dump_excess } i := 0; b_real :- 0; repeat i := i + I; if real_stmt(buffer[i[) then b e g i n b real := b_real + l; b~ffer[b_real] := buffer[it end e l s e putstr(buffer[i],destin); until (i = BUFF_PROTECT); buff ct :" b_real; End; { ~ump_excess } { 2 ****** pr_option ******* } PROCEDURE pr_option(card : STRING); { sets the boolean flags for debuging and changin~ case } vat opt_~o~ : integer; { 3 ****** find true ****** } FUNCTION find_t~ue(cpt : integer) : boolean; { determines if there is a true after the option card } { only checks for the letter "t" } v a t flag : boolean;

if (lower(cardlcpt]) else flag := false;

~ ord('t'))

in [BLA~FK,TAB]) do

then flag

find true := flag; End; { find_true } Begin { pr_option } opt~os := 3; { check if debug or upper option } if (lower(card[opt_pos]) = ord('d')) and (lower(card[opt_pos+l]) ~ ord('e')) and (lower(card[opt_pos+2]) = ord('b')) and (lower(card[opt_pos+3]) = ord('u')) and (lower(card[opt_~os+4]) = ord('g')) then

:= true

)

72 }

Begin { strip_tom } i := I; inquote :ffi false; while (i <= MAXSTR) and (line[i] <> ENDSTR) do begin if line[it = SQUOTE then inquote := not inquote else if (line[it = EXCLAM) and (not inquote) then begin endline := i; comstr[l] := CAp_c; j :=1; repeat i := i+l; j := j + l ; comstr[j] := line[i]; u n t i l ( line[it = ENDSTR ); buff ct := buff_or + i; buffer[buff ct] := comstr; line[endline] := NEWLINE; line[endline+1] := ENDSTR; i := endline; end; { else if } i := i + i; end; { while } if ((i - 2) > COL_72) and { subtract 2 for NEWLINE and ENDSTR (not (line[COL l] in [CAP-C,LETC,STAR])) then begin message('>>>>>>> ERROR <<<<<<<<'); putstr(line,STDOUT); message('line with more than 72 characters found'); message('Could be a result of converting tabs into spaces') end; End; { s t r i p _ t o m ) { 2 *********** dump_excess **************** } PROCEDURE dump._excess; T h i s p r o c e d u r e i s used t o remove the non e s e n t i a l l i n e s from the buffer in order to keep it from overflowing due to a large ammount of comments. The main use of this will probably be at the begining of the program where there is often a large number of header comments

{ pr_optlon

Begin { put_in_buff } if (line]COL i] in [LETC,CAP_C]) and (line[COL 2] = DOLLAR) then pr_option(line); strip_tom(line); buff ct := buff_el + I; buffer[buff ct] := line; if buff_ct >= BUFF_PROTECT then dump_excess; End; { put_in_buff }

( 1 ********* put_xn_buff ************** } { puts the llne in the buffer after striping off the end of { line comment and puling it in the buffer first PROCEDURE put_in_bnff(VAR line : STRING ); VAR i : integer;

and (card[cptl

+ 5)

else if (lower(card[opt~oos]) = ord('u')) and (lower(card[opt~o$+l]) = ord('p')) and (lower(card[opt_pos+2]) = ord('p')) and (lower(card[opt~oos+3]) = ord('e')) and (lower(card[opt_pos+4]) = ord('r')) then case_flag := f i n d _ t r u e ( o p t ~ o s + 5);

Begin

Begin { find true } while (ept < MAXSTR) opt := opt + I;

:= f i n d _ t r u e ( o p t ~ o s

DEBUG

until line[i] = ENDSTR; End; { c b a n g e c a s e }

{ I ********* fill_buff ********** } { fills the buffer with a fortran statement including any cou~ents { v ~ tab conventions and end of line comments are processed out { otherwise the text remains unchanged PROCEDURE fill buff; FAR real_line : boolean; continued : boolean; i : integer;

) } )

( 2 ******* is continued ******** ) FUNCTION is_co~tinued(VAR line : STRING):boolean; vat flag : boolean; i : integer; Begin ( is_continued } { find first non blank character. } i := i; while (lineli] = BLANK) and (i <= COL 6 ) do i := i + I; if i <> COL 6 then flag := false else if lin~ICOL_61 in lord('0"),BLANK] flag := false else flag := true; is_continued := flag; if DEBUG then writeln('is End; ( is_continued } Begin { fill buffer { { { (

a continuation

then

line:

",flag);

}

first time "line" comes from procedure "initialize") after that it is left over from "fill_buff" since } it has to check if the next line is a continuation } of the current line )

put_in_buff(line); c o n t i n u e d :ffi f a l s e ; r e a l _ l l n e :ffi f a l s e ; if line_flag then repeat i :ffi 1; if g e t l i n e ( l i n e , s o u r c e , M A X S T R ) t h e n ' b e g i n pr_vaxtab(line); while (i < MAXSTR) and (line[it in [BLANK,TAB]) i := i + I; if (i = COL I) and (line[COL_l] line[l[ := CAP_C; if (line[i] ~ EKCLAM) line[i] :- BLANK; line[l] :ffi CAP-C; end;

= EXCLAM)

do

then

and ( i <> COL_6 ) then begin

i f l i n e [ l ] in [CAP_C,LETC,STAR] t h e n p u t _ i n _ b u f f ( l i n e ) else if line[i] in [NEWLINE,ENDSTR] t h e n put_in_buff(line) { else it is a non trivial line and has to be checked for } { c o n t i n u a t i o n (TAB or normal) o r n o n s t a n d a r d do t y p e . } e l s e begin real line := true; if i~_continued(line) then begin continued := true; put_in_buff(llne); end else continued := false; end; end { if getline then } e l s e begin line_flag := false; flush_bur fer; end; until (real_line and not continued) or (not line_flag); if DEBUG then writeln('fill buff: buff_or = ",buff_ct:l); End; { fill_buff } {l **** initialize **** ) PROCEDURE initialize; { initialize constants, etc. VAR j : integer; ch : C H ~ C T E R ; Begin { initialize } {string constants} CAP_C :- ord('C'); dowh[l] dowh[2]

:= o r d ( ' d ' ) ; :" ord('o');

dowh[3] := o r d ( ' w ' ) ; dowh[4] :- o r d ( ' h ' ) ; dowh[b] : " o r d ( ' i ' ) ; do~h[6] : - o r d ( ' l ' ) ;

}

sifnot[l] sifnot[2] sifnot[3] sifnot[41 sifnot[5] $ifnot[6]

:= := :" ::= :=

ord('I'); ord('F'); ord('('); ord('.'); ord('N'); ord('O');

Adv. Eng. Software, 1985, Vol. 7, No. 3

147

dowh[l] dowh[8}

:= o r d ( ' e ' ) ; :~ ENDSTR;

scontlnue[l] sconttnue[2] sconttnue[3] scont~nue[4] scont~nue[5] scont~nue[6] scontznue[7] sconttnue[8/

:= :::= := := ::=

sifnot[7] sifnot[8]

ord('C'); ord('O'); ord('N'); ord('T'); ord('I'); ord('N~); ord('U'); ord('E');

:= o r d ( ' T ' ) ; := o r d ( ' . ' ) ; := :::-

ord('G'); ord('O'); ord('T'); ord('O*);

send[l] :send{2[ :send{3[ :send[4] := send[5[ := send[6[ := { startimg v a l u e of statement n u m b e r s line_hum := S T A R T I N G LINE NUM;

ord(~e'); ord('n'); ord('d'); ord('d'); ord('o'); ENDSTR;

{ powers of I0 } t e n { O [ :~ 1; f o r j := 1 t o 4 do t e n { j [

source destin

:= STDIN; { s o f t t o o l s := STDOUT;

sgoto[l] sgoto[2] sgoto[3] sgotoI4]

:-

te~[j-ll

{ 2 ************ find_do_type ************** { returns the type of do loop that is In the F U N C T I O N find ~ o _ t y p e : t_of do; VAR t e m p d o ~ t_of_do;

} tf l o w e r ( t i t [ i l l - send[j[ then begin i := i + I; j := j + I; end else flag := false; until (flag = false) or (send[j[ = ENDSTR); is enddo := flag; end; ~ i~ith } End; { i s e n d d o }

* I0;

constants

{ get the string " l~ne " for till bull line_flag := g e t l i n e ( l i n e , s o u r c e , M A X S T R ) ; if line_flag then p r _ v a x t a b ( l i n e ) ; End; {initialize}

}

{ 3 ************ is_dowhlle ***************** } F U N C T I O N is_dowhlle : boolean; VAR flag : boolean; i,j : integer; Begin w i t h stmt do begls i:=l;j :=i; flag :- true; repeat w h i l e txt[i] in IBLANK,TABI do i :- i + i if l o w e r ( t x t [ i [ ) = dowh[j] thuo begi~ ~ := i + l; j := j * ~ ; end e l s e f l a g := f a l s e ; until (flag ~ a l s e ) o r ( d o w h [ i[ ~ ENDSTR); is dowbiie :- flag; end; ~ w i t h } End; { is d o w h i l e }

]

{l * * ~ * * * * * * g e t _ s t m t * * * * * * * * * ~ } F U N C T I O N get_stmt( VAR stmt : t stmt ):boulean; { Gets entire f o r t r a n statement, including continued { stmt.text[..] and the line nnmber if any is stored

lines,

Into

~nto

{ strut.hum[ ..] VAR 1,be : integer;

}

{ 2 *~***** begining ot_text ***'**~* } { finds the position of the first character of ~he a c t u a l { statement text, ~gnoring blanks,tabs, :md statement labels FUNCTION b e g i n i n g o i text(line : STRING) : i n t e g e r ; j,i

{ 3 *********** do_loop_type *************** FUNCTION do_loop_type : t~of_do; VAR o~s,i : integer;

: integer;

Begin { hegining~of text } i :~ COL 1 ; { in the first six columns then w h i l e ( i <= COL 6) a n d ( l i n e ~ i ] i := i ÷ 1 ; end; { while }

c a n be a n u m b e r , <> TAB) do b e g i n

blank,

or

a tab

i~ote temp_do

do begin

if txt[i] ~ EQUALS then begin repeat i := i+l; if txt[i] = SQUOTE then else if txt[i] - LPAREN until (i = tit fen) or ((txt~i] = COM>~)

determins if a statement is a do while or a non asd then p r o c e s s e s the stmt if n e c e s s a r y pr_stmt( VAR ~tmt : t stmt)~ VAR do_type : t_of_do; i : integer; {used in DEBUG}

standard

PROCEDURE

148

Adv. Eng Software, 1985, Vol. 7, No. 3

do loop

inquote := not i n q u o t e then f i n d r p a r e n ( t x t , i); and

[not

inquo[e))

if txt[i] - COMIiA then beg~n I := o ~ o s ÷ l; w h i l e (txt[i] in [BLANK,TAB[) do ~ : i*l; if txt[i] in [ o r d ( ' 0 " ) . . o r d ( ' 9 " ) ] then temp do := N O R M ~ D O else temp do :- DO NN; e n d { ~f comma [ else t e m p _ d o :- NO DO; { I~ no comma on line end { il equals then } else t e m p _ d o := NO_DO; { else end; { else begin } d o _ l o o p type := temp do; end; { with }

}

} }

}

Begin w i t h stmt do begin { d n l o o ~ t y p e } temp do :- NO_DOs i :~ 2 ; if 1 o w e r ( t x t [ l ] ) = LETD the~ w h i l e txt[~] in [BLANK,TAB[ do I : - ~*l; if l o w e r ( t x t [ i ] ) <> LETO then temp do : NO_DO e l s e begin o~os := x;

End;

*~***********

} }

inquote := f a l s e ; repeat i := x + i; if txt[i] = SQUOTE then inquote := not inquote; until ((txt[i] = EQUALS[ and (not inquote)) or (i >= txt

Begin { g e t _ s t m t } if DEBUG then writeln(chr(10),chr(10),'****** G E T STM~ * * * * * * ' , c h r ( 1 0 ) ) f~11 buff; stmt.txt_len := 0; { l~ne_flag indicates eof t[ lalse } { it is set in "fill buff" } if line_flag then begin get_stmt :- true; bc := 0 ; { buffer line p o s i t i o n polr/t~r / let ; O; { statement line count } repeat bc := bc + 1; tf real_stmt(buffer[bcl) then >egin lct :- let + 1; get txt(buffer[bc],let); end; { if then } until (bc = buff ct); end { If line flag ) else get stmt :- false; End; { get stmt }

stmt

: boolean; : t__of_do;

{ ~ ~e*~******* f i n d ~ r p a r e n * * * * * * * * * * * * } find_rparen(txt : t_text; VAR i : integer[ { a d v a n c e s the pointer "i" to the last R P A R E N of a set of { parentheses. It h a n d l e s nested p a r e n t h e s e s r e c u r s t v l y { i must be g i v e n a value in the calling routine. Begin If DEBUG then w r i t e l n ( ' f i n d rparen: i - ",i:1); repeat i :~ ~ + i; ~f txtlil = SQUOTE then inquote :- ~ot ~nquote else if txt]i] - LPAREN then f i n d _ r p a r e n ( t x t , i ) ; nntil (i - stmt.txt fen) or (txt[1] = RPAREN); End~ { f i n d _ r p a r e n >

}

{ 2 * * * * * * * * get_tit * * * * * * * * } PROCEDURE g e t _ t x t ( I i n e : STRING; VAR let : integer); VAR j : integer; inquote : boolean; Begin with stmt do begin j := b e g i n i n g _ o f _ t e x t ( l ~ n e ) ; if ict = i then t x t _ l e n := O; { else txt fen starts w h e r e it left off last tlme } while (j <7 MAXSTR) and (not(line[j{ in [ N E W L I N E , E N D S T R ] ) txt len := txt _ len + I; txt[txt fen] line{j[; j :- j + l; end; { while } end { with } End; { get_tit }

pr

}

PROCEDURE

{ find the first real character of the statement line w h i l e ( i < MAESTR) a n d (line{i[ i n {TAB,BLANK I ) a n d (not(line{i[ i n [NEWLINE,ENDBTR])) do l,eg~n i := i + l ; end; { while } { position of the first character ot t h e s t a t e m e n t } begining of text : - 1; End; { beginin~_of_text }

I *********

}

{ 3 ************ is_enddo *******~****** ~ F U N C T I O N is_enddo : boolean; VAR flag : boolean; i,j : integer; Begin w i t h stmt do begin i := COL I; j := COL i; flag := true; repeat w h i l e txt[i] in [BLANK,TAB[ do i := i + l;

case flag := true; DEBUG := false;

VAR

} statement

{ do_loop_type

if not

}

Begin with stmt do b e g i n { find_do type } temp_do := NO_DO; if l o w e r ( t x t [ l ] ) = LETE then begin if is enddo then t e m p _ d o := ENDDO end else if l o w e r ( t x t [ l ~ ) = LETD then if is_dowhile then temp__do :- D O W B I L E else temp_ do := d o _ l o o p _ t y p e ;

equals

}

fen) I

find_do_type := temp_do; end; { with ) if DEBUG then writeln(~find_do_type: End; ( f i n d d o _ t y p e }

{ 2 ********** pr_do ************ } PROCEDURE pr_do(VAR stmt : t_stmt; do_type { p r o c e s s a "do" statement } TYPE num_str = array[1..5) of character; VAR

i,j : integer; slinel : nu~str; aline2 : hum_sir; curt_do : t_of_do; d o ~ o s i t i o n : t buff

repeat

temp_do = ~,temp_do);

: t_of_do);

{ counter and loop indicia } { line number string xxxxx if(.not { line number string "guru yyyyy" line;

i := i ÷ l ; until lower(buffer[do.us,t)) = LETE; e ~ o s := i; { posit ion of the "e" in the dowbile for i := COL I to COL_5 do addstr[il := BLANK; addstr[COL 6T := CONTINUE_CHAR; addstr[COL 7] := BLANK; j := e ~ o s ; i := 7; repeat i :- i+l; j := j+l ; addstr[i] := b u f f e r [ d o . u s , j ) ; until (buffer[do_Dos,j) = EHDSTR); buffer[do__pos] :- addstr;

} }

{ buffer position of do stmt.

}

{ 3 ****** insert ******** } { the STRING instr is inserted into the buffer in front of b ~ o s } PROCEDURE insert( instr : STRING; VAR b ~ o s : integer); VAR i,j : integer; Begin ( insert ) for i := buff ct + i downto b_.pos + I do buffs=liT := buffer[i-l); buffer[b~s] := instr; buff_ct := buff_ct + I; b~pos := b ~ o s + i; End; { insert }

{ 3 ****** f i n d t h e do ******* } { a do statement is always the first non BLANK or } { non c o g e n t line in a the buffer FUNCTION find the do : t buff line; VAR i : t buff line; Begin i := 0; repeat i := i + I; until real_star(buffer[i]) find the do :~ i; End; { find the do } ch t o s t r ****** PROCEDURE ch tO s t r (n : integer; VAR s t r { translates i n t e g e r n into 5 c h a r s t r i n g VAR j : integer;

str[l] := o r d ( ' 0 " ) End; ( ch_to_str }

+ (n - n mod t e n [ 4 ] )

div ten[4];

addstr[COL_7) addstr[COL_8] addstr[COL_9]

)

:= o r d ( ' D ' ) ; := o r d ( ' O ' ) ; : - BLANK;

{ now g e t t h e number t o make a n o r m a l do l o o p ) ch._to_str(llne_a~m, sl inn2); I tue._num : " line_num+l ; f o r i := COL l 0 to COL~14 do a d d s t r [ i ] a d d a t r [ C O L _ l ~ ] :- NEWLINE; addstr[COL_16] := ENDSTR; insert(addstr,do~os);

{ 3 ********* pr_dowhile *********** } PROCEDURE pr_dowhile(VAR d o _ p o s : t buff line); V~R a d d s t r : STRING; i,j : integer; e~os : integer; { position of the e in "dowhile" last_real : integer;

)

Begin { put in line number - use existing number if it is there } if has_a_n~ber(buffer[do_pos]) then begin j := I; for i := COL_I to COL 5 do if b u f f e r l d o ~ o s , i ] in [ o r d ( ' 0 " ) . . o r d ( ' 9 " ) ] then begin slinel[j] := b u f f e r [do__Dos,i]; j :=j +l; end; for i :2 j to COL_5 do slinel[i] := BLANK; end e l s e begin ch to str(line_num,slinel); line_hum := line_hum + I;

end; if(.not." 12345678901234

for i :- COL l to COL_5 do addstr[ i) := BLANK; addstr[COL_6~ := CONTINUE_CHAR; addstr[COL_7] := BLANK; addstr[COL 8] := RPAREN;; for i :" COL 9 TO COL_S2 do addstr[i] :- sgoto[i-8]; addstr[COL_l~] := BLANK; for i := COL 14 to COL_18 do addstr[i] := sline2[i-13]; a d d s t r [ C O L l 9] := NEWLINE; addstr[COL20] := ENDSTR;

Begin if has_a_number(buffer[do._pos]) then begin j : - 1; for i :" COL~I to COL 5 do if buffer[do_pos,i~ in [ord('0")..ord('9")] t h e n b e g i n addstr[j] :- buffer[do_pos,i]; j :=j +1; end; f o r i := j to COL_6 do a d d s t r [ i ] : - BLANK; end else begin for i :- COL_I t o COL_6 do a d d s t r [ i ] := BLANK; end;

div ten[j-l]

repeat if line[j] IN [ord('l')..ord('9")] then mum_exist : - true { must be non 0 } else j : - j - I ; until (j = O) or (hum_exist); has. a_number :~ num._exist ; if DEBUG then writeln('has_a_number:', num._exist); End; {has_a._number)

} }

f o r i : - COL 1 t o C0~_5 do a d d s c r [ i ] a d d s t r [ C O L _ 6 ~ : - BLANK; f o r i : - COL 7 t o COL 1~ do a d d s t r [ i ] a d d s t r [ C O L _ l ~ ) : " REWLINE; a d d s t r [ C O L 16] : - ENDSTR; insert(addstr,do~os);

) }

{ 3 *********** p r _ d o _ n n ************** } PROCEDURE pr_do_nn(¥A~ do_poe : t b u f f l i n e ) ; ¥~ addstr : STRING; i,j : integer; o_pos : i n t e g e r ; ( p o s i t i o n o f t h e o i n t h e "do" )

{ 3 ******* has_a_number *******} FUNCTION h a s . _ a . _ ~ b e r (line : STRING) : boolean; { determins if there is an existing statement label for the { statement } VAR j : integer; n u ~ e x i s t : boolean; Begin { h a s _ a _ n u m b e r } j :E COL 5; { last legal column for a statement label } hum_exist := false;

{ pot i n { positions

build addstr to be " & )GOTO xxxxx" addstr positions are 123456789012345678

End; ( p r _ d o w h i l e

num_str); str}

- n mod t e n [ j - l ] )

get 2nd line number, for the trailing guru ) on the "if(.not ..... " } c h _ t o _ s t r ( l i n e _ ~ , aline2); llne._num :E line_~um + l;

the position to insert the return guru after the ) last real line in the buffer } for i :- I to buff ct do if ~ea1_atmt(b~ffer[i]) t h e n last_real := i; last _ real :- last --real + l; insert(addstr,last real);

{ 3 ******

Beg in { c h _ t o _ s t r } f o r j :- 1 to 4 DO str[6-jl := ord('O') + ( n mod t e n [ j ]

}

:" sline2[i-9];

{ now d e l e t e the "do" from t h e o r i g i n a l line } { and make the original a continued line } i := O; repeat i := i+l; until (lower(buffer[do_pus,i)) - LETO); o._pos := i; { position o f "o" in do } for i :2 COL I to COL_5 do addstr[i] := BLANK; a d d s t r [ C O L 6T := CONTINUE_C~AR; a d d s t r [ C O L 7] := BLANK; j := o _ p o s ; i : = 7; repeat i : - i+l; j : - j+l; addstr[i] := b u f f e r [ d o _ p o s , j ] ; until (buffer[do_pos.j] = ENDSTR); i f i > co1_72 t h e n b e g i n putstr(buffer[do__pos],atderr); measage('Strlug l o n g e r t h e n 72 a f t e r b e i n g p r o c e s s e d ' ) ; error('probably a t a b ( l c h a r . ) changed t o 5 b l a n k s ' ) ; end; b u f f e ~ [ d o _ p o s ] :" a d d s t r ; End; { pr_do_nn }

:= s l i n e l [ i ] ; :- sifnot[i-6];

{ delete the "dowhile" and make the line a continuation { t h e "if(.not." } i : = O;

of

}

{ 3 ********* p r _ e n d d o *********** } PROCEDURE p r _ e n d d o ( s l i n e l , s l i n e 2 : num._sir); { p r i n t s r e p l a c e m e n t f o r "ENDDO" l i n e a s s o c i a t e d VAR j : integer; end_pos : t_buff_line; l_temp : STRING;

Eegin { pr_enddo } i f DEBU~ t h e n w r i t e l n ( ' p r _ e n d d o :

curr_do-

w i t h a "WHILE" }

",curr._do);

Adv. Eng. Software, 1985, Vol. 7, No. 3

|~9

endjos

:= t t n d . . t h e _ d o ;

( i t the e n d d o l i n e h a s a n u m b e r L b e n t u r i : at i' ( into ##### cont lnue / i f ha~ _ a. n u m b t . r ( b u [ f t . r [ t . n d ~ o ~ ) ) lht't, ~,',1,: j l; f o r t : - DOt 1 t o COl $ do it bufl,.r[en:i~o~,i~ In [ord('O'J,.otd('9")l :hen l._temp[ II

ZZ. ThLs a l l o w s t o t 1296 u n i q u e names to be g e n e r a t e d . This should sufficient since a name is generated o n l y when a Io n K n a m e c a n n o t truncated without conflict. All variables t o be p r o c e s s e d (plus declared. The long varibles are obtained

begin

: = but f e r Eend po~, ~ ] ;

j : - j + 1; end ; ~ or i : " j t o COL_6 do 1 . t t . m p [ * ] := BLANK; f o r l : = COL 7 t o C O L _ I 4 do _tt.=p[*] :- ~ont:,:ut,[t-h{, l _ t e m p [ C O L 1 5 l := NEWI.1NE; l _ t e m p [ C O L 16] : - ENDSTR; £ n ~ e r t ( l _ t emp , e n d _ p o ~) ; end ; tf

curt_do * I~)WHILE t h e n b e g x m wr~te gore yyyyy , f o r j := COL I t o COL 6 do ] f i e m p [ j { ~ BIANK; / o r j :~ COL Y t o COL 10 dc i__r~mp[j', : - ~ g o t o ( l - ~ , ] ; l _ t e m p [ C O L 11{ ; - BI£NK; ~ o r j := C'~l. 17 t ~ COL !¢~ ~ I :,'mp~i :" ,,lln,.l{ I ll~; I _ L e m p { C O L 17] := NEWI.INE, l . . t e m p [ C O L 18] :~ ENDSTR; { have to ~hilt t h e i l n , ' s ,:; tt~, b u : : , . ~ It, u:,,K,, r, om { lot th,' t'xtla llnv ltl~.rt{i :,.ml,,c*~a p o s ) , v n d , { :~ c u r t _ d e - :R)WHIIV : : , ~ ; , xxxxx

cent:nun,

f o r j := COl. I t o l _ t e m p [ C O L 6J := t o t j : - COL ? t o

tills

IS don, '

COL 5 do

:or

both

I temp[]}

:-

~vl,*'~ o:

t, n c d o . .

[ [ t h e C$MODUI.E o p t i o n ~ ~sed thor: all global names are mapped into ~ unique name genermted from a fm~r letter prefix ~ h a t c a n be ~peci[ied by t h e u ~ e r w i t h • CSMODOI.E o p t i o n c a r d . T h e l a s t ~wo cb~racter~ are obtained £n t h e ~ame way a s f o r t h e l o c a l n a m e ~ . T h e default £m " M O ~ " . H the u~r doe~ not want a global name c h a n g e d , t h e n a m e m u ~ be p u t ~n ~ C $ V I S I 8 L E o p t i o n c a r d . N a m e s o n t h e v i s i b l e o p t i o n c a C d w i l l n o t b e p r o c e m ~ e d £n a n y w a y , e v e n ~[ ~ b e y a r e l o n g e r t h e n s£~ c h a r a c t e r s . T h e n a m e s m u s~ be s e p a r a t e d by: a cuba, tab, or b l a n k . A~ m a n y C ~ V I S I B L E c a r d ~ u~ ~ v c , . ~ s a r y may b e u ~ e o . Since the 5o~ware Tool~ macro processor ~s c a ~ e ~ e p e n d e n t th~ p r o s r a m wam w r i t t e n t o be ca~e d e p e n d e n ~ . V a r [ m b l e s ~n d i f [ e r e n ~ c~me m re d ~ [ ~ e r e n t var[able~ e v e n when ~ p e l l e d t h e ~am~. [ t i s t h e u ~ r ~ responsibility to b, con6~tan~ £~ u s i n g u p p e r a n d l u w e r ca6e n a m e ~ Code t h a t ~ u p p o r t s the oge of unde~corv~ as valid variable names is ~ncluded, bu¢ p r o t e c t e d by .~ b o o l o ~ because the ~acro processor ~ u s t be ¢ o d ~ [ [ e d :o tr~a~

COL 14 do

l_lemp[j[

:=

15] : - NEWI.INE; l . _t em p[ C O l . 16] : - ENDSTR; { replace enddo with I temp } bullet[end post : - !. l e a p ; { delete~;

tb,.

I m b e d e d b l a n k ~ ~() a v a r i a b l e name a r e be s p l ~ t a c r n s 6 c a r d b o u n d a r l e ~ with

"ENDIgV'

The INPUT

~ta;,. be

to

do~; USE

OF

b, -gl l :

pr

do(stot,do

typ,.'.

***~

iepeaI Line_flag : - get s t ~ t ( s t : : t ) . If line .fl~g (hl.n p~_~tmt(stmt), until (l~ne .flag - 1~1~}; {while177)

{ wrapper lnzt

gnO.

)

io;

~hzlet?? { ~rapper

~

LONGNM.SFT Creates a list of define statements for long variable names 6 characters h character

} i n FORTI~N ) name to } } }

T he u n i q u e ~ m e xs e i t h e r a truncated version of th,' original name } or tf truncation cause~ a conflict w i t h an e x ~ t t n g name, a new u n i q u e } n ame i~ g e n e r a t e d . Tile l x r a t four characters of the g~nerated name can} be s p e c i f i e d by t h e u s e r w i t h a CSUNIQUE o p t i o n : a r d . T he d e f a u l t fez the prefix x~ "UNIQ'*. Tile r e m a i n i n g twu Lharacters a r e d e t t . t m t n ¢ ' d by the order that the name~ are generated; starting a t O0 a n d e n d i n ~ a t

150

there

Adv. Eng. Software, 1985, Vol. 7, No. 3

a

:s

~nput and w r ~ t e a t : , ~ t a n d a r d o u t p u t }

has any C$1NChUDES p r o c e s s e d

VAX t a b

are

:.[,~t,,m,.nI

~:.,

conventions, be

or

end

o[

processed

comparable

OUt.

line

co--eats

by "~H2STD".

wlth

the

Sol/ware

O~ION C O U N T CARDS - - e x a m p l e c$flebug true -- dtagaostics on (true), o[f (raise)de/~ult cSmodule bt
The ca~e of The case of proces~ ~n~.

earn

the the

are

not

processed

t n a n y way

option keywords doe~ not matter. parameterb i~ p r e s e r v e d ttlrought)ut

tile

BUGS : Variable

nome~ a r e

ca~e

dependent.

If tbe re~ultln g name tlom proceeding a variable with underscores ks i e ~ s t h a n ~lx c h a f e . C l e f s l [ w i l l u o t be c h e c k e d f o r c o n f l i c t i o n with other vatiab)es. August

19~

. ......................................................

NESTING STURCTURE PR~H longnam~" - - ~ i n routine PUNCTION Lower - - maps a c h a i a c t t . r z n t o Low(.i c a s e < FUNCTION t e ~ / a i p h a -- t r u e . t~ L e s t c h a r a c t e r [~ a l p h a b e t i c > < FUNCTION t e s t n u m e r x c -- true if teat character ks a d i g i t > FONCTION e q u a l - - t r u e I f tw o s t r i n g ~ are equml, neglects case FUNCTION inlist -- true if name ia in the list FUNCTION h a s . . u n d ~ r ~ c o r e -- trut i f Dame h a ~ a n u n d e r ~ c o r ~ FUNCTION p u t _ l n _ l z s t - - p u t s na~," t n a p p r o r x a L e l ~ $ t i f t t 1~ n o t t h e t e FUNCTION g e / v a r -- gets a variable name F U N C T I O N l i n d _ s u b s e t -- L~u,. ~ s,*b~[r~ug Is f o u n d ~ t~.s} ~ t r £ n K F U N C T I O N ~ezltn*. -. ~ e ~ a {{n,' f r o m s ~ a m d a r d zapu~ PROCEDURE g e n s y m t a b l t . . . . g e n e r a t e s a symbol start' tabl~, PROCEDURE l u s t a l -- itlstals a ~ame i n t t i l e s y m b o l s t a t e :abl,. PROCEDU~ g e t n a m e ~ - - g e t ~ n a m e s t r o m d c i ~ t . a t e m e n t $ PROCEDURE s a y + . . n a m e - - ~av¢.s a v a r i a b l e name In the appropriate list PROCEDURE o u t p u t . d e f i n e s - * ~ u t p u t s the" d e f i t ~ e ~ t c ~ t a n d a r d o u t p u t PROCEDURE t r u n . a t v - - : i~l[)C;l:(.R .i txame, a n d ier.,)ve~ u n o , . r s c , , r e ~ PROCEDURE w r i t + . , tn'w_DaGl," "" W l t t e ~ it t l n l e l H l ' o r m a g : : i e :~am," PROCEDURE p r _ o p t l o n -- p r e ( : e w s o p t I o n c a r d m PROCEDURE i n i t i a l i z e -- tuztlallzv all constant v.irlab],'~; FUNCTION c h e c k _ d c l -- true if statement is a dcl FUNCTION c o n t i n u e d -- trite zf statement i~ c o n t t n u e ~ ...................................

~.........................

~........

{ next I*~ lohertt~ t h e c o r ~ s t a n t ~ arid u t i l i t i e s ot t b e [ inherit {'~terl : [ b l lb . ~ ( , f t t o o l . e n v x r o n ] g I o b d e f ~ .ellV" ) ] P R ~

LONGNM PROGRAM ( s f t ) P r o g r e ~ t o ! rod v a r i a b l e names longer than declaration statements and d e t e r m i n e a unique be u ~ e d im p l a c e o t t h e l o n g n a m e .

a~

:mdeIsc~,t,.s.

illegal, l o n f i:a m e s o u ~ t C o n l : n u a l l ( ~ n , , r:i~

det*.rml~,,

:o

[tom standard

n a m e ~ o[: u c S v l ~ x b [ o

thvn

~n

"}'R_USCORE" c;t]~;[ ~)e s.,[

proces~

A [l~L el deILne ~tatemen/~ tooI~ macro procesBor.

OUTPUT . . . do.typer',vurr,

........

Begin

to

~n t h e ~ o u r c e i t s h o u l d [ ~ r ~ t Stallntng terminatea wxth eof.

{ look ior the "end do" } repemt i! get_strut(strut) then bt.glu do t y p e : = t l n d _ d o , t y p e ; i[ do_type " EBD~ then pr.enddo(slinel,~ltne2) else if do_type £n [ ~ NN,dowhile] then pr_dn(~tmt,do_type) el*e [lu~h_ buffer ; etld else error('mt*s~ng cnddo to m~tck prevlmts "do ~truttures" "); until (do_type - END~); End; { pr_do }

End,

proKram

FORT~N a o u r c e t h a t

note,

I**** whileI;/ BeRzu {whzlef/l) ~nxt ~alzze;

ibis

table x~ u~ed ~cann~,(~.

program ~ e a d ~ ...

It

11 d o _ t y p e - ~ W H I I . E t h e n b e g i n pr d o w l n l e ( d o _ p o s ~ t / o n } ; f l u s h _bur [~'r ; ,,nd

Begin { pr_stmt ~ do. t y p v := l itld d o _ t y p e ; 1~ do t y p e i n [ D O . . N N . d o w b l l e ] vlse flush_b~l let i gt~d, { pr ~ t x l ?

for

Co~8~an[

not

A symbol declaratlon

flush_bur let ; End; { pr_enddo }

t , l ~ e 1: d o _ t y p e = ~ _ N N t h e n p r _ d o _ t m { do_ po ~ i t i o n ) ; flush buffer; ,'nd;

~n o t t e r

Tb,.

true

~b~acters :ou~tanl underscores

~

~cont~nue[j-b];

I_te=p[CO1.

B e ~ x n { pr._do } t : u r r _do : : d o _ t y p e ; do3osttlon : " i i n d . _ t h e _d~, tf DEB~ Lhen wrtteln('pr do:

alphanumeric characteI~.

to

~,llne2[J];

B~NK;

six letter variables) m u s t be by ~ c a n n l n g t u n d e c l a r a t i o n s .

The program can make the d~st~nctlun betwven local and ~[obm[ varxmbl~ names. The only ~loba[ names ~ n PORTRAN a r e suhrnutine, [unc[lo~, and co~oo b l o c k n m m e ~ . G l o b a l name~ a r e t r , , a ~ e d ~n t h e ~ame way ~ s l o c a l ~ a m e s .

valid

write

be be

{ill.ill;

CONST

lo~nmme a~

~t~tt

MAJ[YARLEN MA~LIST CARDLENGTH MAX~TRIN(; SY~M~ABSIZE PR_USCORE

STDSIZE

( anput .output t ttt~

it t~t

-

" =

COL6

PREFIXLEN

"

tools

) a

ttttt

32; 1296; 72; 81; tO0; TRUE;

b; 6; ~

So/tware

it

lit

t ~tt

~It

t t t ~ t

t~ttwt

t~ltt

tt~tt~tt

arbttray maximun variable lenght) maximum number ot unique nameg } I,*ngtb ot card to scan } m a x i m u ~ st r ~ n g L ~ n g L L ~' ~ t Z v o [ symbo~ s ~ a t e t a b l e } true --> p[oc~s under~core~ } s t a n d a r d v o r l a b D , n a m e szzv } culumn 6 } u n i q u e name p r e f i x length }

i

: : ~

TYPE

namestr christ t._lls~ t_varl~st t_.namelist

war

card end_dcl in_sixlist namelist in vs¢ list vie_list vis list ct six char list lastwasdcl syllable module_flag DEBDG { string sreal sintgr slgcl Icmplx sbyte sdble schar sfnctn sco~ subrtn

: : : : : : : : : : : :

packed array[l..~AXVARLEN]of C~ARACTER; s e t of 0 . . 1 2 7 ; { C~L~RACTER - eodfile } ( G L O B A I . , I . O C A L , V I S I B I . E L I S T , S I X I .I S T ) ; arrayll..~AXLlgT] of n a m e s t r ; arrayll..,½AXLlgTlof record scope : t_list; txt: namestr; end; { record }

flag : boolean; Begin ( inlint } t : " O; repeat i : " i ÷ 1; f l a g :- t r u e ; j : " 1; w h i l e ( j < 8AKVARI, EN) a n d ( n a m e [ j ] a n d f l a g do b e g i n i f n a m e [ j ] <> l i s t [ i , j ] the~ flag :- false; j :- j +l; end; { while } until ( i >= l i s t _ s i z e ) or flag; inligt := f l a g ; End; ( inlist }

l i n e of f o r t r a n code } string; e n d o f dcl n a m e } znteger; current number in stx_char_list } 0..~XLIST; record of l o n g names a n d scopes } t_namelzst; current n u m b e r in namelist } O..MAXLIST; g l o b a l names n o t to be c h a n g e d } t_varlist; current number in via_list } znteger; l i s t of s i x c h a r . v a t . n a m e s } t_varlzat; continuation card flag } boolean; array[LETA..LETZ,I . . S Y H T A B S I Z E ] of i n t e g e r ; { t r u e if m o d u l e option x s i n v o k e d } boolean; { true --> write out dzagnostics } boolean;

constants } : namestr : nsmestr : namestr : namestr; : ns~estr; : nsmestr; : namestr; : namestr; ~ namestr; : namestr;

resl } znteger ) logical ~ complex } byte } doubleprecision character } function ) co--on } subroutine )

<> ENDSTR)

(I ............... ham_underscore . . . . . . . . . . . . . . . . . . . . EUNCTION ham_underscore(name : namestr ) : b o o l e a n ; { returns t r u e i f s name h a s a n u n d e r s c o r e in it vat j : integer; flag : boolean; g e g i n { ham_underscore } j :- O; flag :- false; repeat j :-j.l; i f n a m e [ j ] " UNDERLINE t h e n f l a g : " t r u e ; until (name[j} = ENDSlIt) or (flag); ham_underscore :- flag; End; ( h a s _ u n d e r s c o r e }

)

)

)

(1 . . . . . . . . . . . . . . . . . . . . . . . . .

put_in_list ..................... ) : namestr; ltype : t_list); ( puts m ~ i n t h e s p e c i f i e d l i s t i f i t i s not i l r e a d y t h e r e ) { INPUTS u~me - - n a m e t o be p u t i n l i s t ) ( ltype -- list type, dete~ines w h i c h l i s t name g o e s i n } v a t i,j : i m t e g e r ; fLsg: boolesn;

procedure p u t _ i n . _ l i s t ( n a m e

defstr

; namestr;

( o p t i o n s~rings ) sdebug na~str; visible na~e.tr~ mo~mle namest r; unique namemtr; glob_preflx n~estr; lot_prefix n~estr ; chrset;{ christ; chrset;

delimiters alpha alp~nu~er~c

( **********************

general

define - -

for

output

}

{ prefix { prefix

for for

global names } local na~es }

on a s~ller ~chine these { s e t s c o u l d be s l d e s m a l l e r { than the full ascii set if

test

functions

} } necessary

}

***********************

{1 . . . . . . . . . . . . . . . . . lower ................. } FUNCTION l ~ e r ( i n _ c h : CIL~RACTER) : CHARACTER; { returns a i n l o w e r case } { assumes difference between upper ~ lower case is v a t c h : CHARACTER; Begin { lower ) if iu_¢h in [ord('A')..ord(°Z')] then ch :- in _ ch ÷ ord('a °) - ord('A') else ch :- in ch; lower :- ch; End; {l~er}

a constant

}

(~ <><><><~<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> { the folI~iug 2 rout i~s are ~ longer used but can be used ) ( in place of the sets "~[pha" and "aIphan~eric" [ n came t h e } ( aach£~ t h i s £s ~ p [ ~ ¢ e d on dose not al[~ mats chat b~g } (I ................. testalpha ................. ) FUNCTION [ e s c a I p h ¢ (ch : C~C~R) : boolean; { test [[ a character is an alpha assumes cont~nious ( and sequential character se~ } ~g£n {testalpha} testalpha :- (lo~er(cb) in [ord('n')..ord('z')]); End; (testa[pha}

}

{I . . . . . . . . . . . . . . . . . tenth,eric ................. } FUNCTION c e a t o ~ e r £ c (oh : C~ER) : boolenn; ( test £f a c h a r a c t e r is n~er[c nssumes coat £n~ous } { and sequential set of numbers } Begin {testnu~eric} testnumeri¢ :- false; if (oh in [ord('0")..ord('9")]) then cestn~mer£c :- ~rue e l s e [ f ( c h - U ~ E R L I ~ E ) a n d (PR_USCORE) t h e n t e s t n u ~ e r i c :- true; End; {testnumertc} { <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ~) {I . . . . . . . . . . . . . . . . . . . s e q o s l . . . . . . . . . . . . . . . . . . . . . . } ~unction sequal (war earl, sir2 : namestr) : ~olean; ( ~he progra~ in general £s c a s e dependent boa t h i s { rou¢£~ is only used with the option cards, £n { which case ~he case dose ~ matter, therefore this ( function ~glects the case of the strings tested

}

begin came l t y p e o f LOCAL, GLOBAL : begin i :-0; repeat i :- i*l; flag :- true; j :-l; while (j < ~ V A ~ L F ~ ) and (name{j] <) E N D $ ~ ) and flag do begin if uame[jl <> namelist[i].txt[j] then flag :" false; j :=j ÷I; end;{ while } { if flag makes it through the while and is } { still true then the ~me was in the list } until (i >- in vat list) or flag; if not flag then begin in vat list :" in vat list * I; namelist| in_vat_list] .txt :- n~ae; namelist[iu._var_list].scope :- Itype; end; { if not flag } end; { local, global } SIXLIST : begin i f not i n l i s t ( n ~ m e , s i ~ _ c h a r _ l i s t , i n _ s i x l i s t ) t h e n b e g i n i n _ s i x l i s t : - i n _ s i x l i s t * 1; six c h a r l i s t [ i n _ s ~ x l i s t ] :- name; end; { if ) end; ( sixlist } VISIgLE~IST : begin if not inlist(name,vis_list,vis_list_et) theu begin vim list ct :- vim list ct + 1; via_list[vie_list_el] :- name; end; { if } end; { vislist } end; { case } end; ( put_in_list } (1 . . . . . . . . . . . . . . . . . . . . function getvar

getvar .............................. } (vat s : string; vat varstart : integer; vat out : namestr; vsr lea : integer) : integer gets s variable name d e l i m i t e d by w h i t e s p a c e o r a c o ~ a . assumes variable name s t a r t s with In alpha character. INPUTS s -- earing to get varlahle from vsrstart -start looking for variable

OUTPUTS

out

i

end;

(1 . . . . . . . . . . . . . . . . inlist ................. FUN~ION inlis~(n~e : names~r; liar : t_varlist; lisc_si:~ : integer ): boolean;

i~T~I$

( decerains if the vat j,i :inreger;

name i s

in ~he specified

vat begin

list

list

)

terminated

with

a

o~e of the tollo~iu~ integers -- the polition of the first del~iting character after the variable -- 0 indicates last variable on line was gotten -- -1 indicates no v a r i a b l e was gotten and sol

j,tp,

i

: integer;

( &et~ar

}

i :- vlrstart; while (not (sill in alpha)) (s[il <> ENDSTR) a n d i :- i + 1;

)

na~e found,

leu -- length of variable obtained varstart -- first char of the variable

: integer;

{ eeq~l } i :- 1; ~bile {loner(earl[ill - l~er(etr2[i])) and (stri[i] <> E N ~ ) do i :" i + I; sequal :- (lo~er(scrl[iJ) - Iower(str2[i])); { sequsl )

variable

ENDSTR c h a r a c t e r .

vat

be~i~

--

varstart :- i; j:-l; while (s[i] in alphanumeric o,tijl :- ,[i];

and ( i < - I~KSTBING) do

)do begin

Adv. Eng. Software, 1985, Vol. 7, No. 3

t[[1

L :- k + l; j :- j ¢ 1 ~nd; ( ~hile }

{ lnittal~ze t h e symbol t a b l e to minus I f o r j : - I t o S Y ~ A B S I Z E do f o r ch : " o r d ( ' a ' ) to ord('z') do symtahle [cb,j] :- -l; {initialtze

out[jl : - Eb~)ST~; tp :- i; len :" j-l; if

not(*[il ;n delimiters) measage('GE~tAR: illegal putstr(a,S~DOUT); end; { i f oat i n d e l i m i t e r ~ { see while

then begin character

in v a r l a b l e

{ put k~y ~ o r d s in~tal(sreal); i~tal(s~n~r)~ inatal(scmplx)~ in~tal(slgcl); ~nstal(sbyte); in~tal(sdble); in~tal(schar); ~o~tal(~foctn); ins&al(scomm); ~nstal(snb~tn);

hams');

}

if variablr i s t h e l a s t one on t h v i u : , ' (not (s[i] in a l p h a ) ) and ( i < ~{AXSTRING) a n d ( s i L l <> ENDSTR) do t :- t ÷ ~;

/

~nd; If

ENDSTR) th,,n ~t ( j > 1) t h e n g e t v a r : : 0 { l a s t w,~rd on ~ l t : r else getvar := -'1 { no word ,~n [ l u r ~ else getvar :- rp; { gains Wt'[~; ~I: [l:c : It;'* •

it

debug then

~rtteln, end; { debug { getvar }

}

(l

matched wpos sublnd¢'t flag

............

vat

li

"

~XV^RI.EN);

integer; boolean; namestr; integer; integer; integer;

( position pointer ) ( b e g i n ~ n g p o i n t of a v a t . ( e n d o f v a r x b l e name }

name

(2 . . . . - - . . . . . . . . . Live_name ...... - ....... ~...... ) PROCEDORE D a v e _ n a m e ( n a m e : n a m e s * r ; l e n : z n t e g e r ; I L y p e : ~_ l i s t ) ; ( s a v e s a name i n t h e a p p r o p r i a t e list ~f i t zs n o t a l r e a d y t h e r e ( Uses a s e q u e n t i a l s e a r c h t h r u t h e l i s t tu ~znd t h e ~ame. ( ~NPUT$ na~e -~ name tO be aa~ed. { Inn -- length of name to be saved. { itype -- Izat type. vat

uflag

:

boolean;

{ Dave" nlme

Begin

: integer; : integer; lnteger~ : boolean;

End;

thee

begin

t:,p

Irv,,l

prors

( sa~e_~ame { IS*names

Beg~n

}

}

)

{ g p t r comes b a c k a s 0 o r t h e p o s i t i o n of t h e if find aubstr(card,sfnctn,8,gpt~) then begin laatwasdcl :- false; p t ~ : - g p t r * 1; it getvar(card,ptr,nlme,count) >~ 0 ~h~n slve._~ame(name,count,glohal); end ( if the~ }

e n d of

z! f i n d s u b s t r ( c a r d , s u b r t n , 1 0 , g p t r ~ th,'n lastwasdcl :- false; p t r := g p t r ¢ 1; if getvar(card,ptr,name,eount) - 0 thee save name(t.ame,count,g!obal)~ e n d { e l s e If

~,,.gln

else

else **********************

**************************

begin coutlt : - C. pit. rid : , p e t

* pos~ttot:

alter

,ht.~k.d~

the

substr

t

v h i l e p t r > O do b e g i n p t b e g l t ~ := p t e n d ; ptr :- g~tvar(card,ptbegln,name,count)~

{1 . . . . . . . . . . - .... gensymtabl, ......... ~......... ' PRC)CEI)I:R~ g e n s y m t a b ~ P , ~ g e n ( ' r a t v tL~' ~ y m b ~ ~,t.,~, ( a D ~ t ' f :

integer; : ~ntegrr; {tahl,, : CHARACTERs

xf p t r > 0 t h e n p t e n d :o p t r

p,}lnt~rt

cite

*2 . . . . . . . . . . inst*l ........... ~ PROCEIXJRE I n s t a l ( s y m b o l : names[i); { I n n [ a l l • l y r i c a l tn t h e symbol s t a t e t a b l e ) trite, lattttate,l : integer; * w a r a i u g : w i l l not w o r k t a r tram[, b e i n g s u b s e t of

another

~egin { iu•tal } ~ : " 1; lasts[ate := 1; state :" ~ymLable[symbol[l},laststate~i while s t a t e >* 0 do b e g ~ n I : " x ~ 1; laltstate :- state; silts :~ s y m t a b l e [ s y m b o l [ l ] , l a s t s t a t e ] ; end; symtable[symbol[l[.llststat~'l :~ p t ¢ l , w h i l e s y m b o l [ i ] <> ENDSTR do b e g i n g y m [ a b l e [ s y m b o l [ i] , p t :- pt¢l; pt :~ pt ÷ I ~ ~ := t e l ; end; symtabie[symbol[i-l~.pt-I ~ '), End; { instal } { geoaymtablr := I ;

Freud

lived iepei~

vat

152

: : : : : :

count, I saved name gptr ptbegin ptend

nflag :: ( h m s . u n d e r s c o r e ( n a m e ) and PR ~SCORE): if (Inn > stdsgze) or *uflag) then put. in. llst(uame,ltyp~.) else if (Itype " global) and m o d u l e flag and ( not inlzst(name,vis_list,vzs..list _ < t ) ) then pnt_in_list(na~e,global) else it (~en - stdsize) and not uflag then put_in_liat(nime.szxlist);

Beg~n ( f i n d s u b s t r } m a t c h e d : - O; w e n s := O; s u b i n d e x : " l ; f l a g := l a l s e i endsubatr := 0; while (matched < sublen) and ( s t r ] w p o s ÷ s u b i e n ] <> ENDSTR) a n d ( ( u p o s ¢ s u b l e n ) < HAXSTRIN(;) do if lower(str[wpos+aubinde×[) " lower(substr[subzndex[) m~tched :- matched ¢ l; s u b i n d e x := s u b i n d e x mod s u b l e n + 1; end vlb~. D t ~ l l l m a t c h e d := 0~ wpos : - wpus ¢ ; , end; { if } II ta~tched - sublefl then begin f l a g :" t r u e ; rndsnbstr : - wpos + s u b l e n ; ~nd ~ l i n d s t l h s t r : - tla~x; gild; { t l n d _ s u b s t t }

Begin pt

)

g e t names . . . . . . . .

)

Searches for # substr in the art Input. If a character falls t h e s e a r c h ts c a r r i e d out u s i n g t h a t c h a r a c t ~ . r and s h i f t i n g the window p o s i t i o n . When a c h a r a c t e r Is marcher% t h e c o m p a r i s o n s c o n t i n u e and w r a p a r o u n d t h e w i n d o w . D i s r e g a r d s t h e c a n e of b o t h the s t r i n g ant* t h e s u b s [ r i n g . R e f . "Ads f o r r i p e r | a n t e d Program~.rs"

] pt ('h

}

}

"i;

{1 . . . . . . . . . . . . . . . . . ftnd_substr ................. } FUNCTION f i a d _ s u b s t r ( s t r : string; substr : namestr; ~ u b l e n : ~ n t e g e r ; ~a~ ~ n d s ~ b ~ t r : l n t e g e r ) : b o o l e a n ;

vat

~ensysmboltable

table

". . . . . . . . . . . } PROCEDURE i s * n a m e s ( c a r d : string; /,tr lll~t,gcr J ~ { get~ t h v na~e~ o ~ t h e ~ c l l ~ e a~c put~ t h e ~ ~u ~h,. { appropseate ]lEt, { INPUTS c a r d - - s t r ~ n g ,~t (~,rtran ~ o u r c v c o d v ( ptr position at enc at dcl keyword

begin

repeat write(out[~l); i : - i + 1; until (out{~] " ENUSTR) o r

vat

tho

(s[x[=

write('gETVAR: var" t := l ;

end;

* of

into

)

}

Adv. Eng. Software, 1985, Vol. 7, No. 3

name I

:~

:-

ptbeggn

* count;

false;

if clrd[pteDd] - SLASN t h e n b e g i n ( c o ~ = o u b l o c k ~sme ) aave_oame(name0countoglobal); saved :- true; end e l s e zf c a r d [ p t e n d ] - LPAREN ~ h e n b e g z n { an array ie be£ng declared, o n l y n e e d t h e namr } save_name(name,count.local); s a v e d := t r u e ; j : - pten~; repe~ j :'~.I; until (card[j] = ENDSTR) or (card[j) - RPAREN) ~ (j >- ~ X S T R I N G • ~)~ gg card[j] - R P A R E N the~ else if card(j] - ENDSTR end; p~eud :- p~end • ~; until ( c m r d l p t e n d } " Eh~STR) (car~Ip&e~d] in alpha) (¢tend >- ~ I N G ) ; £~ not

eared

then

ptend : - ) [hen ptend

:~ j "" I~

or or

aave_~ame(n~me,couu~,~ocal};

}

} } } } }

end; { while } end; { if find_substr... End; { getnamee }

j : - 1; repeat putc(namelist[i].txt[j]); j :=j÷l; until ( j >- MAXVARLEN) or (namelist[il,txt[j] putt(COMMA);

}

{I ....... - ............ output_defines . . . . . . . . . . . . . . . . . . } PROCEDURE output_defines; generates a table of defines to be used with the macro processor t h e defines are written t~ standard output global names not in the visible list are mapped into sequential unique names using "gloh_.prefix". local nares are truncated. If truncation causes a conflict then a new name is generated using "loc~prefix". code is supplied for handleing underscores, but must be activated at compile time with the constant "PR_USCORE" CONST MAXSUFCHAR 36; { 0..9,A..Z }

else begin truncate(namelist[i].txt,tname); if inlist(tname,six char list,in_sixlist) then write new n a m e ( l o c ~ r e f ix,lvar) else begin { put t r u n c a t e d name in the six char list } in_sixlist :- in._sixlist * I; s i x char list[in sixlist] := tname; ( write out truncated name ) j :-1; w h i l e ( t n a m e [ j ] <> ENDSTR) and ( j < HAXSTRING) do b e g i n putc(tname[j]); j :- j + I; end; ( while }

= record end;

vat

s|,s2 : integer; { record }

{ counters

for the last 2 chrs.

i,j : integer; tname : uamestr; gvar,lvar : sufix_cntr; c h _ c t r : CHARACTER; ( c h a r a c t e r c o u n t e r } s u f i x : array[I..HAXSUFC~AR] of CMARACTER; { u s e d to g e t t h e l a s t two c h a r a c t e r s of t h e u n i q u e name }

end; { e l s e end; { else }

{2 " = ' = " . . . . . " - = ' ' ' ' ' " truncate -------------------------} ~rocedure t r u n c a t e ( i n n a m e : n a m e s t r ; v a r outname : n a m e s t r ) ; T r u n c a t e s a name to the STDSIZE and t a c k s a ENDSTR on t h e e n d . I f a name h a s u n d e r s c o r e s and t h e y a r e t o be p r o c e s s e d t h e y a r e removed and the result is truncated if it is still > STDSIZE BUG: does not check for conflict with names shorter than six characters. Conflict could occur if removing the underscores g e n e r a t e s a name s h o r t e r t h a n s i x c h a r a c t e r s t h a t a l r e a d y e x i s t in t h e fortran s o u r c e c o d e . INPUTS OUTPUTS

j :'0; repeat j :-j÷l; outnnme[j] :- inname[j]; until (j - STDSIZE) or (outname[j] - ENDSTR); if outname[j] <> ENDSTR then outname[STDSlZE + I] := ENDSTR; e n d ; { truncate } {2 ................... write_new_name . . . . ~ .............. } PROCEDURE write new name(prefix : n a m e s t r ; v a t s u f c t r : sufix_cntr); generates a unique name for a variable name using t h e user supplied prefix, o r the default prefix. INPUTS prefix -- first part of new name sufctr -- counters for the last two characters of the new name. OUTPUTS sufctr -- incremented by i

vat j : integer; g e g i n ( ~rlte n e w ~ m e } f o r j := l t o PREFIXLEN do p u t t ( p r e f i x [ j ] ) ; putc(eufiz[eufctr.sl]); putc(~iz[sufctr.e2] ); • ufctr.~2 : " sufctr.s2 + l; i f s ~ f c t r , e 2 = ~AXSUFC~L~R+I t h e n b e g i n s u f c t r . s 2 :- O; s u f c t r . s l :- s u f c t r . s l + 1; if s u f c t r . s l > MAXSUFCHAR t h e n m e s ~ a g e ( ' T o o many u n i q u e v a r i a b l e s end; { if eufctr... } End; { write new name }

putc(NEWLINE);

e n d ; { f o r i :- I to in vat list } End; { output_defines } {I ~ . . . . . . . . . . . . . . pr_option " .................. PROCEDURE pr_option(card : string); war o p t ~ o s , l p , l e n : integer; sour : aamestr; Begin { pr_option opt_poe :" 3;

}

)

l p := g e t v a r ( c a r d , o p t _ _ p o s , s o u t ,

fen);

if s e q u a l ( s d e b u g , s o u t ) then begin if getvar(card,lp,eout,len) >=0 t h e n b e g i n i f sour[l] i n [ o r d ( ' t ' ) , o r d ( ' T ' ) ] the~ DEBUG :" t r u e e l s e DEBUG := false; e n d ; ( if getvar... } end ( if sequal }

} e l e e if s e q u a l ( m o d u l e , s o u t ) then begin m o d u l e _ f l a g := t r u e ; if getvar(card,lp,eout,len) >- 0 then glob~prefix :- sour; i f DEBUG t h e n w r i t e l n ( ' P R _ O F T l O N : m o d u l e c a r d f o u n d ' ) ; end e l s e if s e q u a l ( u u i q u e , s o u t ) t h e n begin if g e t v a r ( c a r d , l p , s o u t , l e n ) >ffi 0 then I o c ~ r e f i x := sour; if DEBUG then writeln('PR_OPTlON: unique card found'); end else if sequal(visible,sout)then b e g i n repeat Ip :- getvar(card,lp,sout,len); if (Ip >= O) then put_in_list(sout,VISIBLELlgT); until (Ip <" O) or (vis list ct >= MAXLIST); if DEBUG then writeln('PR_OPTlON: visible c a r d found'); end; End;

{ pr_option

)

( l .................. ( initializes

ell

initialize ....................

constants

)

}

~egin

delimiters

:- (BIA[~,COI~4A,LPAREN,Eh'DSTR,NE~LINE,SLASH,STAR,T&B|;

alpha : " ~ o r d ( ' a ' ) . . o r d ( ' z ' ) , o r d ( ' A ' ) . . o r d ( ' Z ' ) J ; alphanumeric : - l o r d ( ' 0 " ) . . o r d ( ' 9 " ) ] + alpha; i f PR._USCORE then a l p h a n u m e r i c required');

( initialize sufix a r r a y } i : - 0; f o r c h ~ c t r : - ord('0") to ord('9") do begin i : - i + I; sufix[i] :" ch_ctr; end; ( for ) f o r ch._ctr := o r d ( ' A ' ) to o r d ( ' Z ' ) do b e g i n i :- i + 1; sufix[iJ : - c h _ c t r ; end; { for )

I to in war l i s t

}

P R O ~ E I ~ initialize;

gegin { output_defines } g v s r . s l := 1; g v a r . s 2 :~ 1; l v a r . e l := l ; I v a r . s 2 : " 1;

for i : -

putc(RPAREN);

inname - - name to be t r u n c a t e d , can have u n d e r s c o r e s outname - - t r u n c a t e d name e n d i n g w i t h a ENDSTR

v a t j,k : i n t e g e r ; begin if PR_USCORE then begin if has_underscore(inname) then begin k :" 0; j := 0; repeat j :-j÷l; if inname[j] <> UNDERLINE then begin k :- k + 1; i n n a m e [ k ] := i n n a m e [ j ] ; { j >- k so u s e same v a r i a b l e end; { xf inname } u n t i l ( j = MAXVARLEN) or (inuame[k] - ENDSTR); e n d , { if h a s _ u n d e r s c o r e } end; ( i f PR_USCOEE )

);

if (namelist[i].scope - GLOBAL) and (module_flag) then begin { names in the visible list were never saved in namelist } write new name(glob_pref ix,gvar); end { if global }

-

TYPE sufix~cntr

- ENDSTR

do b e g i n

j :" I; repeat putc(defstr[j]); j :- j +1; until ( d e f s t r { j / " ENDSTR) or ( j " b~XVARLEN); puCc(LPAREN);

steal[I]

:,

sreal[2] sreal[3] sreal[4] sreal[5]

::= := :=

sintgr[l] sintgr[2] siutgr[3] sintgr[4] sintgr[b] sintgr[6] sintgr[7] sintgr{8|

:= := := := :" := := :"

ord('i'); ord('n'); ord('t'); ord('e'); ord('g'); ord('e'); ord('r'); EMDSTR;

• cmplx[l] scmplx[2] ecmplx[3] scmplx[4] scmplx[5] scmplx[6] scmplx[7] scmplx[8]

::= :::-

ord('c');

slgc1[l] slgcl[2] slgcl[3] slgcl[4]

:= a l p h a n u m e r i c

÷ [UNDERLINE];

ord('r'); ord('e'); ord('a'); ord('l'); ENDSTR;

ord('o'); ord('m'); ord('p'); ord('l'); : = ord('e'); :- ord('x'); : " ENDSTR; :" ord('1"); :" o r d ( ' o ' ) ; := ord('g'); :- ord('i');

Adv. Eng. Software, 1985, Vol. 7, No. 3

153

slgcI[5] slgcl[6] slgcl[7] slgcl[8]

:= := := :=

ord('c'); ord('a'); ord('l'); ENDSTR;

sbyte[ll sbyte[2] sbyte[3] sbyte[4] sbyteI§]

:= ord(~b'); := ord('y'); := ord(~t~); := o r d ( ' e ' ) ;

:= ord('d') :- ord('o ~ ) :~ ord(~u ") :- ord('b') :- ord('l') :~ ord('e') := ord('p'); := ord(~r'); := ord(~e'); :ffi ord('c'); := ord('i'); := ord('s'); := ord('i*); := ord('o'); :ffiord('n'); := ENDSTR;

schar[ll schar[2] schar[3] schar[4] schar[5] schar[6] schar[7] schar[8] schar[9] schar[10]

:= ord(*c~); := ord('b~); := ord('a'); :ffi ord('r*); := ord('a*); := ord('c'); := ord('t'); := ord(*e'); := ord('r'); := ENDSTR;

subrtn[l] subrtn[2] subrtn[3] subrtn[41 subrtn[5} subrtn[6] subrtn[7] subrtn[8] subrtn[91 subrtn[lO[ subrtn[ll[

loc~refix[l] loc ~refix[2] loc~refix[3[ loc~refix[4]

:= := := :=

gensymtable;

( initialize symbol state table }

visible[l] visible[2] visible[3] visible[4] visible[5] visible[6] visible[7] visible[8]

debug lastwasd¢l module_flag in vat list in_sixlist vis__list_Ct

ord('U'); ord('N'); ord('l'); ord('O');

var cptr state dclflag ch

unique[If unique[2] unique[3] unique[4] unique[5] unique[6] unique[7]

::~ := := ::= :=

ord('u'); ord('n'); ord('i'); ord('q'); ord('u'); ord('e'); ENDSTR;

sdebug[l] sdehug[2~ sdebug[3] sdebug[4] sdebug[5] sdebug[6]

:ffi := ::= := :=

ord('d'); ord('e~); ord('b'); ord('u'); ord('g'); ENDSTR;

defstr[l] defstr[2] defstr[3] defstr[4] defstr[5] defstr[6] defstr[7]

::= := := :~ := :=

ord('d'); ord('e'); ord('f'); ord('i¢); ord('n¢); ord('e¢); ENDSTR;

{ default value of g l o b ~ r e f i x g l o h ~ r e f i x [ l ] := ord('M'); g l o b ~ r e f i x [ 2 ] := ord('O');

integer; { card pointer } integer; { used in symbol state table } boolean; CHARACTER;

while (state > O) and not(card[cptr] cptr :- cptr + 1 ; ch := lower(card[cptr]);

= ENDSTR) do begin

if (ch in alpha) then state := symtable[ch,state] else if not(ch in [BLANK,TAB]) then state := -1; { not a dcl } if state = 0 then dcl_flag :- true; end; { while } if dcl_flag then end dcl := cptr + 1 else end_dcl := 0; if debug then writeln('check dcl: ",dc[_flag); check_dcl := dcl_f]ag; End; { check_dcl } {I ............. continued . . . . . . . . . . . . . . . . . ) FUNCTION continued(card : string): boolean; { the first six columns are searched for a non blank character ( if that character is a tab then the line is nnt cotltlnued { i f t h e f ~ r s t non b l a n k c h a r a c t e r i s i n c o l u m n s i s a n d not a { tab or 0 then the ltne ts continued vat cp : 0..MAXSTRING; { card position } cflag : boolean; { continued flag } Begin { continued } ep := l; cflag := false; while ( c p <= COL6) and (card[cp] = BLANK) do cp := cp + i; if (cp > COL6) or (card[cp] = TAB) then cflag := false else if cp ~ COL6 then begin if card[cp] " ord('0") then cflag :- false else cflag :" true; end; ( else if } continued := cflag; End; { continued } { ******************** main procedure ************************* Begi~

ord('m*); ord(*o'); ord('d'); ord('u'); ord('l'); ord('e'); ENDSTR;

: : : :

Begin { check _ dcl } dcl_flag false; cptr := I; state := I;

:= ord('v ~ ) :ffi ord('i') :ffi ord('s') : - ord('i') :- ord('b') :- ord('l ~) :ffi ord('e') := ENDSTR; := := :ffi := := :~ :=

}

{I ............. check _ dcl ................. } check_dcl(card : string; var end_dcl : integer) : boolean; checks to see if a card is a declaration card. Uses the symbol } state table to determine if the card has a reserved word on it ) input -- card, a line of fortran code } output -- end_dcl, positlon of first character after the } end of the reserved word. } returns -- true if dcl card is found. }

ord('f'); ord('u'); ord('n'); ord('c'); ord('t'); ord('i'); ord(*o'); ord('n¢); ENDSTR;

module[if module[2] module[3] module[4] module[5] module[6] module[7]

false; false; { inltialize for continuation checking false; O; ( initialize llst counters } O; O;

FUNCTION

ord('c'); ord('o'); ord('m'); ord('m'); ord('o'); ord('n'); ENDSTR;

:= := ::= := := ::ffi :=

:= ::~ :* :* :=

End; { initialize )

:- ord(*s'); := ord('u'); := ord('b'); := ord('r'); := ord('o'); := ord('u'); := ord(~t'); := ord('i'); := ord('n*); := ord('e~); := ENDSTR;

:= := := := := := :=

sfnctn[l} sfnctn[2] sfnctn[3] sfnctn[4] sfnctn[5] sfnctn{6] sfnctn[7] sfnctn[8] sfnctn[9]

154

:= ord('D'); := ord('U');

:= ENDSTR;

sdble[II sdble[2] sdhle[3] sdble[4] sdble[5] sdble[6] sdble[7] sdhleIS~ sdbleIg] sdble[10] sdble[ll] sdble[12] sable[13] sdble[14l sdble[15] sdble[16]

scomm[l] sen=f2] scoff31 scomm[4] scomm[5] scomm[6] scowl7]

glob~refix[3] glob~refix[4]

{main}

initio;

{ initializes software tools constants,types and variables

initialize;

{ initializes all the variables, used in the main procedure }

arrays and tables

while getline(card,STDIN,MAXSTR) do begin if (lower(card[l]) = LETC) and (card[2] = DOLLAR) then pr_option(card) else if not (lower(card[If) in [LETC,STAR]) then if check_dcl(card,end_dcl) then begin getnames(card,end_dcl); lastwasdcl := true; end else if (lastwasdcl) and continued(card) then { if a line is continued the text has to start } { in at least column 7 } getnames(card,7) else lastwasdcl := false; end; { while } output~define s; End. ( longname }

DEFINE.SFT Processes the define statements for global names }

Adv. khg. Software, 1985, Vol. 7, No. 3

{ ( ~

DEFINE PROGRAM (sft) FUNCTION -- define reads from standard input,

looking for macro

end;

definitions of the form define([dent,string). } and writes tO standard output with each subsequent instance of the } the identifier ideal replaced by the sequence of characters string.} String must be he,lanced in parentheses. The text of each definition proper results in no output of text. Each replacement string is rescanned for further possible replacements, permitting multilevel definitions. NOTE this program may be modified to handle underscores by adding an underscore to the valid characters of the utility "isalphanm~" EXAMPLE define(endfile,(-l)) define(done,endfile) if (getit(line) = done) then putit(sumline);

if (getit(line) " ( - i ) ) put it ( s ~ l i n e ) ;

( g e t p b c - - g e t a ( p o s s i b l y pushed back) c h a r a c t e r f u n c t i o n getpbc ( v a t c : c h a r a c t e r ) : c h a r a c t e r ; begin i f ( b p > O) t h e n c := b u f [ b p ] else begin bp : - i ; buf[bp} := g e t c ( c ) end; if (C <> ENDFILE) then bp := bp - i; g e t p b c := c end; ( p b s t r - - push s t r i n g back o n t o i n p u t } p r o c e d u r e p b s t r (war s : s t r i n g ) ; vat i : integer; begin for i :- length(s) downto I do putback(s[i]) end;

then

BUGS A recursive definition such as define(x,x) loop when x is invoked

will cause an infinite

REFERENCE Kernighan & P l a u g e r , "Software Tools in Pascal" ~ d i s o n - W e s l e y Publishing Company, Reading, MA

198l { gettok -- get token for define ) function gettok (vat token : string; toksize : integer) : character; vat i : integer; done : boolean; begin i := I ; done : - f a l s e ; while (not done) and (i ~ toksize) do if (isalphanum(getpbc(token[i]))) then i:=i+l else done : - t r u e ; if (i >- toksize) t h e n error('define: token too long'); if (i > 1) then begin { some alpha was seen } putback(token[i]); i :" i - 1 end; { e l s e single n o n - a l p h a n u m e r i c ) token[i+l] := ENDSTR; gettok :- token[l}

wrapper (CU) -- this is the wrapper for all the software tools This next line inherits all the global definitions that go along with the software t o o l s . [ inherit ('userl : [bllb.sof ttool .environ} globdefs ,env') ] program wrapper( input , o u t p u t ) ; { define -- simple string replacement procedure define; { defcons -- coust declarations coast BUFSIZE = 500; MAXCMARS - 5000; MAXDEF - MAXSTR; MAXTOK = MAXSTR; HASRSIZE - 53;

macro processor

for define { { { { {

}

}

size of pushback buffer size of uame-defn table max chars in a defn } max chars in a token } size of hash table }

} }

{ deftype - - type definitions for define } type c h a r p o s = 1..MAXCHARS; c h a r b u f - a r r a y [I..MAXCHARS] of c h a r a c t e r ; s t t y p e - (DEFTI~E, MACTYPE); { symbol t a b l e t y p e s ) n d p t r = Andblock; ( p o i n t e r t o a name-defn b l o c k ) ndblock = record { name-defn block } name : c h a r p o s ; defn : charpoa; k i n d : sttype; nextptr : ndptr end; {defvar

--

vat declarations

for define

)

vat h a s h i s h : a r r a y [I..HASHSIZE] of n d p t r ; ndtable : charbuf; nexttab : charpos; { first f r e e p o s i t i o n i n n d t a b l e } bur : a r r a y [ I . . B U F S I Z E ] o f c h a r a c t e r ; { f o r pushback } bp : 0 . . B U F S I Z E ; { n e x t a v a i l a b l e c h a r a c t e r ; init=0 } defn : s t r i n g ; token : string; toktype : sttype; { t y p e r e t u r n e d by lookup } defuame : string; { value is "define" } null : string; { value is "" } { defproc

--

p r o c e d u r e s needed by define

}

{ c s c o p y - - copy c b [ i ] . . , to s t r i n g s } p r o c e d u r e cscopy ( v a t cb : c h a r b u f ; i : c h a r p o s ; vat s : string); vat j : integer; begin j :- 1; w h i l e ( c b [ i ] <> E~DSTR) do b e g i n s[j] :- c b [ i ] ; i :- i + l ; j :" j + I end; s[j] :- ES~STR end;

{ sccopy -~ copy string s to cb[i] . . . } p r o c e d u r e sccopy ( v a t s : s t r i n g ; v a t cb : c h a r b u f ; i : charpos); vat j : integer; begin j :- I; while (s[j[ <> ENDSTR) do begin cbIi] := s[jl; j := j + I; i := i + 1 end ; c b [ i ] : " ENDSTR end; ( putback

--

push c h a r a c t e r

back o n t o i n p u t

p r o c e d u r e p~tback (c : c h a r a c t e r ) ; begin if (bp >- Bt~SIZE) then e r r o r ( ' t o o many c h a r a c t e r s bp : - bp + I ; buf[bp] :- c

)

end;

( g e t d e f - - g e t name and d e f i n i t i o n } procedure getdef (vat token : string; toksize : integer; vet defu : string; defeize : integer); vat i, nlpar : integer; c : character; begin t o R n [ l } : - ENDSTR; { i n c a s e of bad i n p u t ) d e f n [ 1 ] : " ENDSTR; i f ( g e t p b c ( c ) <> LPAREN) t h e n m e s s a g e ( ' d e f l n e : missing l e f t p a t e n ' ) e l s e if ( n o t i s l e t t e r ( g e t t o k ( t o k e n , toksize))) then m e s s a g e ( ' d e f i n e : n o n - a l p h a n u m e r i c name*) e l s e if ( 8 e t p b c ( c ) <> COI~fA) t h e n m e s s a g e ( ' d e f i n e : m i s s i n g cou~a in d e f i n e ' ) e l s e begin { got " ( n a m e , " s o f a r } w h i l e ( g e t p b c ( c ) - BLANK) do ; ( skip leading blanks ) putback(c) ; { went one tOO f a r } n l p a r :m O; i := I ; w h i l e ( n l p a r >= O) do b e g i n i f ( i >" d e f s l z e ) t h e n error('deflne: d e f i n i t i o n too l o n g ' ) e l s e i f ( S e t p b c ( d e f n [ i ] ) = ENDFILE) t h e n error('defiue: missing right paren') e l s e i f ( d e f n [ i ] = LPA~EN) t h e n nlpar :" nlpar + I else if ( d e f n [ i ] " RPAR~N) then n l p a r : " n l p a r - 1; { e l s e normal c h a r a c t e r in defu[i] } i:'i+l end;

defn[i-l]

: - ENDSTR

end end;

{ inithesh -- initialize hash t a b l e to n i l } procedure inithash; vat i : I..HASHSIZE; begin nexttab := l; { first free s l o t in table } for i : " I to HASHSXZE do hashtab[i] :~ nil end; ( h a s h - - compute h a s h f u n c t i o n of a name ) f u n c t i o n hash ( v a t name : s t r i n g ) : i n t e g e r ; vat i, h : i n t e g e r ; begin h : - 0; for i :- I to lem~tb(name)

do h :" (3 * h + name[i}) barb :- h + 1

}

~ o d ~ASHSIZE;

end; pushed b a c k ' ) ;

{ h a s h f i n d - - f l a d ~ m e i~ hash t a b l e f u n c t i o n h a s h f i n d ( v a t name : s t r i n g ) vat

ad ,

} : ndptr;

Vo Z: oo

p : ndptr; tempname : strlng; found : b o o l e a n ;

p : udptr; ~,eK~n p :- h a ~ h f z n d ( n a m e ) : i~ (p - n i l ) t h e n lookup :~ f a l s e else begin lookup := t , u e ~ cscopy(ndtablv, p'.defn, t - p'.kind end

begin found := ~alse; p :- hashtab[hash(name)]; while (not found) and (p <> nil) do begin cscopy(ndtable, p'.name, tempname); if (equal(name, tempname)) then found :~ true else p :~ p'.nextptr end; hashfind :- p end; { install -- add name, definition and type to table } procedure install (vat name, defn : string; t : sttype) vat h, dlen, nlen : integer; p : ndptr; begin ulen :- length(name) + i; { I for ENDSTR dlen :- length(defn) + I; if (nexttab + mien + dlen > HAX¢~ARS) then begin put~tr(n&me, SYDERR); error(': too many definition~') end else begin { put it at front of chain } h :- hash(name); new(p); p^.nextptr :~ hashtab[h]; hashtab[h] :- p; p~.name :- nexttab; secopy(n&m~, ndtable, nexttab); nexttab :- nexttab + mien; p^.defn :" nexttab; se¢opy{de[n, ndtable, nexttab); nextt~b :~ nexttab + dlen; p*.kind :l t end end; { lookup -- locate n~me, get defn ~nd ~ype from t&ble } function lookup (v~r u~me, defm : s~rimg; vlr t : sttype) •

boolean;

va~

l~,q~, ~ H ~ I ~ ~ . ) ~ . ~ .,:~1~, Iz~ 7 , ~ . ~

defn);

end; ( initdef -- initialize variables for define ) procedure i n i t d e f ; begin ( setstring(defname, "definer); } d e f n a m e [ l ] := o r d ( ' d " ) ; defname[2] := o r d ( " e " ) ; defname[3] := o r d ( ' f ' ) ; defname[4] := o r d ( " i ~ ) ; defname[5] := o r d ( ' n ' ) ; de£name[6] := o r d ( ' e ' ) ; defname[7] : - ENDSTR; bp : - 0 ; ( pushback b u f f e r p o i n t e r } inithash end; begin null[l] :- E~DSTR; initdef; install(defname, null, DEFTYPE); while (gettok(token, MAXTOK) <> ENDFILE) do if (not isletter(token[l])) then putstr(token, STIIOUT) e l s e if (not lookup(token, defn, t o k t y p e ) ) then p u t s t r ( t o k e n , STI~UT) ( undefined ) e l s e i f ( t o k t y p e u DEF~YPE) t h e n b e g i n { defn getdef(token, HAXTOK, defn, MAXDEF); install(token, defn, HACTYPE) end else pbstr(defn) ( push replacement onto xnpu~ end; begin { wrapper } initio; { Call program here. For example: filter } define end. { wrapper )

)