.TITLE RESFOR - RESEQUENCE FORTRAN SOURCE ; REV __ VERSION 1.0 ; ; RESFOR.MAR - Resequences labels of Fortran source code. Fortran must ; be compilable under DEC software. Only known limitation is that Fortran ; keywords (e.g., "If", "Do", "Goto", "Read") must not be broken up and ; continued. Note this does not apply to Fortran statements, only the ; Fortran keywords. ; ; Resequencing is carried out in two passes. The first pass builds a label ; map of old and new labels (lbl_data). Also, relevant continued lines are ; identified by record number (ctn_data). If more than one program unit is ; present, information is stored (mdl_data) regarding the whereabouts of ; the units and their respective label maps. ; ; The second pass is the resequencing pass. Each relevant Fortran statement ; is identified and the label(s), if any, is (are) resequenced using the label ; map built during pass one. ; ; William W. Brown, BASD - January 1981 ; ; ; User definable program parameters: ; ; Maximum number of different labels to be resequenced: LBLQTY=1024 ; ; Maximum number of lines having continuations: CTNQTY=256 ; ; Maximum number of subroutines to be resequenced at once: MDLQTY=64 ; ; Utility Macros: ; ; Case Branch Macro (Byte) ; .MACRO CASE CSE,LST,TYP=B,LOW=#0,HGH=S^#,?BAS,?MAX CASE'TYP CSE,LOW,HGH'</2>-1 ; ; Used repetition to generate word case offsets BAS: .IRP EP, .SIGNED_WORD EP-BAS .ENDR MAX: .ENDM CASE ; ; Type String to User Console Macro ; .MACRO TYPE STRING .SAVE .PSECT STRING_IO,NOWRT ; Change PSECT TMPA=. ; Save current location .ASCII "STRING" ; String to be typed to console TMPL=.-TMPA ; Compute length of string .RESTORE ; Restore PSECT MOVL #TMPA,TYPE_RAB+RAB$L_RBF ; Store start address in RAB MOVW #TMPL,TYPE_RAB+RAB$W_RSZ ; Store string lenght in RAB $PUT RAB=TYPE_RAB ; "Put" it according to RAB .ENDM TYPE ; ; On Error Macro ; .MACRO ON_ERROR DEST,?LABEL ; DEST is passed; LABEL computed BLBS R0,LABEL ; Ok if low bit set BRW DEST ; Error; branch to error handler LABEL: .ENDM ON_ERROR ; ; Data Storage Definitions ; .PSECT DATA,LONG ; ; FAB and RAB for TYPE Macro ; TYPE_FAB: $FAB FNM=,- RAT=CR TYPE_RAB: $RAB FAB=TYPE_FAB ; ; FAB and RAB for input, first in "LOCATE" mode ; IN_FAB: $FAB DNM=<.FOR>,- FOP=SQO,- RFM=VAR IN_RAB: $RAB FAB=IN_FAB,- ROP=,- UBF=IO_BUF,- USZ=128 ; Maximum size of any single record ; ; FAB and RAB for output ; OUT_FAB: $FAB DNM=<.FOR>,- FAC=PUT,- FOP=SQO,- RAT=CR,- RFM=VAR,- NAM=OUT_NAM ; Need file name information OUT_RAB: $RAB FAB=OUT_FAB,- RAC=SEQ,- RBF=IO_BUF,- RSZ=72 ; Maximum out record size (Fortran) OUT_NAM: $NAM ; ; All storage necessary to accept command line ; PROMPT: .WORD 8,0 ; Required length of prompt .LONG QUERY ; Address of literal prompt QUERY: .ASCII "$_File: " ; Literal 8 byte prompt CMDLEN=50 ; Maximum command string length STRING: .WORD CMDLEN,0 ; Required length for TPARSE .LONG CMDSTR ; and start address CMDSTR: .BLKB CMDLEN ; Buffer for command string ; ; Character table used for SCANC and SPANC: ; ; 2 - digit ; 4 - space or tab ; 8 - "(", ")" or "'" ; 16,17 - alphabetic (upper and lower case) ; 17 - keyword alphabetic: a,b,c,d,e,f,g,i,o,p,r,t,u,w ; (Above correspond to first letters of Fortran keywords ; that may have Fortran labels associated with them) ; 32 - "$", "_", or "." ; 0 - all other ; CHRTAB: .BYTE 0[9],4,0[22],4,0[3],32,0,0,8,8,8,0[4],32,0 .BYTE 2[10],0[7] .BYTE 17[7],16,17,16[5],17,17,16,17,16,17,17,16,17,16[3] .BYTE 0[4],32,0 .BYTE 17[7],16,17,16[5],17,17,16,17,16,17,17,16,17,16[3] .BYTE 0[5] .BYTE 0[128] ; ; Label map, end and start address, length ; LBL_DATA: .BLKB 8*LBLQTY ; Buffer to hold "was-is" label relationship LBLEND=.-8 ; Mark near end of this buffer for error catch LBLBEG: .ADDRESS LBL_DATA; Store address of map beginning LBLLEN: .WORD 0 ; Reserve space for map length to bound search ; ; Continuation line information ; ; Ctn_data - Even word: record number of each continued line in file ; Odd word : number of continued lines making up the ; associated continued statement CTN_DATA: .BLKW 2*CTNQTY CTNEND=. ; ; Multiple subroutines in module (file) information ; ; Mdl_data - Each longword: end address of section of label map ; associated with particular program unit MDL_DATA: .BLKA MDLQTY MDLEND=. MDLPTR: .ADDRESS MDL_DATA ; Points to appropriate address in mdl_data ; ; Miscellaneous Variables and Buffers ; PINCRE: .PACKED 20 ; Label increment; default is 20. PNEWLB: .PACKED 00000000 ; New label incremented by pincre PFMTLB: .PACKED 00000000 ; Special format label if requested PFMTIN: .PACKED 00498000 ; Starting format label (minus pincre) CMPBUF: .ASCII "ABCDEFGH" ; General purpose compare buffer ENDSTR: .ASCII "END" ; Used to find "End" statement or "End=" ERRSTR: .ASCII "ERR" ; Used to find "Err=" qualifier FMTSTR: .ASCII "FORMATFMT" ; Used to find "Format" statements or "Fmt=" ADDHLD: .ADDRESS 0 ; Special address hold buffer SPCADD: .ADDRESS 0 ; Address hold for special continue routine IO_BUF: .BLKB 128 ; Main record I-O buffer; one line REC_BUF: .BLKB 512 ; Continuation line buffer; multiple lines ; ; Byte, word and longword lowercase to uppercase bit masks ; LCMSKB=32 LCMSKW=8224 LCMSKL=538976288 ; ; All data structures needed to determine statement type ; ; Fortran keywords by length and frequency of usage FTNSTM: .ASCII "IFGODO" .ASCII "END" .ASCII "GOTOTYPECALLOPENREADFIND" .ASCII "WRITECLOSEPRINT" .ASCII "ACCEPTENCODEDECODEASSIGNDELETEREWINDUNLOCK" .ASCII "REWRITEENDFILE" .ASCII "BACKSPAC" ; ; Keyword number (0-23) of first keyword in each length class (0-9) ; ; 0 1 2 3 4 5 6 7 8 9 FTNIDX: .BYTE 0,0,0,3,4,10,13,20,22,23 ; ; Keyword attribute: 0- No comment ; 1- "Go " with or without "To" ; 2- "End" ; 3- "Backspace" ; 4- Direct access I-O possibility ; 5- "Encode" or "Decode" ; FTNATT: .BYTE 0,1,0,2,0[4],4[3],0[3],5[2],0,4,0[4],3 ; ; Address of each keyword in stack ftnstm FTNADD: .ADDRESS FTNSTM .ADDRESS FTNSTM+2 .ADDRESS FTNSTM+4 .ADDRESS FTNSTM+6 .ADDRESS FTNSTM+9 .ADDRESS FTNSTM+13 .ADDRESS FTNSTM+17 .ADDRESS FTNSTM+21 .ADDRESS FTNSTM+25 .ADDRESS FTNSTM+29 .ADDRESS FTNSTM+33 .ADDRESS FTNSTM+38 .ADDRESS FTNSTM+43 .ADDRESS FTNSTM+48 .ADDRESS FTNSTM+54 .ADDRESS FTNSTM+60 .ADDRESS FTNSTM+66 .ADDRESS FTNSTM+72 .ADDRESS FTNSTM+78 .ADDRESS FTNSTM+84 .ADDRESS FTNSTM+90 .ADDRESS FTNSTM+97 .ADDRESS FTNSTM+104 FTNTYP: .BYTE 0 ; ; TPARSE global data - used to analyze the command string ; $TPADEF TPARSE_BLOCK: .LONG TPA$K_COUNT0 .LONG TPA$M_ABBREV .LONG CMDLEN .LONG CMDSTR .BLKL TPA$K_LENGTH0-16 PARSER_FLAGS: .BLKL 1 ; To hold bit flag parsing results INCREMENT: .BLKL 1 ; To hold user increment if any FORMAT_LABEL: .BLKL 1 ; To hold user format label if any INC_FLAG=1 FOR_FLAG=2 $INIT_STATE SWI_STATE,SWI_KEY $STATE OPTIONS $TRAN '/' $TRAN TPA$_LAMBDA,TPA$_EXIT $STATE $TRAN 'INCREMENT',PARSE_INC,,INC_FLAG,PARSER_FLAGS $TRAN 'FORMAT_LABEL',PARSE_FOR,,FOR_FLAG,PARSER_FLAGS $STATE PARSE_INC $TRAN ':' $TRAN '=' $STATE $TRAN TPA$_DECIMAL,OPTIONS,,,INCREMENT $STATE PARSE_FOR $TRAN ':' $TRAN '=' $STATE $TRAN TPA$_DECIMAL,OPTIONS,,,FORMAT_LABEL $END_STATE ; ; Main entry: Process command line including any switches ; .PSECT CODE,EXE,NOWRT,LONG RESFOR::.WORD ^M<> PUSHAL PROMPT ; Push prompt address to stack PUSHAL STRING ; Push target string address CALLS #2,LIB$GET_FOREIGN ; Get the entire command line PUSHAL SWI_KEY ; Save address of keyword table PUSHAL SWI_STATE ; Save address of state table PUSHAL TPARSE_BLOCK ; Save address of tparse block CALLS #3,LIB$TPARSE ; Parse the command line BLBS R0,10$ ; On success, continue 5$: MOVZBL #5,R0 ; Indicate switch error message needed BRW RESERR ; Proceed to error handler 10$: MOVL TPARSE_BLOCK+TPA$L_STRINGCNT,R0 ; Get file-spec length MOVL TPARSE_BLOCK+TPA$L_STRINGPTR,R1 ; Get file-spec start address MOVB R0,IN_FAB+FAB$B_FNS ; Store file name length in input fab MOVB R0,OUT_FAB+FAB$B_FNS ; Store file name length in output fab MOVL R1,IN_FAB+FAB$L_FNA ; Store file name address in input fab MOVL R1,OUT_FAB+FAB$L_FNA ; Store file name address in output fab $OPEN FAB=IN_FAB ; Open the input file-spec ON_ERROR RESERR ; On error, branch to error handler $CONNECT RAB=IN_RAB ; and connect to the channel ON_ERROR RESERR ; On error, branch to error handler CLRL R10 ; Clear the flag longword BLBC PARSER_FLAGS,20$ ; Branch if no special increment MOVL INCREMENT,R1 ; Store increment CMPL R1,#99 ; Is increment greater than 99 BGTRU 5$ ; Yes: illegal switch value TSTL R1 ; Is increment equal to zero BEQL 5$ ; Yes: illegal switch value CVTLP R1,#2,PINCRE ; No: convert increment value to packed 20$: BBC #1,PARSER_FLAGS,40$ ; Branch if no special format label MOVL FORMAT_LABEL,R1 ; Store format label CMPL R1,#50000 ; Is format label greater than 50000 BLEQU 30$ ; No: format label value ok BRW 5$ ; Yes: illegal switch value 30$: CVTLP R1,#6,PFMTIN ; Convert the format label to packed SUBP4 #2,PINCRE,#6,PFMTIN ; Adjust initial format label by incre MOVP #6,PFMTIN,PFMTLB ; Initialize the format label hold BISB2 #4,R10 ; Set the special format label flag 40$: MOVAL PNEWLB,R8 ; Store address of new label string MOVAL CTN_DATA,R11 ; and store address of continuation data MOVAL LBL_DATA,R9 ; Initialize R9 to label map address MOVB #^A';',(R9)+ ; First byte in map must be ";" CLRW R7 ; Initialize record counter to zero ; ; Main loop of first pass: Build old-new label map ; ; R0,R1,R2,R3 - scratch ; R4 - address of character in statement under examination ; R6 - first, record start address; later, end of record (eor) address ; R7 - record number ; R8 - address of "Pnewlb" or "Pfmtlb" - new labels ; R9 - address of next available byte in label map ; R10 - bit flags set: 7 6 5 4 3 2 1 0 ; | | | | | |__ at valid continuation line ; | | | | |____ not 1st line of continuation ; | | | |______ special format labels reqst'd ; | | |________ special format label used ; | |__________ at "End" statement ; |____________ non-zero label digit found ; R11 - pointer into ctn_data structure ; GETLBL: $GET RAB=IN_RAB ; Begin with locate of first record ON_ERROR RESETF ; At end, proceed to second pass INCW R7 ; Adjust record number TSTW IN_RAB+RAB$W_RSZ ; Was length of record zero BEQL GETLBL ; Yes: just get next record MOVL IN_RAB+RAB$L_RBF,R6 ; Store address of first byte in R6 BICB3 #LCMSKB,(R6),R1 ; Mask out lowercase CMPB #^A'C',R1 ; Have we a "C" for comment BNEQ 15$ ; No: continue BRW MAPLBL ; Yes: see if last line a continuation 15$: ADDL3 #5,R6,R2 ; Store address of continuation field MOVL R6,R4 ; Set R4 to address of label field CMPB #^A'D',R1 ; Does label start with "D" BNEQ 20$ ; No: begin to examine field INCL R4 ; Yes: adjust label field pointer 20$: CMPB #9,(R4) ; Is this label field byte a tab BNEQ 25$ ; No: continue SCANC #1,B^1(R4),CHRTAB,#2 ; Yes: does digit follow tab BEQL GETKWD ; No: not a continuation line BRB 40$ ; Yes: this is a continuation line 25$: CMPB #32,(R4) ; No: is byte a space BEQL 35$ ; Yes: proceed to next byte BBS #5,R10,30$ ; No: skip if past first non-zero digit CMPB #^A'0',(R4) ; Is digit a leading zero BEQL 35$ ; Yes: do not append it to map BISB2 #32,R10 ; No: set non-zero digit found flag 30$: MOVB (R4),(R9)+ ; Append digit to label map 35$: AOBLSS R2,R4,20$ ; Examine next byte in label field ; At continuation field; does the field SCANC #1,(R4),CHRTAB,#4 ; contain a space or tab character BNEQ GETKWD ; Yes: not at a continuation line ; No: have a continuation line; if not 40$: BLBC R10,50$ ; Part of a valid statement, ignore it BBSS #1,R10,45$ ; Valid: branch if not 1st cnt'd line SUBW3 #1,R7,(R11)+ ; 1st: store the former record number CMPL #CTNEND,R11 ; Are there too many continued lines BGTR 45$ ; No: continue MOVZBL #1,R0 ; Yes: set error flag to error one BRW RESERR ; Proceed to error handler 45$: INCW (R11) ; Increment number of continuations 50$: BICB2 #32,R10 ; Clear non-zero digit found flag BRW GETLBL ; and examine next Fortran line GETKWD: MOVW IN_RAB+RAB$W_RSZ,R0 ; Store record size CMPW #72,R0 ; Is it greater than 72 bytes BGEQ 20$ ; No: we have effective record size MOVW #72,R0 ; Yes: effective size is 72 bytes 20$: ADDW2 R0,R6 ; Compute address of effective eor byte INCL R4 ; Starting at next character SUBL3 R4,R6,R0 ; compute length to bound search SPANC R0,(R4),CHRTAB,#4 ; Get to next non-blank BNEQ 40$ ; Branch if non-blank found ok BRW GETLBL ; Have line with just spaces; next rec 40$: MOVL R1,R4 ; Update character address MOVZBL (R4),R1 ; Store ASCII code of first alpha BICB2 #1,R10 ; Clear valid statement bit (false) CMPB #17,CHRTAB[R1] ; Is it of valid type BNEQ MAPLBL ; No: branch with valid bit clear BISB2 #1,R10 ; Yes: set the valid statement bit BICL3 #LCMSKL,(R4),CMPBUF ; Mask out lowercase CMPC3 #3,CMPBUF,ENDSTR ; Are we at an "End" statement BNEQ MAPLBL ; No: must not have "End" statement ADDL3 #3,R4,R1 ; Yes: compute trailing address SUBL3 R1,R6,R0 ; Compute length to bound search SPANC R0,(R1),CHRTAB,#4 ; Are there trailing non-blanks BEQL 50$ ; No: have a valid "End" statement CMPB #^A'!',(R1) ; Yes: have we found an in-line comment BNEQ MAPLBL ; No: must not have "End" statement 50$: BISB2 #16,R10 ; Have "End": set flag for later MAPLBL: BBCC #1,R10,20$ ; Branch if last line not continued ADDL2 #2,R11 ; Adjust ctn_data pointer to next word 20$: BBSC #5,R10,25$ ; Branch if label digits found BRW 85$ ; No label digits found 25$: CMPL #LBLEND,R9 ; Is label map too full BGTR 30$ ; No: continue CLRL R0 ; Yes: set error flag to error zero BRW RESERR ; Proceed to error handler 30$: BBC #2,R10,40$ ; Branch if no special format labels ; Special format labels requested BICL3 #LCMSKL,(R4),CMPBUF ; Mask out any lowercase characters BICW3 #LCMSKW,B^4(R4),CMPBUF+4; in 6 bytes alphabetic string CMPC3 #6,CMPBUF,FMTSTR ; Are we at a "Format" statement BNEQ 40$ ; No: branch ADDL3 #6,R4,R1 ; Yes: compute trailing byte address SUBL3 R1,R6,R0 ; Compute length to bound search SPANC R0,(R1),CHRTAB,#4 ; Get to next non-blank CMPB #^A'(',(R1) ; Is it required trailing "(" BNEQ 40$ ; No: not a format statement BISB2 #8,R10 ; Yes: set special label used flag MOVAL PFMTLB,R8 ; Store address of format label 40$: MOVB #^A'*',(R9)+ ; Append delimiter to map ADDP4 #2,PINCRE,#6,(R8) ; Increment new label by increment CVTPS #6,(R8),#6,CMPBUF ; Convert packed to numeric string SKPC #^A'0',#5,CMPBUF+2 ; Get to next non-zero digit MOVC3 R0,(R1),(R9) ; Move new label to label map MOVL R3,R9 ; Update available map byte address MOVB #^A';',(R9)+ ; Append final delimiter to label map BBCC #3,R10,85$ ; Clear 3 bit; branch on no format label MOVAL PNEWLB,R8 ; Replace standard label address BRW GETLBL ; and get the next record 85$: BBSC #4,R10,90$ ; Continue if at "End" statement BRW GETLBL ; Not at "End"; get the next record 90$: MOVL MDLPTR,R1 ; Place module pointer in R1 CMPL #MDLEND,R1 ; Are there too many modules BGTR 95$ ; No: continue MOVZBL #2,R0 ; Set error flag to error two BRW RESERR ; Proceed to error handler 95$: SUBL3 #1,R9,(R1)+ ; Store address of last ";" in map MOVL R1,MDLPTR ; Update the address pointer BBC #2,R10,99$ ; Branch if format label not requested ; Special format labels requested CMPP3 #8,PFMTIN,PNEWLB ; Have we conflict with ordinary labels BGEQ 97$ ; No: reset starting format label MOVZBL #3,R0 ; Yes: special format label error BRW RESERR ; so proceed to error handler 97$: MOVP #6,PFMTIN,PFMTLB ; Re-initialize the format label 99$: CLRL PNEWLB ; Clear the new label string BRW GETLBL ; and get the next record ; ; End of pass one: Commence resequencing pass ; RESETF: CMPL #^X1827A,R0 ; Was error an end-of-file BEQL 10$ ; Yes: all ok; continue CMPL #^X181A8,R0 ; No: have some kind of rms error BNEQ 5$ ; If "Record too big" set error flag MOVZBL #7,R0 ; to seven to indicate condition 5$: BRW RESERR ; Branch to fatal error handler 10$: $CLOSE FAB=IN_FAB ; Close input file and then re-open $OPEN FAB=IN_FAB ; for second pass through source ON_ERROR RESERR ; On error, branch to error handler $RAB_STORE RAB=IN_RAB,- ROP=ASY ; Reset file to just ASY $CONNECT RAB=IN_RAB ; Connect the ASY input file ON_ERROR RESERR ; On error, branch to error handler $GET RAB=IN_RAB ; Get the first record $CREATE FAB=OUT_FAB ; Create a new output file ON_ERROR RESERR ; On error, branch to error handler $CONNECT RAB=OUT_RAB ; and connect it as a new version ON_ERROR RESERR ; On error, branch to error handler MOVAL MDL_DATA,R0 ; Get address of module data area MOVL R0,MDLPTR ; Use it to initialize address pointer SUBL3 LBLBEG,(R0),R1 ; and compute the starting map length MOVW R1,LBLLEN ; placing the result in a word item CLRL R12 ; Initialize record counter to zero MOVAL CTN_DATA,R11 ; Initialize continuation pointer ; ; Main loop of second pass ; ; R0-R5 - scratch ; R6 - usually alternative byte for routine advchr search ; R7 - usually address of character under examination in line ; R8 - input record start address ; R9 - (1) label field length; (2) address following ")" in "()" pair ; R10 - address of byte following last byte in record (eor) ; R11 - address pointer into ctn_data data structure ; R12 - (low word) record number ; R12 - (high word) bit flag set: ; 7 6 5 4 3 2 1 0 ; | | | |__ continued lines read by reactn ; | | |____ I-O "Fmt=" or "End=" sought ; | |______ I-O "End=" sought ; |________ possibly direct access I-O ; REAREC: MOVAL IO_BUF,R8 ; Store the I-O buffer start address CLRL SPCADD ; Clear the special continue address 10$: INCW R12 ; Update the record number $WAIT RAB=IN_RAB ; Wait for next input record ON_ERROR EXIT ; At end of file, quit MOVZWL IN_RAB+RAB$W_RSZ,R4 ; Store record size TSTW R4 ; Is it zero length BEQL 30$ ; Yes: just write it back out BICB3 #LCMSKB,(R8),R1 ; Mask out a lowercase alphabetic CMPB #^A'C',R1 ; Is first byte a "C" (comment) BEQL 30$ ; Yes: comment - write it back out CMPW #72,R4 ; Is it greater than 72 bytes BGEQ 20$ ; No: see if it has non-blanks MOVW #72,R4 ; Effective size of record is 72 20$: SPANC R4,(R8),CHRTAB,#4 ; Check record for any non-blank BNEQ CHKLBL ; Have one: continue normal processing 30$: MOVW R4,OUT_RAB+RAB$W_RSZ ; Store record size for output $PUT RAB=OUT_RAB ; Put record to output file ON_ERROR RESERR ; On error, branch to error handler $GET RAB=IN_RAB ; Get another input file record BRB 10$ ; and see if it is non-trivial CHKLBL: ADDL3 R4,R8,R10 ; Get end of record address (eor) MOVZBL #5,R9 ; Initialize label length estimate CMPB #^A'D',R1 ; Have we a debug statement BNEQ 10$ ; No: continue INCL R8 ; Yes: adjust label field start addr MOVB #4,R9 ; Adjust label field length estimate 10$: LOCC #9,R9,(R8) ; Does label field have a BEQL 15$ ; No: continue SUBL3 R8,R1,R9 ; Yes: compute actual field length BNEQ 15$ ; Continue if label field more than tab SCANC #1,B^1(R8),CHRTAB,#2 ; Just tab; is following character digit BEQL 30$ ; No: go find first alphabetic BRW WRTREC ; Yes: have continuation line; write it 15$: SCANC R9,(R8),CHRTAB,#2 ; Is there a digit in label field BEQL 25$ ; No: have no label to change MOVL R1,R7 ; Yes: store address in R7 for routine BSBW NEWLBL ; Get length and address of new label ON_ERROR RESERR ; On error, branch to error handler CMPB R5,R9 ; Is new label longer than old field BLEQ 20$ ; No: just move with space filler MOVZBW R5,R7 ; Yes: save new label length SUBB2 R9,R5 ; Compute difference in lengths ADDL3 R9,R8,R1 ; Compute address past old label field SUBL3 R1,R10,R0 ; Compute distance to record end ADDL3 R5,R1,R9 ; and then compute new field end addr MOVC3 R0,(R1),(R9) ; Move remainder making room for new MOVL R3,R10 ; Update end of record address MOVC3 R7,(R6),(R8) ; Move new label to old field BRB 40$ ; All done with label field 20$: MOVC5 R5,(R6),#32,R9,(R8) ; Move new label (plus spaces) to old BRB 40$ ; All done with label field 25$: SCANC #1,(R1),CHRTAB,#4 ; Have no label; is the continuation ; field a non-blank character BNEQ 30$ ; No: not part of continued line BRW WRTREC ; Yes: continuation line; just write it 30$: MOVL R8,R3 ; Prepare to search line for first alpha 40$: SUBL3 R3,R10,R0 ; Compute length to bound search SCANC R0,(R3),CHRTAB,#16 ; Scan to alphabetic character MOVL R1,R8 ; Save location of alphabetic CHKFTN: MOVZBL (R8),R1 ; Get ASCII code of character CMPB #17,CHRTAB[R1] ; Have we a valid alphabetic BNEQ 10$ ; No: just write this record SUBL3 R8,R10,R0 ; Yes: compute number of bytes to end SPANC R0,(R8),CHRTAB,#16 ; Get to next non-alphabetic SUBL3 R8,R1,R7 ; Compute length of alpha string and ; Do a case branch on the length of ; the alphabetic string CASE R7, 10$: BRW WRTREC ; String longer than 8 bytes; write 20$: BICW3 #LCMSKW,B^6(R8),CMPBUF+6; Mask lowercase in 7th and 8th bytes 25$: BICW3 #LCMSKW,B^4(R8),CMPBUF+4; Mask lowercase in 5th and 6th bytes 30$: BICL3 #LCMSKL,(R8),CMPBUF ; Mask lowercase in 1st - 4th bytes MOVAB FTNIDX[R7],R1 ; Store address of low index MOVZBL (R1)+,R4 ; Move low index to AOBLSS register MOVZBL (R1),R5 ; Next byte is AOBLSS high index MOVAL FTNADD[R4],R6 ; Get address of ftnstm start 40$: CMPC3 R7,@(R6)+,CMPBUF ; Have we a keyword Fortran statement BEQL 50$ ; Yes: branch AOBLSS R5,R4,40$ ; No: continue looking until done BRW WRTREC ; Do not have a statement with labels 50$: ADDL2 R8,R7 ; Compute address of delimiter byte MOVB FTNATT[R4],R3 ; Get attribute of the keyword CASE R3,<90$ 55$ 60$ 70$> ; and use it in case branch BRB 90$ ; Continue with all other 55$: SUBL3 R7,R10,R0 ; "Go" - compute length to bound search SPANC R0,(R7),CHRTAB,#4 ; Get address of next non-blank BICW3 #LCMSKW,(R1),CMPBUF ; Mask out any lowercase characters CMPW #^A'TO',CMPBUF ; See if "To" follows the "Go" BNEQ 95$ ; No: not a "Go To" statement ADDL3 #2,R1,R7 ; Yes: update address of delimiter byte BRB 90$ ; and continue 60$: SUBL3 R7,R10,R0 ; "End" - compute length to bound search SPANC R0,(R7),CHRTAB,#4 ; Are there any more non-blanks BEQL 65$ ; No: have "End" statement CMPB #^A'!',(R1) ; Yes: have we found an in-line comment BNEQ 95$ ; No: not a genuine "End" statement 65$: MOVL MDLPTR,R5 ; Have "End": store address pointer MOVL (R5)+,LBLBEG ; Get the new map start address SUBL3 LBLBEG,(R5),R0 ; and compute the new map length MOVW R0,LBLLEN ; placing result in a word item MOVL R5,MDLPTR ; Restore new address pointer BRW WRTREC ; Write the "End" statement 70$: BICB3 #LCMSKB,(R7)+,CMPBUF ; Mask out any lowercase characters CMPB #^A'E',CMPBUF ; "Backspac" - is it "Backspace" BNEQ 95$ ; No: just write this record; yes... 90$: MOVB R4,FTNTYP ; Save type of Fortran statement CMPW R12,(R11) ; Are we at a continued line BNEQ CHKDEL ; No: continue SCANC #1,(R7),CHRTAB,#16 ; Yes: is delimiter byte alphabetic BNEQ 95$ ; Yes: this statement has no label BSBW REACTN ; No: may have label; read ctn lines ON_ERROR RESERR ; On error, branch to error handler BRB CHKDEL ; Entire record now in rec_buf; continue 95$: BRW WRTREC ; Statement has no Fortran label ; ; R7 - address of delimiter byte ; R10 - address of eor byte ; CHKDEL: SUBL3 R7,R10,R4 ; Compute length to eor from delimiter SPANC R4,(R7),CHRTAB,#4 ; Find next non-blank character BEQL 20$ ; None found: write the record CMPB #^A'(',(R1) ; Is it a left parenthesis BNEQ 10$ ; No: what is it then ADDL3 #1,R1,R7 ; Yes: store address after "(" MOVZBL FTNTYP,R4 ; Examine type of statement CMPB #4,FTNATT[R4] ; Is direct access I-O a possibility BNEQ 5$ ; No: continue BISL2 #524288,R12 ; Yes: set the direct access flag 5$: CLRB R6 ; Clear alternate byte register BSBW ADVCHR ; Find byte after right parenthesis ON_ERROR RESERR ; On error, branch to error handler BICL2 #524288,R12 ; Clear the direct access flag MOVL R8,R9 ; Store result in more permanent reg SUBL3 R9,R10,R0 ; Compute distance from it to eor SPANC R0,(R9),CHRTAB,#4 ; and get to the next non-blank BEQL 80$ ; None found: resequence labels BRB 40$ ; Examine the non-blank further 10$: CLRL R9 ; Clear right parenthesis address reg CMPW R4,R0 ; Is non-blank the delimiter character BNEQ 35$ ; No: check for trailing "=" ; Label may follow keyword without space SPANC R4,(R7),CHRTAB,#2 ; Get to next non-digit BEQL 80$ ; Branch if all remaining bytes digits CMPW R4,R0 ; Is non-digit the delimiter character BEQL 20$ ; Yes: have no label here SUBL3 R1,R10,R4 ; Compute number of bytes to eor SPANC R4,(R1),CHRTAB,#4 ; Get to next non-blank BEQL 80$ ; If all spaces, resequence label CMPW R4,R0 ; Is non-blank the first non-digit BEQL 20$ ; Yes: have no label here CMPB #^A'(',(R1) ; Check for trailing "(" - array name BNEQ 40$ ; If "(", check for trailing "=" 20$: BRW WRTREC ; Statement has no label; write it 35$: MOVL R1,R7 ; Save address of the non-blank 40$: CMPB #^A'=',(R1) ; Is non-blank an equal sign - assignmt BEQL 20$ ; Yes: have Fortran assignment statement 80$: CASE FTNTYP,- ; ; Change old Fortran statement label to new ; ; R7 - if "(" present: address 1 after "("; otherwise: address of first ; non-blank past Fortran keyword ; R9 - address of byte after ")" if "()" pair present; otherwise clear ; R10 - eor ; DO: SCANC #1,(R7),CHRTAB,#2 ; Is byte a digit BEQL 10$ ; No: not a valid do loop construct BSBW INTCHG ; Yes: interchange old "Do" label w/ new ON_ERROR RESERR ; On error, branch to error handler 10$: BRW WRTREC ; Done with "Do" OC: TSTL R9 ; Is there a "()" pair BEQL 20$ ; No: just write record MOVL R7,SPCADD ; Store address after "(" for wrtspc BSBW EQLLBL ; Find "Err=" if any ON_ERROR RESERR ; On error, branch to error handler 20$: BRW WRTREC ; Done with "Open-close" CL: SUBL3 R7,R10,R0 ; Get number of bytes to eor to bound LOCC #^A'(',R0,(R7) ; Search for call statement "(" BEQL 40$ ; If none: no label in this "Call" ADDL3 #1,R1,R7 ; Store address after "(" for advchr MOVL R7,SPCADD ; and save it for continuation processor MOVB #8,CHRTAB+38 ; Store correct mask in "&" table entry 10$: MOVB #^A'*',R6 ; Store "*" in alternate byte register BSBW ADVCHR ; Locate "*" or "&" or ")" whichever 1st ON_ERROR RESERR ; On error, branch to error handler BLBC R1,30$ ; If ")" found, just write record SPANC R2,(R8),CHRTAB,#4 ; Get to next non-blank character MOVL R1,R7 ; Update current byte address SCANC #1,(R7),CHRTAB,#2 ; Is non-blank a digit BEQL 10$ ; No: continue checking for "*" or "&" DECL R8 ; Adjust address to that of "*" or "&" 15$: CMPB #^A',',-(R8) ; Is preceding character a comma BEQL 20$ ; Yes: continue CMPB #^A'(',(R8) ; Is it a left parenthesis BEQL 20$ ; Yes: continue SCANC #1,(R8),CHRTAB,#4 ; Niether "," nor "("; is it space-tab BEQL 10$ ; If non-blank, no label with "*" BRB 15$ ; Have blank; find preceding non-blank 20$: BSBW INTCHG ; Interchange old label with new ON_ERROR RESERR ; On error, branch to error handler BRB 10$ ; Otherwise, repeat until ")" found 30$: CLRB CHRTAB+38 ; Reset "&" entry to zero 40$: BRW WRTREC ; Done with "Call" return labels IF: TSTL R0 ; Was non-blank found after ")" BEQL 20$ ; No: have invalid Fortran statement MOVL R9,SPCADD ; Store address after ")" for wrtspc SCANC #1,(R1),CHRTAB,#2 ; Yes: is non-blank a digit BNEQ 10$ ; Yes: continue SUBL3 #1,R1,R8 ; No: compute address of non-digit BRW CHKFTN ; Handle logical "If" 10$: MOVL R1,R7 ; Have arithmetic "If" BSBW INTCHG ; Interchange first label ON_ERROR RESERR ; On error, branch to error handler SUBL3 R7,R10,R0 ; Compute length to bound search SCANC R0,(R7),CHRTAB,#2 ; Find next digit BEQL 20$ ; If none: bad Fortran error MOVL R1,R7 ; Store non-digit address for routine BSBW INTCHG ; Interchange second label ON_ERROR RESERR ; On error, branch to error handler SUBL3 R7,R10,R0 ; Compute length to bound search SCANC R0,(R7),CHRTAB,#2 ; Find next digit BEQL 20$ ; If none: bad Fortran error MOVL R1,R7 ; Store non-digit address for routine BSBW INTCHG ; Interchange third label ON_ERROR RESERR ; On error, branch to error handler BRW WRTREC ; Done with arithmetic "If" 20$: MOVZBL #4,R0 ; Set error flag to invalid Fortran BRW RESERR ; and go to the fatal error handler GO: TSTL R9 ; Have we "(" (computed "Goto") BEQL 10$ ; No: handle "Goto-Assign" statements MOVL R7,SPCADD ; Store address after "(" for wrtspc 5$: SUBL3 R7,R9,R0 ; and handle "On-X-Goto" SCANC R0,(R7),CHRTAB,#2 ; Is there a digit remaining before ")" BEQL 20$ ; No: done with computed "Goto" MOVL R1,R7 ; Yes: store address for subroutine BSBW INTCHG ; Interchange old label with new ON_ERROR RESERR ; On error, branch to error handler BRB 5$ ; Continue to next label 10$: SCANC #1,(R7),CHRTAB,#2 ; Is non-blank a digit BEQL 15$ ; No: have an assigned "Goto" BSBW INTCHG ; Yes: have "Assign" or simple "Goto" ON_ERROR RESERR ; On error, branch to error handler BRW WRTREC ; Done with all "Goto" and "Assign" 15$: SUBL3 R7,R10,R0 ; Is there a statement label list LOCC #^A'(',R0,(R7) ; Find out by locating "(" BEQL 20$ ; No: no statement label list; done MOVL R1,R7 ; Yes: update delimiter byte address SUBL3 R7,R10,R0 ; Compute length LOCC #^A')',R0,(R7)+ ; Locate corresponding ")" BEQL 20$ ; None: (???) just write the record ADDL3 #1,R1,R9 ; Update parenthesis end address BRB 5$ ; and handle as if computed "Goto" 20$: BRW WRTREC ; Done with "Goto" IO: TSTL R9 ; Is there a "()" pair BNEQ 10$ ; Yes: handle as unit number given MOVL R7,SPCADD ; Store address of non-blank for wrtspc SCANC #1,(R7),CHRTAB,#2 ; Have default unit; is byte a digit BEQL 5$ ; No: must be format array or "*" BSBW INTCHG ; Yes: resequence format label ON_ERROR RESERR ; On error, branch to error handler 5$: BRW WRTREC ; Done with default unit I-O ; Have I-O with unit number and "()" 10$: BSBW EQLLBL ; Find "Err=" if any ON_ERROR RESERR ; On error, branch to error handler MOVZBL FTNTYP,R4 ; Examine type of statement CMPB #5,FTNADD[R4] ; Is statement "Encode" or "Decode" BEQL 50$ ; Yes: handle conventional format BISL2 #131072,R12 ; No: set bit 17 to indicate "Fmt=" BSBW EQLLBL ; Find "Fmt=" if any ON_ERROR RESERR ; On error, branch to error handler BLBS R1,60$ ; Branch if "Fmt=" label found and fixed 50$: MOVB #^A',',R6 ; Store comma in alternate byte register BSBW ADVCHR ; Locate comma or ")" ON_ERROR RESERR ; On error, branch to error handler BLBC R1,70$ ; If ")" found, just write record SPANC R2,(R8),CHRTAB,#4 ; Find a non-blank after the comma MOVL R1,R7 ; Store address of non-blank for later SCANC #1,(R7),CHRTAB,#2 ; Is non-blank in fact a digit BEQL 60$ ; No: branch BSBW INTCHG ; Yes: resequence it ON_ERROR RESERR ; On error, branch to error handler 60$: CMPB #8,FTNTYP ; Is statement a "Read" BNEQ 70$ ; No: all done with unit I-O CMPB #^A')',(R7) ; Yes: are we at ")" BEQL 70$ ; Yes: just write the record BISL2 #393216,R12 ; No: set bits 17 & 18 to find "End=" BSBW EQLLBL ; Find "End=" if any ON_ERROR RESERR ; On error, branch to error handler 70$: MOVL R9,SPCADD ; Save address of byte after ")" ; ; Prepare to write the Fortran statement ; WRTREC: BBSC #16,R12,20$ ; Branch on continuation flag set MOVAL IO_BUF,R7 ; Store output record start address SUBL3 R7,R10,R9 ; Compute output record length CMPW #72,R9 ; Is it greater than 72 bytes BGEQ 5$ ; No: just write simple record ; Yes: line exceeded 72 bytes during BSBW WRTCTN ; label resequence; handle as continued ON_ERROR RESERR ; On error, branch to error handler 5$: MOVW R9,OUT_RAB+RAB$W_RSZ ; Store output record size $PUT RAB=OUT_RAB ; and put it to the output file ON_ERROR RESERR ; On error, branch to error handler $GET RAB=IN_RAB ; Initiate getting the next record CMPW R12,(R11) ; Have we just processed a continuation BNEQ 40$ ; No: continue ADDL2 #4,R11 ; Yes: update ctn_data address pointer BRB 40$ ; Process next record if any ; ; Line was processed by subroutine reactn; record is in rec_buf and ; may exceed 72 bytes. next input record already in io_buf. ; 20$: MOVAL REC_BUF,R7 ; Line may exceed 72 bytes; write it MOVL R7,OUT_RAB+RAB$L_RBF ; Change the output buffer to rec_buf SUBL3 R7,R10,R9 ; Compute the record's length CMPW #72,R9 ; Is it greater than 72 bytes BGEQ 30$ ; No: just write it BSBW WRTCTN ; Yes: write as continuation lines ON_ERROR RESERR ; On error, branch to error handler 30$: MOVW R9,OUT_RAB+RAB$W_RSZ ; Store length of remaining record $PUT RAB=OUT_RAB ; and put it to the output file ON_ERROR RESERR ; On error, branch to error handler 40$: MOVAL IO_BUF,OUT_RAB+RAB$L_RBF; Return output buffer to IO_BUF BRW REAREC ; Next record already in io-buf; analyze ; ; Main exit section - termination normal ; EXIT: CMPL #^X1827A,R0 ; Was error an end-of-file BNEQ RESERR ; No: error while reading input file $CLOSE FAB=IN_FAB ; Yes: have normal termination $CLOSE FAB=OUT_FAB $EXIT_S R0 ; ; Fatal error handler ; RESERR: MOVL R0,R5 ; Save the error number $CREATE FAB=TYPE_FAB ; Open terminal for error messages $CONNECT RAB=TYPE_RAB ; and connect it MOVL #7,R2 ; Store highest error number CMPL R2,R5 ; Was error file I-O related BGEQ ERRBRC ; Yes: show file I-O error TYPE <%RES-F-FILEIO, file I-O error> BRW ERREXT ; Also show the rms error message ERRBRC: MOVL R5,R0 ; Set exit register to just show MOVL #^X10001,R5 ; My internal error message CASE R0, E0: TYPE <%RES-F-MAXLBLEX, maximum number of labels exceeded> BRW ERREXT E1: TYPE - <%RES-F-MAXCTNEX, maximum number of continued lines exceeded> BRW ERREXT E2: TYPE <%RES-F-MAXMDLEX, maximum number of modules exceeded> BRW ERREXT E3: TYPE - <%RES-F-FMTLOVLP, resequenced label overlaps user format label> BRW ERREXT E4: TYPE <%RES-F-ILLFOREN, illegal Fortran encountered> BRW SHOREC E5: TYPE <%RES-F-INVQUALV, invalid qualifier or value> BRW ERREXT E6: TYPE <%RES-F-INVLBLRE, invalid label referenced> BRW SHOREC E7: TYPE <%RES-F-RECTOOBIG, Fortran record too big> BRW ERREXT ; ; Show erroneous record and delete output file ; SHOREC: BBS #16,R12,10$ ; Branch if record in continuation area MOVAL IO_BUF,R2 ; Store address of I-O buffer BRB 20$ ; Continue 10$: MOVAL REC_BUF,R2 ; Record in continuation buffer 20$: SUBL3 R2,R10,R1 ; Compute the record length MOVW R1,TYPE_RAB+RAB$W_RSZ ; and store it for typer MOVL R2,TYPE_RAB+RAB$L_RBF ; Also the record start address $PUT RAB=TYPE_RAB ; Show fatal error record $FAB_STORE FAB=OUT_FAB,- FOP=DLT ; Make output file disposal "Delete" ERREXT: $CLOSE FAB=IN_FAB $CLOSE FAB=OUT_FAB $CLOSE FAB=TYPE_FAB $EXIT_S R5 ; ; ; Subroutine Interchange ; ; Inputs: ; ; R7 - Address of first digit in old label string (5 digits or less) ; R9 - Clear or address of right parenthesis ; R10 - Address of first byte past current record (eor) ; ; Outputs: ; ; R0 - Error code ; R1-R6 - Destroyed ; R7 - Address of byte after inserted new label ; R8 - Destroyed ; R9 - If clear: change in number of characters; otherwise new ; address of right parenthesis ; R10 - New address of first byte past current record (eor) ; INTCHG::BSBB NEWLBL ; Get length and address of new label ON_ERROR 20$ ; If label not found, fatal error MOVL R5,R8 ; Store length in more permanent reg ; Now compute the address of byte after ADDL3 R7,R8,R2 ; New label when it replaces old label CMPL R2,R4 ; Do labels end at same address BEQL 10$ ; Yes: do simple move SUBL3 R4,R10,R0 ; No: compute number of bytes to eor BNEQ 5$ ; Branch if old label end not eor ; Old label end is eor; just make the MOVL R2,R10 ; New eor the new label end address BRB 10$ ; and make a simple move 5$: MOVC3 R0,(R4),(R2) ; Move characters following old label SUBL2 R10,R3 ; Compute change in characters ADDL2 R3,R10 ; Use change to adjust eor address ADDL2 R3,R9 ; and address of byte following ")" 10$: MOVC3 R8,(R6),(R7) ; Move new label to old MOVL R3,R7 ; Return location of trailing non-digit MOVB #1,R0 ; Set error flag to success 20$: RSB ; ; ; Subroutine New Label ; ; Inputs: ; ; R7 - Address of first digit in old label string (5 digits or less) ; R10 - Address of first byte past current record (eor) ; ; Outputs: ; ; R0 - Error code ; R1-R3 - Destroyed ; R4 - Address of old label end ; R5 - Length of new label in label map ; R6 - Address of new label in label map ; R7 - Untouched ; R10 - Untouched ; NEWLBL::SPANC #6,(R7),CHRTAB,#2 ; Find non-digit after old label CMPL R10,R1 ; Was last digit past eor BGEQ 5$ ; No: continue MOVL R10,R1 ; Yes: make sure address is just eor 5$: CMPB #^A'0',(R7) ; Is first digit a leading zero BNEQ 10$ ; No: continue MOVL R1,R2 ; Yes: save address of trailing byte SUBL3 R1,R7,R0 ; Compute length of whole digit string SKPC #^A'0',R0,(R7) ; Find next non-zero digit BEQL 30$ ; On fail, have fatal label error SUBL3 R1,R2,R6 ; Place digit string length in R6 MOVC3 R6,(R1),CMPBUF+1 ; Move remaining digit string to buffer BRB 20$ ; Done with leading zero exception 10$: SUBL3 R7,R1,R6 ; Place digit string length in R6 MOVC3 R6,(R7),CMPBUF+1 ; Move digit string to search buffer 20$: MOVB #^A'*',(R3) ; Append asterisk to search buffer MOVB #^A';',CMPBUF ; Lead with semi-colon delimiter MOVL R1,R4 ; Save address of digit string end ADDB2 #2,R6 ; Compute new length of search buffer MOVL LBLBEG,R0 ; Store address of map's first byte MATCHC R6,CMPBUF,LBLLEN,(R0) ; Find old label in label map BEQL 40$ ; Branch on successful label match 30$: MOVZBL #6,R0 ; Set error flag to "Invalid label" RSB ; and return with error 40$: MOVL R3,R6 ; Store address of map's new label LOCC #^A';',#6,(R6) ; Find ";" that trails new label SUBL3 R6,R1,R5 ; Store new label length in R5 MOVB #1,R0 ; Set error flag to success RSB ; ; Subroutine Read Continuations ; ; Inputs: ; ; R7 - Address of delimiter byte in io_buf ; R10 - Address of eor ; R11 - Address in ctn_data holding record number of the ; Present continued Fortran line ; ; Outputs: ; ; R0 - Error code ; R1-R6 - Destroyed ; R7 - New address of delimiter byte in rec_buf ; R8 - Address of io_buf ; R9 - Number of continuation lines processed ; R10 - New address of eor in rec_buf ; R11 - Address in ctn_data of next continued record number ; REACTN::BISL2 #65536,R12 ; Set the continuations read flag MOVAL IO_BUF,R8 ; Store address of the I-O buffer SUBL2 R8,R7 ; Compute distance to delimeter byte MOVAL REC_BUF,R2 ; Store address of 512 byte buffer and ADDL2 R2,R7 ; Use it to get new address of delimiter MOVC3 IN_RAB+RAB$W_RSZ,(R8),(R2); Move io_buf to rec_buf $GET RAB=IN_RAB ; Initiate getting first continuation MOVL R3,R10 ; Update the eor address register CLRL R6 ; Clear a loop counter MOVZWL B^2(R11),R9 ; Store number continued lines present ADDL2 #4,R11 ; Update ctn_data address pointer 10$: INCW R12 ; Increment the record counter $WAIT RAB=IN_RAB ; Wait for the next record ON_ERROR 40$ ; On error, branch to error handler CMPB #9,(R8) ; Is first character a tab BNEQ 20$ ; No: have ordinary continuation line MOVZWL #2,R0 ; Yes: have continued line using tab BRB 30$ ; Proceed to append line to rec_buf 20$: MOVZWL #6,R0 ; Field length is normal (6 bytes) 30$: SUBW3 R0,IN_RAB+RAB$W_RSZ,R1 ; Adjust size accounting for ctn field ADDL3 R0,R8,R2 ; Compute address after ctn field byte SPANC R1,(R2),CHRTAB,#4 ; Get to non-blank after ctn field MOVC3 R0,(R1),(R10) ; Append continuation to rec_buf $GET RAB=IN_RAB ; and initiate getting next record MOVL R3,R10 ; Update eor address AOBLSS R9,R6,10$ ; If more continued lines: repeat MOVB #1,R0 ; Set error flag to success ; Next rec already on its way: return 40$: RSB ; ; Subroutine Write Continuations ; ; Inputs: ; ; R7 - Address of first byte in current record ; R10 - Eor byte address ; ; Outputs: ; ; R0 - Error code ; R1-R6 - Destroyed ; R7 - Starting address of remaining record ; R8 - Destroyed ; R9 - Length of record remaining in output buffer (LEQ than 72) ; R10 - Eor address of remaining record (same as input) ; WRTCTN::TSTL SPCADD ; Use special continuation processing BEQL 5$ ; No: must use default processing BSBW WRTSPC ; Yes: handle with special ctn write BLBC R1,20$ ; Use default processor if necessary 5$: MOVW #72,OUT_RAB+RAB$W_RSZ ; Set output buffer size to 72 bytes 10$: $PUT RAB=OUT_RAB ; Put partial record to output file ON_ERROR 20$ ; On error, branch to error handler ADDL2 #66,R7 ; Update remaining record start address MOVL R7,OUT_RAB+RAB$L_RBF ; and store it in out_rab MOVL #^A' ',(R7) ; Store 4 spaces in continuation field MOVW #^A' &',B^4(R7) ; and append " &" as continuation mark SUBL3 R7,R10,R9 ; Compute the remaining record length CMPW #72,R9 ; Is it greater than 72 bytes BLSS 10$ ; Yes: repeat this process MOVB #1,R0 ; No: set error flag to success 20$: RSB ; Return to write remaining record ; ; Subroutine Advance to Character ; ; Inputs: ; ; R6 - ASCII code of alternate search byte; otherwise clear ; R7 - Address of of byte on which to begin search ; R10 - Eor address ; R12 - Bit 19: set if a direct access I-O check required ; ; Outputs: ; ; R0 - Error code ; R1 - Low bit set when alternate byte was found first ; R2 - If alternate found, number of bytes to eor; otherwise scratch ; R3-R5 - Destroyed ; R6 - Same as input ; R7 - Updated to "r" address if (r'u) present; otherwise untouched ; R8 - Address after alternate byte or ")", whichever first ; R10 - Same as input ; R12 - Bit 19: cleared if "r'u" found; otherwise set ; ADVCHR::MOVZBL #1,R4 ; Set parenthesis counter to one MOVL R7,R8 ; Store address of start byte TSTB R6 ; Is alternate search byte reg clear BEQL 10$ ; Yes: branch MOVZBL R6,R6 ; No: build index out of ASCII code MOVB CHRTAB[R6],R5 ; Save chrtab mask value MOVB #8,CHRTAB[R6] ; Replace with mask eight - "()'" 10$: SUBL3 R8,R10,R0 ; Compute distance to eor SCANC R0,(R8),CHRTAB,#8 ; and find next "()'" or alternate BEQL 25$ ; On fail, have a fatal error SUBB3 #39,(R1)+,R2 ; Tranform ASCII code for case branch MOVL R1,R8 ; Update to address of byte following CASE R2,<15$ 35$ 40$> ; Branch on "' ( )" CMPB #1,R4 ; Have alternate; is just one "(" BNEQ 10$ ; No: alternate inside new "()" MOVB #1,R1 ; Yes: set alternate byte found flag MOVL R0,R2 ; Save number of bytes to eor MOVB #1,R0 ; Set error flag to success BRB 50$ ; and prepare to exit 15$: SUBL3 R8,R10,R3 ; Have "'"; compute distance to eor BBC #19,R12,20$ ; Branch if direct access problem ok BSBW DAEVAL ; See if I-O of form (r'u,...) BRB 10$ ; Direct access ok; continue with search 20$: LOCC #^A"'",R3,(R8) ; Locate corresponding "'" BNEQ 30$ ; Branch on success 25$: MOVZBL #4,R0 ; Fatal "Invalid Fortran" error BRB 45$ ; Clean-up and return with error 30$: ADDL3 #1,R1,R8 ; Examine the following byte BRB 10$ ; During next search 35$: INCB R4 ; Have "("; increment counter BRB 10$ ; and continue search for ")" 40$: SOBGTR R4,10$ ; Have ")"; repeat on counter not zero CLRB R1 ; Have last corresponding ")" MOVB #1,R0 ; Set error flag to success 45$: TSTB R6 ; Was there an alternate given BEQL 60$ ; No: branch 50$: MOVB R5,CHRTAB[R6] ; Yes: replace original mask in chrtab 60$: RSB ; All done ; ; Subroutine Direct Access I-O Evaluator ; ; Inputs: ; ; R3 - Number of bytes to eor from "'" ; R7 - Address of first byte in string ; R8 - Address of byte after "'" ; R10 - Eor address ; R12 - Bit 19: set ; ; Outputs: ; ; R0 - Error code ; R1-R3 - Scratch ; R7 - Address of "r" if (r'u) present; otherwise untouched ; R8 - Address of first byte after correct "'" ; R10 - Untouched ; R12 - Bit 19: cleared ; DAEVAL::BICL2 #524288,R12 ; Clear the direct access flag LOCC #^A"'",R3,(R8) ; Do we have a matching "'" BEQL 70$ ; No: have direct access I-O statement ; May still have direct access I-O MOVL R1,ADDHLD ; Save address of second "'" SUBL3 #2,R8,R1 ; Compute address before "'" 10$: SCANC #1,(R1),CHRTAB,#4 ; Is it space or tab BNEQ 40$ ; Yes: continue looking back SCANC #1,-(R1),CHRTAB,#50 ; No: is it a legal unit specifier char BEQL 60$ ; No: do not have direct access I-O BRB 70$ ; Yes: have direct access I-O 40$: DECL R1 ; Adjust address back one byte CMPL R1,R7 ; Have we gone before start BGEQ 10$ ; No: continue looking ; Yes: do not have direct access I-O 60$: ADDL3 #1,ADDHLD,R8 ; Compute address after second "'" RSB ; Return 70$: MOVL R8,R7 ; Update R7 to address of "r" in (r'u) RSB ; ; Subroutine Find "Err=", "Fmt=" or "End=" ; ; Inputs: ; ; R7 - Address of first byte in string ; R9 - Address of first byte after ")" ; R10 - Eor address ; R12 - Bit 17: set if looking for "Fmt=" or "End="; clear: "Err=" ; R12 - Bit 18: set if looking for "End="; clear: "Fmt=" ; ; Outputs: ; ; R0 - Error code ; R1 - Low bit set if label found and changed ; R2-R6 - Scratch ; R7 - Untouched ; R8 - Destroyed ; R9 - New address of first byte after ")" ; R10 - New eor ; R12 - Bit 17: clear ; R12 - Bit 18: clear ; EQLLBL::MOVB #^A',',R6 ; Set alternate delimiter to "," MOVL R7,ADDHLD ; Save the address held in R7 MOVL R7,R8 ; Start with first byte SUBL3 R8,R9,R2 ; Compute number of bytes to ")" 10$: SPANC R2,(R8),CHRTAB,#4 ; Get to next non-blank MOVL R1,R7 ; Update current address BICL3 #LCMSKL,(R1),CMPBUF ; Mask out lowercase BBC #17,R12,30$ ; Do we want to handle "Err="; branch BBC #18,R12,25$ ; Do we want to handle "Fmt="; branch CMPC3 #3,CMPBUF,ENDSTR ; "End="; are next 3 bytes "End" BNEQ 40$ ; No: continue looking until ")" BRB 35$ ; Yes: check for equal sign 25$: CMPC3 #3,CMPBUF,FMTSTR+6 ; "Fmt="; are next 3 bytes "Fmt" BNEQ 40$ ; No: continue looking until ")" BRB 35$ ; Yes: check for equal sign 30$: CMPC3 #3,CMPBUF,ERRSTR ; "Err="; are next 3 bytes "Err" BNEQ 40$ ; No: continue looking until ")" 35$: ADDL2 #3,R7 ; Adjust current address to after string SUBL3 R7,R9,R0 ; Yes: compute length to ")" SPANC R0,(R7),CHRTAB,#4 ; Get to next non-blank CMPB #^A'=',(R1)+ ; Is it an equal sign BNEQ 40$ ; No: resume equal search SUBL3 R1,R9,R0 ; Yes: compute length to bound search SPANC R0,(R1),CHRTAB,#4 ; Get to next non-blank SCANC #1,(R1),CHRTAB,#2 ; Is it a digit BEQL 50$ ; No: (???) just write this record MOVL R1,R7 ; Yes: place address in R7 for routine BSBW INTCHG ; Interchange old label with new ON_ERROR 60$ ; On error, branch to error handler MOVB #1,R1 ; Set the label found and fixed flag BRB 55$ ; Prepare to leave 40$: CMPL R7,R9 ; Have we passed ")" BGEQU 50$ ; Yes: done with equal label search BSBW ADVCHR ; No: find next delimiting "," ON_ERROR 60$ ; On error, branch to error handler BLBC R1,50$ ; Found ")"; all done BRW 10$ ; Branch if comma found (alternate) 50$: CLRB R1 ; Clear the label found and fixed flag 55$: MOVB #1,R0 ; Set error code to success 60$: MOVL ADDHLD,R7 ; Restore original address BICL2 #393216,R12 ; Clear both R12 flag bits RSB ; ; Subroutine Special Continuation Line Processor ; ; Inputs: ; ; R7 - Address of first byte in current record ; R10 - Eor byte address ; ; Outputs: ; ; R0 - Error code ; R1 - Low bit set if default continuation processing still needed ; R2-R6 - Destroyed ; R7 - Starting address of remaining record ; R8 - Destroyed ; R9 - Length of record remaining in output buffer (LEQ than 72) ; R10 - Eor address of remaining record (same as input) ; R11-R12 - Untouched ; WRTSPC::MOVL R7,R9 ; Save record start address MOVL SPCADD,R7 ; Get start address to be used by advchr SUBL3 R9,R7,R0 ; Compute number of bytes from start CMPW #72,R0 ; Is number greater than 72 BLEQ 15$ ; Yes: must use default processor MOVB #^A',',R6 ; Place comma in alternate for advchr 5$: BSBW ADVCHR ; Find byte after comma or ")" ON_ERROR 10$ ; If no "," or trailing ")", branch SUBL3 R9,R8,R0 ; Compute distance from record start CMPW #72,R0 ; Is it greater than 72 BLEQ 20$ ; Yes: write to previous comma MOVL R8,R7 ; No: store address after ")" or "," BLBS R1,5$ ; If "," found, look for more BRB 30$ ; Found ")"; return to write this record 10$: SUBL3 R7,R10,R2 ; Compute number bytes remaining CMPW #64,R2 ; Will it all fit on one more line BGEQ 25$ ; Yes: write first part of record ; Must use default processor 15$: MOVL R9,R7 ; Reset R7 to rec_buf start address MOVB #1,R1 ; Indicate default processing required RSB 20$: SUBL3 R7,R10,R2 ; Compute number of characters remaining 25$: SUBL3 R9,R7,R1 ; Compute record length MOVW R1,OUT_RAB+RAB$W_RSZ ; and store it $PUT RAB=OUT_RAB ; Put record to output file ON_ERROR 50$ ; On error, proceed to error handler SPANC R2,(R7),CHRTAB,#4 ; Get to next non-blank SUBL3 #8,R1,R9 ; Compute address of 8 bytes before MOVQ #^A' & ',(R9) ; Store continuation and trailer MOVL R9,OUT_RAB+RAB$L_RBF ; Store record start address MOVL R1,R7 ; Save non-blank address after "," CMPW #64,R0 ; Is record (with continuation) too long BLSS 5$ ; Yes: find "," or ")" to break it up ADDB2 #8,R0 ; No: compute actual record length 30$: MOVL R9,R7 ; Restore last record start address MOVZBL R0,R9 ; Save record length MOVB #1,R0 ; Set error flag to success 50$: CLRB R1 ; Indicate default processing not nec. RSB .END RESFOR