.TITLE EXF -- FORTRAN ERROR EXTRACTOR .ENABL LC ; ; ; * * ** ** *** ** * * ; ** ** * * * * * * * * ** ** ; * * * **** * *** * * * * ; * * * * * * * * * * * * ; * * * * ** * * ** *** *** ; ; ; Asea Brown Boveri b.v. ; afd. industriele automatisering ; postbus 301, 3000 AH Rotterdam ; telefoon: 010-4078911 ; ; Auteur : J.H.HAMAKERS ; Account : 1,24 ; File : EXF.MAC ; Datum : 24-MAR-82 ; Gewijz : 31-may-88 .ident /JHA03/ ; ; Edited: ; ; 14-Oct-83 V02a JHA02 Exit with status ; 31-May-88 V02b JHA03 Changed for F77 v5.2 ; ; Macro calls to the system ; .MCALL EXST$S ,QIOW$S ,GTIM$S ;JHA02 .MCALL FCSMC$ ,GET$R ,PRINT$ .MCALL GCMLB$ ,GCML$ .MCALL CSI$ ,CSI$1 ,CSI$2 .MCALL FDAT$R ; FCSMC$ ; ; Logical units ; LSTLUN = 1 EXFLUN = 2 CSILUN = 5 MSGLUN = 6 ; ; Other definitions ; OFFSET = 128. ; OFFSET IN MESSAGE FILE MAXDPT = 1 ; NESTING DEPTH @ FF = 14 ; ;JHA03 ; RECL=LSTFDB+F.NRBD ; RECORD LENGTH .SBTTL FCS DATA PIECE ; .NLIST BEX ; ; FSRSZ$ 3 ; MAX. 3 FILES OPEN AT SAME TIME ; .SBTTL COMMAND LINE BLOCK ; GCMBLK: GCMLB$ MAXDPT,EXF,,CSILUN ; .SBTTL INTERPRETER BLOCK ; CSI$ ; CSIBLK: .BLKB C.SIZE ; ; ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; .SBTTL FILE CONTROL BLOCK FOR .EXF ; EXFFDB: FDBDF$ ; FDAT$A R.VAR ; FDOP$A EXFLUN,EXFDSD,EXFDFB,FO.WRT,FA.ENB!FA.DLK ; ; EXFDFB: NMBLK$ ,EXF,,SY,0 ; DEFAULTS ; EXFDSD: .BLKW 6 ; EXF DESCRIPTOR ; EXFDV: .ASCII /TI0:/ ; DEFAULT DEVICE FOR NO FILESPEC. EXFDVL =.-EXFDV ; .EVEN ; ; ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; .SBTTL FILE CONTROL BLOCK FOR .LST ; LSTFDB: FDBDF$ ; FDRC$A ,LINBUF,LNBUFL ; FDOP$A LSTLUN,LSTDSD,LSTDFB,FO.RD ; ; LSTDFB: NMBLK$ ,LST,,SY,0 ; DEFAULTS ; LSTDSD: .BLKW 6 ; LST DESCRIPTOR ; ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ; .SBTTL FILE CONTROL BLOCK FOR ERROR MESSAGES ; MSGFDB: FDBDF$ ; FDRC$A FD.RAN ; FDOP$A MSGLUN,MSGDSD,,FO.RD ; ; MSGDSD: MSGDVL,MSGDV,MSGDRL,MSGDR,MSGFLL,MSGFL ; DATA SET DESCR. ; MSGDV: .ASCII /LB0:/ ; MSGDVL =.-MSGDV ; .EVEN ; MSGDR: .ASCII /[1,2]/ ; MSGDRL =.-MSGDR ; .EVEN ; MSGFL: .ASCII /QIOSYM.MSG/ ; MSGFLL =.-MSGFL ; .EVEN ; .SBTTL MESSAGES ; MSG1: .ASCII /EXF -- Indirect file open or read error/ MSL1 =.-MSG1 MSG2: .ASCII /EXF -- Syntax error/ MSL2 =.-MSG2 MSG3: .ASCII /EXF -- No switch allowed/ MSL3 =.-MSG3 MSG4: .ASCII /EXF -- Too many input specifiers/ MSL4 =.-MSG4 MSG5: .ASCII /EXF -- Input specifier missing/ MSL5 =.-MSG5 MSG6: .ASCII /EXF -- Too many output specifiers/ MSL6 =.-MSG6 MSG8: .ASCII /EXF -- No wildcards allowed/ MSL8 =.-MSG8 MSG9: .ASCII /EXF -- No input filename specified/ MSL9 =.-MSG9 MSGU: .ASCII /EXF -- Error occurded, LB:[1,2]QIOSYM.MSG read error/ MSLU =.-MSGU MSGE1: .ASCII /EXF -- Errors detected: 0/ MSLE1 =.-MSGE1 MSGE2: .ASCII /EXF -- Several errors detected/ MSLE2 =.-MSGE2 MSGC: .ASCII <15><12><12> MSLC =.-MSGC MSGX: .ASCII /EXF -- / MSGXT: .BLKB 64. ; ERROR TEXT MSLX =.-MSGX .EVEN STACK: 0 ; INITIAL STACKPOINTER NOEXF: 0 ; NONAME: 0 ; LSTSIZ: 0 ; LINBUF: .BLKB 134. ; LINE BUFFER LNBUFL=.-LINBUF .EVEN ; SAVBUF: .BLKB 134. ; SAVE BUFFER FOR RECORDS .EVEN SAVLEN: 0 ; LENGTH OF SAILED RECORDS DEFDEV: 0 ; DEFAULT DEVICE FLAG ERRFLG: 0 ; ERROR FLAG FORTRN: 0 ; FORTRAN FLAG F77FLG: 0 EXSTA: EX$SUC ; EXIT STATUS ;JHA02 START: FINIT$ ; INIT FSR MOV SP,STACK ; SAVE INITIAL STACK VALUE MOV #6,R1 ; + MOV #EXFDSD,R2 ; MOV #LSTDSD,R3 ; CLEAR JUNK 10$: CLR (R2) ; CLR (R3) ; FROM SOB R1,10$ ; CLR NOEXF ; PREVIOUS CLR NONAME ; CLR DEFDEV ; RUNS CLR ERRFLG ; CLR F77FLG ; CLR FORTRN ; - ; .SBTTL COMMANDLINE FETCH ; GCML$ #GCMBLK ; GET COMMANDLINE BCC CSISYN ; OK ? YES: => CSISYN CMPB GCMBLK+G.ERR,#GE.EOF ; END OF FILE BNE 20$ ; NO: => 20$ JMP EXIT ; EXIT ; ; Indirect file open or read error ; 20$: MOV #MSG1,R1 ; ADDR. OF MESSAGE MOV #MSL1,R2 ; LENGTH OF MESSAGE MOV #EX$SEV,EXSTA ; Severe error ;JHA02 JMP ERROR ; => ERROR ; .SBTTL CSI SYNTAX TEST ; CSISYN: MOV #EX$SEV,EXSTA ; Severe error ;JHA02 MOV GCMBLK+G.CMLD+2,CSIBLK+C.CMLD+2 ; COPY BUFFER ADDRESS MOV GCMBLK+G.CMLD ,CSIBLK+C.CMLD ; COPY BUFFER LENGTH CSI$1 #CSIBLK ; TEST SYNTAX BCC GETEXF ; OK ? YES: => GETEXF ; ; Syntax error ; MOV #MSG2,R1 ; MESSAGE ADDRESS MOV #MSL2,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR .SBTTL GET EXF SPECIFIER ; GETEXF: CSI$2 #CSIBLK,OUTPUT ; GET EXF SPECIFIER BCC 10$ ; OK ? YES: => 10$ ; ; Illegal switch ; MOV #MSG3,R1 ; MESSAGE ADDRESS MOV #MSL3,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 10$: BITB #CS.MOR,CSIBLK+C.STAT ; MORE FILES SPECIFIED ? BEQ 20$ ; NO: => 20$ ; ; Too many output specifiers ; MOV #MSG6,R1 ; MESSAGE ADDRESS MOV #MSL6,R2 ; MESSAGE LENGTH JMP ERROR ; ERROR 20$: BITB #CS.WLD,CSIBLK+C.STAT ; WILDCARDS USED ? BEQ 30$ ; NO: => 30$ ; ; No wildcards allowed ; MOV #MSG8,R1 ; MESSAGE ADDRESS MOV #MSL8,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 30$: BITB #CS.NMF!CS.DIF!CS.DVF,CSIBLK+C.STAT ; SOMETHING SPECIFIED ? BNE 50$ ; YES: => 50$ 40$: INC NOEXF ; SET NOEXF FLAG MOV #EXFDV ,EXFDSD+2 ; DEFAULT DEVICE MOV #EXFDVL,EXFDSD ; FOR NO FILESPEC INC DEFDEV ; BR GETLST ; => GETLST 50$: BITB #CS.NMF,CSIBLK+C.STAT ; FILENAME SPECIFIED ? BNE 60$ ; NO: => 60$ INC NONAME ; SET NONAME FLAG BR 70$ ; => 70$ 60$: MOV CSIBLK+C.FILD+2,EXFDSD+12 ; COPY ADDRESS AND MOV CSIBLK+C.FILD ,EXFDSD+10 ; LENGTH OF FILENAME 70$: MOV CSIBLK+C.DIRD+2,EXFDSD+6 ; COPY ADDRESS AND MOV CSIBLK+C.DIRD ,EXFDSD+4 ; LENGTH OF DIRECTORY MOV CSIBLK+C.DEVD+2,EXFDSD+2 ; COPY ADDRESS AND MOV CSIBLK+C.DEVD ,EXFDSD ; LENGTH OF DEVICE .SBTTL GET LST SPECIFIER ; GETLST: CSI$2 #CSIBLK,INPUT ; GET LST SPECIFIER BCC 10$ ; OK ? YES: => 10$ ; ; Illegal switch ; MOV #MSG3,R1 ; MESSAGE ADDRESS MOV #MSL3,R2 ; MEGGASE LENGTH JMP ERROR ; => ERROR 10$: BITB #CS.MOR,CSIBLK+C.STAT ; MORE SPECIFIERS ? BEQ 20$ ; NO: => 20$ ; ; Too many input specifiers ; MOV #MSG4,R1 ; MESSAGE ADDRESS MOV #MSL4,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 20$: BITB #CS.WLD,CSIBLK+C.STAT ; WILDCARDS USED ? BEQ 30$ ; NO: => 30$ ; ; No wildcards allowed ; MOV #MSG8,R1 ; MESSAGE ADDRESS MOV #MSL8,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 30$: BITB #CS.NMF!CS.DIF!CS.DVF,CSIBLK+C.STAT ; SOMETHING SPECIFIED ? BNE 50$ ; YES: => 50$ TST NOEXF ; ALSO NO EXF ? BEQ 40$ ; NO: => 40$ MOV #EX$SUC,EXSTA ; Success status ;JHA02 JMP START ; PROMPT AGAIN 40$: MOV EXFDSD+12,LSTDSD+12 ; COPY ADDRESS AND MOV EXFDSD+10,LSTDSD+10 ; LENGTH OF FILENAME MOV EXFDSD+6 ,LSTDSD+6 ; COPY ADDRESS AND MOV EXFDSD+4 ,LSTDSD+4 ; LENGTH OF DIRECTORY MOV EXFDSD+2 ,LSTDSD+2 ; COPY ADDRESS AND MOV EXFDSD ,LSTDSD ; LENGTH OF DEVICE MOV #EXFDV ,EXFDSD+2 ; DEFAULT DEVICE EXF MOV #EXFDVL,EXFDSD ; FOR NO FILESPEC INC DEFDEV ; BR OPEN ; 50$: BITB #CS.NMF,CSIBLK+C.STAT ; FILENAME SPECIFIED ? BNE 70$ ; YES: => 70$ TST NOEXF ; ALSO NO EXF ? BNE 60$ ; YES: => 60$ TST NONAME ; OR NO NAME ? BEQ 70$ ; NO: => 70$ 60$: ; ; No file name specified ; MOV #MSG9,R1 ; MESSAGE ADDRESS MOV #MSL9,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 70$: MOV CSIBLK+C.FILD+2,LSTDSD+12 ; COPY ADDRESS AND MOV CSIBLK+C.FILD ,LSTDSD+10 ; LENGTH OF FILENAME MOV CSIBLK+C.DIRD+2,LSTDSD+6 ; COPY ADDRESS AND MOV CSIBLK+C.DIRD ,LSTDSD+4 ; LENGTH OF DIRECTORY MOV CSIBLK+C.DEVD+2,LSTDSD+2 ; COPY ADDRESS AND MOV CSIBLK+C.DEVD ,LSTDSD ; LENGTH OF DEVICE ; ; SKIP EXF. FOR DEFAULTNAME ; MOV CSIBLK+C.FILD+2,R0 ; COPY ADDRESS CMPB (R0),#'. ; IS IT A "." ? BNE 80$ ; NO : => 80$ ; ; No input filename specified ; MOV #MSG9,R1 ; MESSAGE ADDRESS MOV #MSL9,R2 ; MESSAGE LENGTH JMP ERROR ; => ERROR 80$: TST NONAME ; NO EXF NAME ? BEQ 110$ ; NO: => 110$ MOV CSIBLK+C.FILD,R1 ; LENGTH OF FILENAME MOV CSIBLK+C.FILD,LSTSIZ ; LENGTH OF FILENAME CLR R2 ; CLEAR COUNT 90$: CMPB (R0)+,#'. ; IS IT A "." ? BEQ 100$ ; YES => 100$ INC R2 ; INC COUNT SOB R1,90$ ; NO => 90$ 100$: MOV LSTDSD+12,EXFDSD+12 ; ADDR OF LSTFILE MOV R2 ,EXFDSD+10 ; SIZE OF LSTFILE 110$: .SBTTL OPEN FILES ; OPEN: OPEN$R #LSTFDB,,,,,,FCSER ; OPEN INPUT FILE OPEN$W #EXFFDB,,,,,,FCSER ; OPEN EXF FILE MOV #EX$SUC,EXSTA ; Success status ;JHA02 .SBTTL ALGORITHM ; 10$: CALL GET ; GET RECORD CMPB #FF,(R1)+ ; FIRST CHAR. A ? ;JHA03 BNE 10$ ; NO: => 10$ MOV R1,R5 ; save the pointer .IRPC Q, ; TEST FOR CMPB #''Q,(R1)+ ; FORTRAN LISTING BNE 20$ ; .ENDR ; INC F77FLG ; It's F77 FDAT$R #EXFFDB,,#FD.CR ; BR 30$ ; => 30$ 20$: MOV R5,R1 ; unsave the pointer .IRPC Q, ; TEST FOR CMPB #''Q,(R1)+ ; FORTRAN LISTING BNE 10$ ; .ENDR ; 30$: INC FORTRN ; SAY WE HAVE FORTRAN 40$: ;JHA03 TST F77FLG ; is is f 77 ? BNE 70$ ; yes: => 70$ CALL GET ; GET RECORD CMPB (R1),#'* ; START WITH "*" ? BNE 50$ ; NO: => 50$ CALL PUT ; PUT RECORD MOV #SAVBUF,R1 ; ADDRESS MOV SAVLEN,R4 ; AND LENGTH CALL PUT ; OF SAVED RECORD BR 40$ ; NEXT ;JHA03 50$: MOV R1,R0 ; R0 = CHARACTER POINTER .IRPC Q, ; SEARCH CMPB #''Q,(R0)+ ; FOR "IN LINE" BNE 40$ ; NEXT ;JHA03 .ENDR ; TST ERRFLG ; DID WE HAVE AT LEAST 1 ERROR BNE 60$ ; YES: => 60$ MOV R1,-(SP) ; MOV R4,-(SP) ; MOV #MSGC,R1 ; OUTPUT A CR,LF,LF MOV #MSLC,R4 ; BEFORE THE CALL PUT ; FIRST ERROR MOV (SP)+,R4 ; MOV (SP)+,R1 ; INC ERRFLG ; SAY WE HAVE AT LEAST 1 ERROR MOV #EX$ERR,EXSTA ; Error status ;JHA02 60$: CALL PUT ; PUT RECORD BR 40$ ; NEXT ;JHA03 ; ; F77 ; 70$: CALL GET ; GET RECORD MOV R1,R0 ; R0 = CHARACTER POINTER .IRPC Q, ; SEARCH CMPB #''Q,(R0)+ ; FOR "F77 --" BNE 70$ ; NEXT .ENDR ; TST ERRFLG ; DID WE HAVE AT LEAST 1 ERROR ;JHA03 BNE 80$ ; YES: => 80$ ;JHA03 MOV R1,-(SP) ; MOV R4,-(SP) ; MOV #MSGC,R1 ; OUTPUT A CR,LF,LF ;JHA03 MOV #MSLC,R4 ; BEFORE THE ;JHA03 CALL PUT ; FIRST ERROR ;JHA03 MOV (SP)+,R4 ; MOV (SP)+,R1 ; INC ERRFLG ; SAY WE HAVE AT LEAST 1 ERROR ;JHA03 MOV #EX$ERR,EXSTA ; Error status ;JHA03 80$: CALL PUT ; PUT RECORD MOV #SAVBUF,R1 ; ADDRESS MOV SAVLEN,R4 ; AND LENGTH CALL PUT ; OF SAVED RECORD CALL GET CALL PUT BR 70$ ; NEXT .SBTTL FINISHING ; END: TST ERRFLG ; ERRORS ? BEQ 20$ ; NO: => 20$ TST DEFDEV ; DEFAULT DEVICE ? BNE 10$ ; YES: => 10$ MOV #MSGC,R1 ; ADDRESS OF MESSAGE MOV #MSLC,R4 ; LENGTH OF MESSAGE CALL PUT ; MOV #MSGE2,R1 ; ADDRESS OF MESSAGE MOV #MSLE2,R4 ; LENGTH OF MESSAGE CALL PUT ; MOV #MSGC,R1 ; ADDRESS OF MESSAGE MOV #MSLC,R4 ; LENGTH OF MESSAGE CALL PUT ; 10$: MOV #MSGE2,R1 ; ADDRESS OF MESSAGE MOV #MSLE2,R2 ; LENGTH OF MESSAGE BR 40$ ; => 40$ 20$: TST DEFDEV ; DEFAULT DEVICE ? BNE 30$ ; YES: =>15 MOV #MSGC,R1 ; ADDRESS OF MESSAGE MOV #MSLC,R4 ; LENGTH OF MESSAGE CALL PUT ; MOV #MSGE1,R1 ; ADDRESS OF MESSAGE MOV #MSLE1,R4 ; LENGTH OF MESSAGE CALL PUT ; MOV #MSGC,R1 ; ADDRESS OF MESSAGE MOV #MSLC,R4 ; LENGTH OF MESSAGE CALL PUT ; 30$: MOV #MSGE1,R1 ; ADDRESS OF MESSAGE MOV #MSLE1,R2 ; LENGTH OF MESSAGE 40$: ; ; USE ERROR ROUTINE TO GIVE THE MESSAGE AND RESTART THE PROGRAM. ; 50$: JMP ERROR ; EXIT: EXST$S EXSTA ; Exit with status ;JHA02 ; .SBTTL SUBROUTINE GET ; ; READ INPUT FILE ; GET: MOV #LINBUF,R1 ; R1 = INPUT BUFFER CLRB (R1) ; CLEAR FIRST CHARACTER GET$ #LSTFDB ; GET THE RECORD BCC 30$ ; OK ? YES: => 30$ CMPB #IE.EOF,LSTFDB+F.ERR ; EOF ? BNE 10$ ; NO: => 10$ TST FORTRN ; FORTRAN FILE ? BNE 20$ ; YES: => 20$ 10$: JMP FCSER ; OTHER ERROR 20$: MOV #END,(SP) ; CHANGE RETURN ADDR. BR 50$ ; 30$: MOV RECL,R4 ; R4 = RECORD LENGTH CMPB (R1),#'0 ; LOOK FOR BLT 50$ ; A NUMBER CMPB (R1),#'9 ; WHICH SAYS BGT 50$ ; IT'S A LEGAL RECORD MOV R4,-(SP) ; MOV R2,-(SP) ; MOV R1,-(SP) ; MOV #SAVBUF,R2 ; 40$: MOVB (R1)+,(R2)+ ; SAVE THE RECORD SOB R4,40$ ; MOV (SP)+,R1 ; MOV (SP)+,R2 ; MOV (SP)+,R4 ; MOV R4,SAVLEN ; - 50$: RETURN ; .SBTTL SUBROUTINE PUT ; ; WRITE TO OUTPUT FILE ; PUT: TST R4 ; WE DON'T PUT EMPTY ONES BEQ 10$ ; PUT$ #EXFFDB,R1,R4,FCSER ; THERE YOU GO 10$: RETURN ; .SBTTL FCS/DIRECTIVE ERROR HANDLING ; DRERR: MOVB (R0),R1 ; ERROR CODE MOVB #-1,R2 ; DSW ERROR BR COMMON ; => COMMON ; FCSER: MOVB F.ERR(R0),R1 ; ERROR CODE MOVB F.ERR+1(R0),R2 ; ERROR IDENT OPEN$R #MSGFDB,,,,,,ER ; OPEN QIOSYM.MSG ; COMMON: NEG R1 ; MAKE IT POSITIVE TSTB R2 ; I/O - ERROR ? BEQ 10$ ; YES: => 10$ ADD #OFFSET,R1 ; TAKE OFFSET TO DSW - CODES 10$: MOV #EX$SEV,EXSTA ; Severe staus ;JHA02 GET$R #MSGFDB,#MSGXT,#64.,R1,#0,ER ; GET RECORD CLOSE$ #MSGFDB ; CLOSE FILE MOV #MSGX,R1 ; MESSAGE ADDRES MOV #MSLX,R2 ; MESSAGE LENGTH BR ERROR ; ERROR ER: MOV #MSGU,R1 ; MESSAGE ADDRES MOV #MSLU,R2 ; MESSAGE LENGTH ERROR: ; ; CLOSE ALL FILES EVEN WHEN THEY WERE NOT OPEN TO ENSURE CORRECT HANDLING ; CLOSE$ #EXFFDB ; CLOSE$ #LSTFDB ; ; ; SET STACK BACK TO INITIAL VALUE ; MOV STACK,SP ; RESET STACK ; ; QUE MESSAGE ; QIOW$S #IO.WVB,#CSILUN,#1,,,, JMP START ; .END START