While going through some old CDs I came across one containing all of the source code for our old ADG/SCADA system (retired 1998). I remembered one horrifyingly bad piece of code that I later rewrote and I thought it might be interesting to post it as an object lesson in how not to write code. I am sure there are worse pieces of code out there in production systems but most are thankfully hidden because the source code is not available (it reminds me about the adage regarding the law and sausages).
The code was written in SFORX (extended FORTRAN which, when run through a preprocessor resulted in standard FORTRAN). All $ keywords are SFORX extensions.
Added 2012-06-29 17:36 - The original code was not written by me
SUBROUTINE READALL(UNIT,BUFF,*,*,IFIRST)
C*TTL READALL READ FROM ANYTHING
C
C
C
C THIS SUBROUTINE IS USED FOR READING COMPRESSED OR UNCOMPRESSED
C DATA INPUT FILES FROM LFC 'UNIT' INTO 80 BYTE ARRAYY BUFF.
C END RETURNS TO FIRST RETURN, ERROR RTETURNS TO SECOND
C IFIRST IS LOGICAL WHICH CALLER PROVIDES TRUE ON
C FIRST READ OFF OF THIS ALLOCATION OF THIS LFC, ELSE FALSE
C*PGMXX READALL SAVD TOOLS FS$READA ON 07/23/80 17:43:51 01819B00R01
LOGICAL IFIRST
INTEGER*1 BUFF(80)
INTEGER*4 UNIT
INTEGER*1 BYTE(120,2)
C
C
INTEGER*1 IN(2)/2*0/,ISP(2)/2*0/,ITX(2)/2*0/,NB(2)/2*0/
INTEGER*1 NBT(2)/2*1/
INTEGER*1 KCR/ZBF/,KLR/Z9F/
INTEGER*1 EOR/ZFF/
INTEGER*2 NSEQ(2)/2*0/,ITY(6),ISEQ(60,2),ICKS(60,2)
INTEGER*4 LFC(2)/2*0/
INTEGER*4 K,N,IERR,IN0,ISP0,ITX0,NB0,IS,I,ISUM,J
C
C
EQUIVALENCE (BYTE(3,1),ICKS(1,1)),(BYTE(5,1),ISEQ(1,1))
C
C
IF(.NOT.IFIRST) GO TO 21
DO 19 K=1,2
IN(K) = 0
ISP(K) = 0
ITX(K) = 0
NB(K) = 0
NBT(K) = 1
NSEQ(K) = 0
LFC(K) = 0
19 CONTINUE
21 CONTINUE
DO 101 N=1,2
IF (UNIT.EQ.LFC(N)) GO TO 103
IF (LFC(N).EQ.0) GO TO 102
101 CONTINUE
GO TO 94
102 LFC(N) = UNIT
CALL W:PDEV(UNIT,ITY)
NBT(N) = 1
IF (ITY(3).GE.4.AND.ITY(3).LE.6) NBT(N)=2
103 IERR = 0
IN0 = IN(N)
ISP0 = ISP(N)
ITX0 = ITX(N)
NB0 = NB(N)
1 IF (IN0.NE.0) GO TO 8
2 CALL BUFFERIN(UNIT,0,BYTE(1,N),30)
CALL M:WAIT(UNIT)
CALL STATUS(UNIT,IS,NB0)
IF (IS-3) 3,80,90
3 IF (BYTE(1,N).EQ.KCR.OR.BYTE(1,N).EQ.KLR) GO TO 6
NB0 = NB0*NBT(N)
DO 4 I=1,NB0
IF (BYTE(I,N).EQ.10.OR.BYTE(I,N).EQ.13) BYTE(I,N) = 1R
4 BUFF(I) = BYTE(I,N)
IF (NB0.GE.80) GO TO 20
I = I+1
DO 5 I=I,80
5 BUFF(I) = 1R
GO TO 20
6 NB0 = BYTE(2,N)
IF (NB0.GT.114) GO TO 91
ISUM = 0
DO 7 I=1,NB0
7 ISUM = ISUM+BYTE(I+6,N)
IF (ISUM.NE.ICKS(1,N)) GO TO 92
IF (ISEQ(1,N).NE.NSEQ(N)) GO TO 93
NSEQ(N) = NSEQ(N)+1
IN0 = 7
8 DO 16 I=1,80
IF (ISP0.NE.0) GO TO 9
IF (ITX0.NE.0) GO TO 12
IF (BYTE(IN0,N).EQ.EOR) GO TO 9
ISP0 = BYTE(IN0,N)
IF (ISP0.GT.81-I) GO TO 91
IN0 = IN0+1
GO TO 10
9 ISP0 = ISP0-1
10 IF (ISP0.EQ.0) GO TO 11
BUFF(I) = 1R
GO TO 16
11 IF (BYTE(IN0,N).EQ.EOR) GO TO 9
ITX0 = BYTE(IN0,N)
IF (ITX0.GT.81-I) GO TO 91
IN0 = IN0+1
12 BUFF(I) = BYTE(IN0,N)
IF (BUFF(I).EQ.10.OR.BUFF(I).EQ.13) BUFF(I) = 1R
ITX0 = ITX0-1
13 IN0 = IN0+1
IF (IN0.LE.NB0+6) GO TO 16
CALL BUFFERIN(UNIT,0,BYTE(1,N),30)
CALL M:WAIT(UNIT)
CALL STATUS(UNIT,IS,NB0)
IF (IS-3) 14,80,90
14 IF (BYTE(1,N).NE.KCR.AND.BYTE(1,N).NE.KLR) GO TO 91
NB0 = BYTE(2,N)
IF (NB0.GT.114) GO TO 91
ISUM = 0
DO 15 J=1,NB0
15 ISUM = ISUM+BYTE(J+6,N)
IF (ISUM.NE.ICKS(1,N)) GO TO 92
IF (ISEQ(1,N).NE.NSEQ(N)) GO TO 93
NSEQ(N) = NSEQ(N)+1
IN0 = 7
16 CONTINUE
IF (BYTE(IN0,N).NE.EOR) GO TO 91
ISP0 = 0
IF (ITX0.NE.0) GO TO 91
IN0 = IN0+1
IF (IN0.GT.NB0+6) IN0 = 0
IF (BYTE(1,N).EQ.KLR.AND.IN0.EQ.0) NSEQ(N) = 0
20 IN(N) = IN0
ISP(N) = ISP0
ITX(N) = ITX0
NB(N) = NB0
RETURN
80 NSEQ(N) = 0
IN(N) = ISP(N) = ITX(N) = 0
RETURN 1
90 IERR = 1
91 IERR = IERR+1
92 IERR = IERR+1
93 IERR = IERR+1
94 IERR = IERR+1
IN(N) = ISP(N) = ITX(N) = 0
BUFF(1) = IERR
RETURN 2
END
The "unraveled" code is as follows:
C*TTL READ - READ A COMPRESSES OR UNCOMPRESSED RECORD FROM FILE
SUBROUTINE READ ( FILE , REC , LREC , * , * , STAT )
C*PGMJD READ SAVD MHTOOLS READ ON 10/03/91 13:59:58 JIM
C =====================================================================
C =
C = NAME:
C =
C = (MHTOOLS)READ READ (FTN)
C =
C = SYNOPSIS:
C =
C = READ A RECORD FROM A COMPRESSED OR UNCOMPRESSED FILE.
C =
C = CALLING SEQUENCE:
C =
C = CALL READ ( FILE , REC , LREC , $EOF , $ERR , STAT )
C =
C = PARAMETERS:
C =
C = FILE: ID I- INPUT FILE NAME IN CURRENT USERNAME
C = $EOF: I- RETURN FOR END OF FILE
C = $ERR: I- RETURN FOR READ ERROR
C = REC: IB* -O BUFFER TO CONTAIN INPUT RECORD
C = LREC: IW -O NUMBER OF CHARACTERS IN CURRENT RECORD
C = STAT: IW -O RETURN STATUS
C =
C = 0 - OK
C = -1 - END OF FILE
C = 1-99 - SEE RETURN CODES FOR M:ALOC1
C = 101 - READ ERROR
C = 102 - BAD BYTE COUNT IN RECORD (COMPRESSED)
C = 103 - SEQUENCE NUMBER OUT OF ORDER (COMPRESSED)
C =
C = NOTE:
C =
C = ONLY ONE FILE CAN BE READ AT A TIME, HOWEVER, MANY FILES CAN
C = BE READ SEQUENTIALLY.
C =
C = MAKE:
C =
C = SUBMIT SFORB MHTOOLS READ
C =
C = AUDIT:
C =
C = 911003 JD UPDATED HEADER
C = 900829 JD RECOVED SOURCE AFTER HEAD CRASH ON PACK 007
C = 890926 JD UNRAVELED DECOMPRESSION LOGIC
C = 880322 JD EXPANDED BUFFER TO HANDLE 132 CHARS MAX
C = 880314 JD IMPLEMENTED
C =
C =====================================================================
C*EJE
INTEGER *8 FILE ! FILE TO READ
INTEGER *8 OLDFILE /-1/ ! LAST FILE READ
INTEGER *1 REC (1) ! RETURNED RECORD
INTEGER *4 LREC ! LENGTH OF RETURNED RECORD
INTEGER *4 STAT ! I/O STATUS RETURN
INTEGER *4 LFC /0/ ! FILE INPUT LOGICAL FILE CODE
INTEGER *2 OLDSEQ /-1/ ! SEQ # OF PREVIOUS BLOCK
INTEGER *2 NEWSEQ ! SEQ # OF CURRENT BLOCK
INTEGER *4 NBYTES /0/ ! # BYTES OF DATA IN BLOCK
INTEGER *4 LBUFW /34/ ! # WORDS ALLOCATED TO BUFFER
INTEGER *4 BUFW (34) ! BLOCK INPUT BUFFER
INTEGER *2 BUFH (68) ; EQUIVALENCE (BUFW,BUFH)
INTEGER *1 BUF (136) ; EQUIVALENCE (BUFW,BUFB)
INTEGER *2 EOR /ZFF/ ! END OF RECORD INDICATOR
INTEGER *4 I ! LOOP INDEX
INTEGER *4 NI /1/ ! NEXT BYTE IN
INTEGER *4 NO /1/ ! NEXT BYTE OUT
INTEGER *4 NB ! NUMBER OF BYTES OR BLANKS
C --- CHECK IF INITIAL CALL FOR A FILE OR NEW FILE REQUESTED
$IF (LFC .EQ. 0 .OR. OLDFILE .NE. FILE)
OLDSEQ = -1
NI = NO = 1
NBYTES = 0
STAT = 0
BUF(W) = ' '
LFC = 'RD1 '
OLDFILE = FILE
CALL M:DALOC (LFC)
CALL M:ALOC1 (LFC,FILE,,,.TRUE.,,STAT)
$IF (STAT .NE. 0)
LFC = 0
RETURN 2
$ENDI
$ENDI
C --- KEEP GOING UNTIL A COMPLETE RECORD IS TRANSFERRED
$WHILE (.TRUE.)
C --- IF NO MORE DATA BYTES, READ ANOTHER BLOCK
$WHILE (NBYTES .LE. 0)
$CALL READNEXT
$ENDW
C --- GET NUMBER OF BLANKS TO EXPAND
NB = BUF(NI); NI = NI + 1 ; NBYTES = NBYTES - 1
$IF (NB .EQ. EOR)
$BREAK
$ENDI
$WHILE (NB .GT. 0)
REC(NO) = ' '
NO = NO + 1; NB = NB - 1
$ENDW
C --- GET NUMBER OF CHARACTERS TO COPY
NB = BUF(NI); NI = NI + 1 ; NBYTES = NBYTES - 1
$IF (NB .EQ. EOR)
$BREAK
$ENDI
$WHILE (NB .GT. 0)
REC(NO) = BUF(NI)
NO = NO + 1; NI = NI + 1
NB = NB - 1; NBYTES = NBYTES - 1
$ENDW
$ENDW
C --- UPDATE BUFFER POINTERS, FIND RECORD LENGTH AND RETURN
LREC = NO - 1; NO = 1
RETURN
C*TTL READ NEXT RECORD
C ================
$SUB READNEXT
C =============
C --- GET THE NEXT DATA BLOCK
CALL BUFFERIN (LFC,0,BUFW,LBUFW) ! READ NEXT BLOCK
CALL M:WAIT (LFC) ! WAIT FOR I/O COMPLETION
CALL STATUS (LFC,STAT,NBYTES) ! GET STATUS AND # OF BYTES
C --- CHECK FOR END OF FILE OR ERROR
$IF (STAT .EQ. 3)
LFC = 0
STAT = -1
RETURN 1 ! END OF FILE
$ENDI
$IF (STAT .GT. 3)
LFC = 0
STAT = 101
RETURN 2 ! ERROR
$ENDI
STAT = 0
$IF (BUF(1) .EQ. 2ZBF .OR. BUF(1) .EQ. 2Z9F)
C --- THIS IS A COMPRESSED FILE, RESET BUFFER VARIABLES
NBYTES = BUF(2)
NEWSEQ = BUFH(3)
NI = 7
C --- CHECK FOR SEQUENCE ERROR
$IF (NEWSEQ .NE. OLDSEQ + 1)
STAT = 103
RETURN 2 ! SEQUENCE ERROR
$ENDI
OLDSEQ = NEWSEQ
$ELSE
C --- FILE IS UNCOMPRESSED - COPY DATA VERBATIM
$FOR I = 1 , NBYTES
REC(I) = BUF(I)
$ENDF
C --- SET RECORD LENGTH - CLEAR NBYTES TO FORCE READ ON NEXT CALL
LREC = NBYTES; NBYTES = 0
RETURN
$ENDI
$ENDS
END