Fortran 2 C Translator

I’ve had some success with a Basic 2 C translator in the past. In that project I used hand coded Flex and Bison but came at the project from a rather naive perspective. While the project worked and I produced working code from old Basic programs it bogged down when I tried to convert my parse tree into structured code and do some optimizations on it.

Recently I tripped across the BNFC (BNF Converter) which translates a BNF grammer to a lexical analyzer and parser with code to generate a parse tree. Thus I can now scrap my hobbled together lexor/parser and convert it to a much more uniform version. This should be much easier to keep up-to-date and should facilitate improvements such as structuring.

I need to read their book Implementing Programming Languages first. Well, actually, I just need to understand LBNF (Labelled BNF grammar) and its use in BNFC. On the BNFC website they give an example LBNF grammar for C (which I know quite well — at least compared to Haskell). Hopefully that will detail how to deal with Fortran’s position dependent code. This is going to take a while so stay tuned …

Here’s a snippet of code that I want to translate. This is the GALAXY.FOR file from the DECUS Galaxy project. This game is a multi-player game (somewhat of a rarity at the time) which was played on a mainframe computer (Dec-10) .

This file is actually in Ratfor. Ratfor is pre-processor for Fortran66 (and here) which adds (badly needed) structure to the Fortran source code:

[cc lang=”fortran” tab_size=”8″ lines=”100″ width=”600″] C ASCII “0” PROGRAM PLAYER C C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR C MAY 1980 BILL CAEL AND BILL WOOD ADDED DEFAULT SHIP AND DIRECTION C MAY 1980 BILL WOOD ADDED ENERGY NETS C MAY 1980 BILL CAEL AND BILL WOOD RECODED OUTPUT C MAY 1980 BILL CAEL, BILL WOOD, AND BOB STODOLA C RECODED COMMAND ARG PROMPTING C NOV 1980 BILL WOOD CONVERTED TO RUN ON VAX C C July/August 1981 Stuart Renes, Western Electric Co. C Mixed Case messages, added sound effects C Improved Driver controls C ^C Intercept AST, Exit handler C Play periods (including weekend control) C VT100 advanced video features – renamed GALAXY V1.0 C Lowered Refresh rates in half C C Version 1.1 September 8th, 1981 C Added purge of type-ahead when destroyed or at games end. C C Version 1.2 September 10th, 1981 C Added silent play option. C C Version 1.3 September 17th, 1981 C Added Shared Command Display and control. C More code cleanup. C C Version 1.4 September 23rd, 1981 C Tighten window in which users can beat the “SHARED” feature. C C Version 1.5 September 27th, 1981 C Fix bugs that creeped in from V1.4. C C Version 1.6 October 2nd, 1981 C Changed Initialization to force active players off. C Slight esthetic change at close of game period. C Describe previously un-documented features in HELP file. C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON common/local/shrflg(8) common/double/share(8),busy(8) logical*1 busy integer share,shrflg,day character*9 today character*80 header character*4 V data V /’V1.6’/ common/signal/playtm integer timcnt data timcnt/4/ logical*1 playtm,wizard,myplay,shpflg,yesshr LOGICAL*1OK, DONE, YES, WARN, REFRES, REFTOG LOGICAL QUIKUP,supflg common done common/silent/belflg logical*1 belflg character*19 paswrd,answer character*8 timbf byte pasbuf(19) data paswrd/’starship enterprise’/ REAL SC(9), R(9) INTEGER DEFSHP, OLDSHP REAL DEFDIR, OLDDIR COMMON/DEFLTS/DEFSHP, DEFDIR, OLDDIR, OLDSHP, DEFSHD LOGICAL CLEARF, VERBOS COMMON/MESS/CLEARF, VERBOS BYTE BLANK(80), ALPHA, MESBUF(60) REAL D1(4) BYTE BLUNK(2) BYTE BLUNK2(2) BYTE OBUFF( – 9: + 9, – 9: + 9) BYTE JUNK, NBUFF COMMON/BNDRY/IXX, IYY, ID, MINID8, JUNK, NBUFF( – 9: + 9, – 9: + *9) INTEGER COMMND common/me/who INTEGER WHO EQUIVALENCE(BLUNK(2), NBUFF( – 9, – 9)) EQUIVALENCE(BLUNK2(2), OBUFF( – 9, – 9)) DATA BLANK/80*’ ‘/ DATA BLUNK, BLUNK2/4*’ ‘/ DATA SC/9* – 9999./ DATA R/9* – 9999./ DATA DONE/.FALSE./ DATA OK/.FALSE./ wizard=.false. DATA DEFDIR/0.0/, DEFSHD/0.0/ C C QUIKUP IS SET TRUE IF TERMINAL SPEED EXCEEDS A THRESHOLD C DETERMINED IN GTCHAR. C IF QUIKUP IS TRUE, A FULL SCREEN UPDATE OCCURS EVERY 1/2 SECOND; C AT SLOWER SPEEDS, 1/2 THE SCREEN IS UPDATED EVERY SECOND ON THE C HALF SECOND, THE OTHER 1/2 IS UPDATED EVERY SECOND ON THE SECOND. C THIS ALLOWS ENJOYABLE GAMES ON TERMINALS AS SLOW AS 1200 BAUD. C C GET QUIKUP, INITIALIZE TERMINAL IO C C If supflg is .FALSE. then terminal type is NOT supported and we will C exit and give him an explaination. C If MYPLAY is .FALSE. then it must be OFFHOURS and we won’t let him in! C CALL GTCHAR(QUIKUP,supflg) If (supflg) goto 1000 write(5,1999) 1999 format(‘ You obviously didn”t read the instructions 1 about terminal setup.’) call exit 1000 call daytim(myplay) call video(‘<') If (myplay) goto 1998 call clear call outch(0,0) write(5,1995) 1995 format(' I''m sorry but the Galaxy is CLOSED now.',//, 1' Entrance is allowed only to those who can',/, 1'$demonstrate their worthiness. ') call inchar(pasbuf,19,.false.,3,nc,ierr) call clear call outch(0,0) if (ierr .ge. 0) goto 1993 If (ierr .eq. -2) then call video('5') write(5,1992) 1992 format(' I''m sorry but you are clearly unworthy!',/ 1,' Come back during regular hours of play.') call video('0') call exit endif 1993 encode(19,9934,answer)pasbuf 9934 format(19a1) If (answer .ne. paswrd) goto 1996 wizard=.true. goto 1998 1996 call video('5') write(5,1992) call video('0') call exit 1998 call clear call outch(0,0) call weekday(day) call date(today) If (day .eq. 0)header='Welcome to GALAXY '//V//' on Wednesday, '//today If (day .eq. 1) header='Welcome to GALAXY '//V//' on Thursday, '//today If (day .eq. 2) header='Welcome to GALAXY '//V//' on Friday, '//today If (day .eq. 3) header='Welcome to GALAXY '//V//' on Saturday, '//today If (day .eq. 4) header='Welcome to GALAXY '//V//' on Sunday, '//today If (day .eq. 5) header='Welcome to GALAXY '//V//' on Monday, '//today If (day .eq. 6) header='Welcome to GALAXY '//V//' on Tuesday, '//today If (day .gt. 6) header='Welcome to GALAXY '//V//', '//today ih=index(header,'-') WRITE(5, 1001)header(1:ih+6) 1001 format(' ',a) 2000 CONTINUE WRITE(5, 1011) 1011 FORMAT('0The following Vessels are available:'/) shpflg=.false. DO 2030 I = 1, 8 IF (.NOT.(.NOT.XSHIP(I))) GOTO 2050 If (busy(i)) goto 2050 WRITE(5, 1021) I 1021 FORMAT(' Ship ', I1) shpflg=.true. 2050 CONTINUE 2030 CONTINUE 2040 CONTINUE if (shpflg) goto 1030 write(5,1032) 1032 format(' I''m sorry but all Ships have launched...',/, 1' It may be possible to share a Command...') 1030 WRITE(5, 1031) 1031 FORMAT(/'$Pick a Ship from our starfleet: ') CALL GETINT(0, IW, OK, 1, 8, 0) IF (.NOT.(OK)) GOTO 2070 IF (.NOT.(IW .EQ. 0)) GOTO 2090 OK = .FALSE. GOTO 2010 2090 CONTINUE WHO = IW If (.not.(busy(who))) goto 1039 Write(5,9699)who 9699 format('0Sorry, ship ',i1,' is temporarily disabled!') goto 1042 1039 IF (.NOT.(XSHIP(WHO))) GOTO 2110 If (share(who).eq.-1.or.share(who).eq.1) then 9918 WRITE(5, 1041)who 1041 FORMAT('0Ship ',i1' already has a full crew. Sorry!') 1042 call wait(60,1,m) goto 1998 endif WRITE(5, 1051)who 1051 FORMAT('$Ship ',i1,' already has a Commander.', 1' Do you wish to share this Command? ') CALL YESNO(0, OK) If ((ok) .and. (share(who) .eq. 1 .or. share(who) .eq. -1)) goto 9918 If (ok) share(who)=1 2110 CONTINUE GOTO 2080 2070 CONTINUE call clear call outch(0,0) write(5,4554) 4554 format(' Those who cannot follow instructions 1 cannot become Starfleet Commanders!') CALL EXIT 2080 CONTINUE 2010 IF (.NOT.(OK)) GOTO 1998 2020 CONTINUE If (.not.(xship(who))) then xship(who)=.true. If (share(who) .eq. 0) then header='Allow Sharing? ' call respnd(header,yesshr) If (share(who) .eq. 0 .and. (.not.(yesshr))) share(who)=-1 If (share(who) .eq. 1 .and. (.not.(yesshr))) then write(5,901) 901 format(' Oops, someone else has slipped into the cockpit!') endif else yesshr=.true. endif endif header='Silent Game? ' call respnd(header,belflg) call video('h') REFRES = .TRUE. REFTOG = .FALSE. CREW(WHO) = CREW(WHO) + 1 DEFSHP = WHO CALL STRMOV(BLUNK2, 1, 361, OBUFF, 1) CALL RBUFF IF (.NOT.(.NOT.QUIKUP)) GOTO 2130 C START 1 SECOND TIMER IF SLOW UPDATE CALL MARK(3, 30, 1, IDS) 2130 CONTINUE C START 1/2 SECOND TIMER CALL MARK(2, 15, 1, IDS) 2150 CONTINUE C C THE FOLLOWING CALL SPAWNS THE MTREKD UNIVERSE MANAGER TASK ON TT0:. C IF YOU CANNOT DO SOMETHING SIMILAR, YOU MUST START MTREKD YOURSELF C BEFORE PLAYING EACH GAME. C IF (.NOT.(THRU)) GOTO 2180 C THEN MTREKD ISN'T RUNNING c CALL RUNMTR C C PLACE LOCAL SCAN ON TERMINAL C 2180 CONTINUE timcnt=timcnt+1 if (timcnt .lt. 4) goto 9078 timcnt=0 call time(timbf) call tpos(12,70) encode(8,9009,mesbuf)timbf 9009 format (a8) call outch(mesbuf,8) 9078 call video('7') REFTOG = (.NOT.REFTOG) .OR. QUIKUP IF (.NOT.((XSHIP(WHO) .AND. REFTOG) .OR. REFRES)) GOTO 5555 C DON'T REFRESH IF BLOWN UP! CALL STRMOV(BLUNK, 1, 361, NBUFF, 1) ID = SCAN(WHO) MINID8 = MIN(ID, 8) IXX = XCORD(WHO) IYY = YCORD(WHO) IXLOW = MAX(2, IXX - ID) IXHI = MIN(99, IXX + ID) IYLOW = MAX(2, IYY - ID) IYHI = MIN(99, IYY + MINID8) DO 2220 IX1 = IXLOW, IXHI IX = IX1 - IXX DO 2240 IY1 = IYLOW, IYHI IY = IY1 - IYY ALPHA = UNIV(IX1, IY1) IF (.NOT.((ALPHA .GE. 48+1) .AND. (ALPHA .LE. 48+8) .AND. *(CLOAK(ALPHA-48)))) GOTO 2260 NBUFF(IX, IY) = EMPTY GOTO 2270 2260 CONTINUE IF (.NOT.(ALPHA .LT. 0)) GOTO 2280 NBUFF(IX, IY) = '%' GOTO 2290 2280 CONTINUE NBUFF(IX, IY) = ALPHA 2290 CONTINUE 2270 CONTINUE 2240 CONTINUE 2250 CONTINUE 2220 CONTINUE 2230 CONTINUE IF (.NOT.(IXX-ID .LE. 1)) GOTO 2300 CALL BNDRY(1, 1, MAX(1, IYY - ID), MIN(100, IYY + MINID8)) GOTO 2310 2300 CONTINUE IF (.NOT.(IXX+ID .GE. 100)) GOTO 2320 CALL BNDRY(100, 100, MAX(1, IYY - ID), MIN(100, IYY + MINI *D8)) 2320 CONTINUE 2310 CONTINUE IF (.NOT.(IYY-ID .LE. 1)) GOTO 2340 CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 1, 1) GOTO 2350 2340 CONTINUE IF (.NOT.(IYY+ID .GE. 100)) GOTO 2360 CALL BNDRY(MAX(1, IXX - ID), MIN(99, IXX + ID), 100, 100) 2360 CONTINUE 2350 CONTINUE IF (.NOT.(NBUFF(-ID, -ID) .EQ. EMPTY)) GOTO 2380 NBUFF( - ID, - ID) = '.' 2380 CONTINUE IF (.NOT.(NBUFF(-ID, MINID8) .EQ. EMPTY)) GOTO 2400 NBUFF( - ID, MINID8) = '.' 2400 CONTINUE IF (.NOT.(NBUFF(ID, MINID8) .EQ. EMPTY)) GOTO 2420 NBUFF(ID, MINID8) = '.' 2420 CONTINUE IF (.NOT.(NBUFF(ID, -ID) .EQ. EMPTY)) GOTO 2440 NBUFF(ID, - ID) = '.' 2440 CONTINUE DO 2460 IY = - 9, + 8 ICURSX = - 999 DO 2480 IX = - 9, + 9 IF (.NOT.(NBUFF(IX, IY) .NE. OBUFF(IX, IY))) GOTO 2500 IF (.NOT.(ICURSX .GE. IX-2)) GOTO 2520 DO 2540 III = ICURSX + 1, IX CALL OUTCH(' ', 1) CALL OUTCH(NBUFF(III, IY), 1) 2540 CONTINUE 2550 CONTINUE GOTO 2530 2520 CONTINUE CALL TPOS(9 - IY, 2*IX + 43) CALL OUTCH(NBUFF(IX, IY), 1) 2530 CONTINUE ICURSX = IX OBUFF(IX, IY) = NBUFF(IX, IY) 2500 CONTINUE 2480 CONTINUE 2490 CONTINUE 2460 CONTINUE 2470 CONTINUE CALL OUTCH(0, - 1) 5555 call video('0') C C THE FOLLOWING WAIT CONTROLS THE UPDATE RATE, WHICH IS NORMALLY C SET TO A HALF SECOND (30 CLOCK TICKS). C 2200 CONTINUE IF (.NOT.(COMMND .NE. ' ' .AND. XSHIP(WHO))) GOTO 2560 IF (.NOT.(REFTOG)) GOTO 2580 CALL WAITFR(2, IDS) IF (.NOT.(QUIKUP)) GOTO 2600 C RESTART 1/2 SECOND TIMER CALL MARK(2, 15, 1, IDS) 2600 CONTINUE GOTO 2590 2580 CONTINUE CALL WAITFR(3, IDS) C RESTART 1 SECOND TIMER CALL MARK(3, 30, 1, IDS) C RESTART 1/2 SECOND TIMER CALL MARK(2, 15, 1, IDS) 2590 CONTINUE 2560 CONTINUE Do 7666 ibb=1,8 If (share(ibb) .ne. -1) then If (shrflg(ibb) .ne. share(ibb)) then if (share(ibb) .eq. 1) then if (ibb .eq. who) then call video('1') else call video('7') endif call buffil((ibb+1),63,'Shr''d',5) If (ibb .eq. who) then call video('0') endif endif if (share(ibb) .eq. 0) then call buffil((ibb+1),63,' ',5) endif shrflg(ibb)=share(ibb) endif endif 7666 continue If (playtm) goto 2998 If (wizard) goto 2998 crew(who)=crew(who)-1 if (.not.(crew(who) .le. 400)) goto 9979 xship(who)=.false. goto 9969 9979 xship(who)=.true. 9969 call outch(0,0) call purge call beeper(7) call tpos(23,20) call video('1') call outstr(.false.,'The GALAXY is now closed. Thanks for playing 1!',.false.) call video('0') call outch(0,0) If (share(who) .eq. 1) share(who)=0 If (.not.(yesshr)) share(who)=0 call exit 2998 NC = 1 COMMND = '0 ' IF (.NOT.(XSHIP(WHO))) GOTO 2620 CALL TREAD(COMMND, NC) C C CHECK FOR NO INPUT C 2620 CONTINUE IF (.NOT.(COMMND .EQ. '0 ')) GOTO 2640 C C LONG RANGE SCAN COMMAND C GOTO 2650 2640 CONTINUE IF (.NOT.(COMMND .EQ. 'L ')) GOTO 2660 CALL GETINT('Target Ship? ', II, OK, 1, 8, DEFSHP) IF (.NOT.(OK)) GOTO 2680 DEFSHP = II IX = XCORD(II)/10. IY = YCORD(II)/10. CALL TPOS(18, 75) ENCODE(5, 1071, MESBUF) IX, IY 1071 FORMAT(I2, ',', I2) CALL OUTCH(MESBUF, 5) XX = XCORD(WHO) YY = YCORD(WHO) X1 = XCORD(II) IF (.NOT.(X1 .LT. 51.)) GOTO 2700 X2 = X1 + 100. GOTO 2710 2700 CONTINUE X2 = X1 - 100. 2710 CONTINUE Y1 = YCORD(II) IF (.NOT.(Y1 .LT. 51.)) GOTO 2720 Y2 = Y1 + 100. GOTO 2730 2720 CONTINUE Y2 = Y1 - 100. 2730 CONTINUE D1(1) = ((XX - X1)**2 + (YY - Y1)**2)**.5 D1(2) = ((XX - X1)**2 + (YY - Y2)**2)**.5 D1(3) = ((XX - X2)**2 + (YY - Y1)**2)**.5 D1(4) = ((XX - X2)**2 + (YY - Y2)**2)**.5 IIT = 1 DO 2740 J = 2, 4 IF (.NOT.(D1(J) .LT. D1(IIT))) GOTO 2760 IIT = J 2760 CONTINUE 2740 CONTINUE 2750 CONTINUE D = D1(IIT) IF (.NOT.(IIT .EQ. 1)) GOTO 2780 YD = Y1 XD = X1 GOTO 2790 2780 CONTINUE IF (.NOT.(IIT .EQ. 2)) GOTO 2800 YD = Y2 XD = X1 GOTO 2810 2800 CONTINUE IF (.NOT.(IIT .EQ. 3)) GOTO 2820 YD = Y1 XD = X2 GOTO 2830 2820 CONTINUE YD = Y2 XD = X2 2830 CONTINUE 2810 CONTINUE 2790 CONTINUE EDIS = D EDIR = ATAN3((YD - YY), (XD - XX))*57.29577951 IF (.NOT.(EDIR .LT. 0.)) GOTO 2840 EDIR = EDIR + 360. 2840 CONTINUE IF (.NOT.(EDIR .GT. 90.)) GOTO 2860 EDIR = (450. - EDIR)/30. GOTO 2870 2860 CONTINUE EDIR = (90. - EDIR)/30. 2870 CONTINUE DEFDIR = EDIR CALL TPOS(17, 75) ENCODE(5, 1081, MESBUF) EDIS 1081 FORMAT(F5.2) CALL OUTCH(MESBUF, 5) CALL TPOS(16, 75) ENCODE(5, 1091, MESBUF) EDIR 1091 FORMAT(F5.2) CALL OUTCH(MESBUF, 5) CALL TPOS(15, 79) ENCODE(1, 1101, MESBUF) DEFSHP 1101 FORMAT(I1) CALL OUTCH(MESBUF, 1) CALL OUTCH(0, - 1) 2680 CONTINUE [/cc]