.TITLE RESFOR - RESEQUENCE FORTRAN SOURCE ; ; IDENTIFICATION - 950037 ; ; REV _J V 3.0 - ACCEPT WILDCARD FILE SPECIFICATIONS - 03/83. ; REV _K V 3.1 - ADD "INQUIRE" STATEMENT "ERR=" RESEQUENCE - 04/83. ; REV _L V 3.2 - PARAMETERIZE CONTINUATION STATEMENT BUFFER ; SIZE. OPTIMIZE WILDCARD FILE PROCESSING - 05/83. ; ;++ ; ; RESFOR.MAR - Resequences labels of Fortran source code. Fortran must ; be compilable under DEC software. A 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. Also, continued executable Fortran statements with ; embedded comments (inline or otherwise), will produce unpredictable ; results. ; ; 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 labels, if any, 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 - if too small, ; "Maximum number of labels exceeded" error will be generated. LBLQTY=1024 ; ; Maximum number of lines having continuations - if too small, ; "Maximum number of continuation lines exceeded" error will be generated. CTNQTY=256 ; ; Maximum size of continuation line buffer - if too small, ; "Continuation buffer overflow" error will be generated. CTNBSZ=512 ; ; Maximum number of subroutines to be resequenced at once - if too small, ; "Maximum number of subprograms exceeded" error will be generated. 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 IN_FAB: $FAB DNM=<.FOR>,- ; Default input file type FAC=GET,- ; Read only FOP=,- ; Sequential only, name block NAM=IN_NAM ; Name block for wildcard resol. $NAMDEF IN_NAM: $NAM RSA=IN_RES_STR,- ; Result buffer address RSS=NAM$C_MAXRSS,- ; Result buffer size ESA=IN_EXP_STR,- ; Expanded buffer address ESS=NAM$C_MAXRSS ; Expanded buffer size IN_RAB: $RAB FAB=IN_FAB,- UBF=IO_BUF,- USZ=128 OUT_FAB: $FAB FNS=13,- ; Output file name/type size FNA=OUTFIL,- ; and start address FAC=PUT,- ; Write access FOP=SQO,- ; Sequential only RAT=CR,- ; Carriage attributes NAM=OUT_NAM ; Name block for delete on close OUT_NAM: $NAM OUT_RAB: $RAB FAB=OUT_FAB,- RBF=IO_BUF,- RSZ=72 IN_RES_STR: .BLKB NAM$C_MAXRSS ; Resultant string buffer IN_EXP_STR: .BLKB NAM$C_MAXRSS ; Expanded string buffer OUTFIL: .BLKB 13 ; Output file buffer for FAB ; ; 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 ; PZERLB: .PACKED 00000000 ; Zero packed decimal 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=" SPCADD: .ADDRESS 0 ; Address hold for special continue routine STM_MSZ: .WORD 0 ; Maximum length of statement and leader CTN_MSZ: .WORD 0 ; Maximum length of continuation and leader CTN_MFSZ: .WORD 0 ; Maximum length of continuation w/o leader CTN_ASZ: .LONG 0 ; Actual length of continuation line leader CTN_LDR: .ASCII " & " .BLKB 56 ; Continuation line leader buffer CTN_BUF: .BLKB CTNBSZ ; Continuation line buffer; multiple lines CBFEND=. IO_BUF: .BLKB 128 ; Main record I-O buffer; one line ; ; Byte, word and longword lowercase to uppercase bit masks ; LCMSKB=32 LCMSKW=8224 LCMSKL=538976288 ; ; Bit masks for flagging ; BIT16=65536 BIT17=131072 BIT18=262144 BIT19=524288 BIT20=1048576 BIT21=2097152 BIT22=4194304 ; ; 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 "REWRITEINQUIREENDFILE" .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,23,24 ; ; 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[5],3 ; ; Address of each keyword in keyword list: 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 .ADDRESS FTNSTM+111 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 qualifiers ; .PSECT CODE,EXE,NOWRT,LONG .ENTRY RESFOR, ^M<> ; Main entry point ; 5$: PUSHAL PROMPT ; Push prompt address to stack PUSHAL STRING ; Push target string address CALLS #2,LIB$GET_FOREIGN ; Get the entire command line CMPL #RMS$_EOF,R0 ; Was EOF (Control-Z) given BNEQ 10$ ; If not, continue MOVL #RMS$_NMF,R0 ; EOF; Simulate no more files - exit BRW EXIT 10$: ON_ERROR RESERR ; On error, branch to error handler SPANC #CMDLEN,CMDSTR,CHRTAB,#4; Were non-blanks given BEQL 5$ ; No: just re-issue the prompt 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,G^LIB$TPARSE ; Parse the command line BLBS R0,15$ ; On success, continue MOVZBL #5,R0 ; Indicate qualifier error message need BRW RESERR ; and proceed to error handler ; ; Command line successfully parsed with TPARSE. Store file in FAB. ; 15$: MOVB TPARSE_BLOCK+TPA$L_STRINGCNT,- IN_FAB+FAB$B_FNS ; Store file name size MOVL TPARSE_BLOCK+TPA$L_STRINGPTR,- IN_FAB+FAB$L_FNA ; Store file name address $PARSE FAB=IN_FAB ; Parse (wildcard?) file specification ON_ERROR RESERR ; On error, branch to error handler BBC #NAM$V_WILDCARD,IN_NAM+NAM$L_FNB,OPNFIL ; Branch if no wildcards ; ; ; Main file processing loop for RESEQUENCE!! Handle wildcard specs. ; RESFIL: $SEARCH FAB=IN_FAB ; Find next file ON_ERROR EXIT ; On error, branch to error handler OPNFIL: $OPEN FAB=IN_FAB ; Open input file ON_ERROR RESERR ; On error, branch to error handler $CONNECT RAB=IN_RAB ; Connect stream ON_ERROR RESERR ; On error, branch to error handler $RAB_STORE RAB=IN_RAB,- ; First pass need only access input ROP=LOC ; file in "LOCATE" mode ; ; Initialize data structures and qualifier values for this RESEQUENCE ; MOVAL LBL_DATA,LBLBEG ; Initialize label map start address CLRW LBLLEN ; and map length MOVAL MDL_DATA,MDLPTR ; Initialize module data start address MOVP #8,PZERLB,PNEWLB ; Set current new label field to zeros CLRL R10 ; Clear the flag longword BLBC PARSER_FLAGS,20$ ; Branch if no special increment MOVL INCREMENT,R1 ; Store increment BEQL 15$ ; Yes: illegal qualifier value CMPL R1,#99 ; Is increment greater than 99 BGTRU 15$ ; Yes: illegal qualifier 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 15$: MOVZBL #5,R0 ; Indicate qualifier error message need BRW RESERR ; and proceed to error handler 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 BVC 10$ ; Check for too many records MOVZBL #9,R0 ; Set file too big error BRW RESERR ; and proceed to error handler 10$: MOVL IN_RAB+RAB$L_RBF,R6 ; Store address of first byte in R6 BSBW CHKCOM ; Confirm we are not on comment line ON_ERROR MAPLBL ; Prepare to get next record if comment ADDL3 #5,R6,R2 ; Store address of continuation field MOVL R4,R0 ; Save current record length MOVL R6,R4 ; Set R4 to address of label field ADDL2 R0,R6 ; Compute end of record (eor) address CMPB #^A'D',R5 ; 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 CLRW (R11) ; and clear number of continued lines CMPL #CTNEND,R11 ; Has data structure overflowed? BGTRU 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: 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 #RMS$_EOF,R0 ; Was error an end-of-file BEQL 10$ ; Yes: all ok; continue CMPL #RMS$_RTB,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 ; ; Reset input file; Open output file under same name. ; 10$: $REWIND RAB=IN_RAB ; Reset input file to start for pass 2 ON_ERROR RESERR ; On error, branch to error handler $RAB_STORE RAB=IN_RAB,- ; Second pass needs to access input ROP=ASY ; file in "MOVE" mode - ASY $GET RAB=IN_RAB ; Launch GET of first input file record MOVZBW IN_NAM+NAM$B_NAME,R0 ; Move input file name to OUT_FAB addr MOVL IN_NAM+NAM$L_NAME,R1 ; File type address MOVC5 R0,(R1),#32,#9,OUTFIL ; Pad with spaces MOVZBW IN_NAM+NAM$B_TYPE,R0 ; Move input file type to OUT_FAB addr MOVL IN_NAM+NAM$L_TYPE,R1 ; File type address MOVC5 R0,(R1),#32,#4,OUTFIL+9 ; Pad with spaces $FAB_STORE FAB=OUT_FAB,- FOP=SQO ; Sequential access only $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 CLRW (R11) ; Mark end of continuation data struct. 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 ; | | |__________ alternate found by Advchr ; | |____________ continuation point advancement ; |______________ processing "DO2WHILE(X)" ; 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 MOVL R8,R6 ; Store record start address for routine BSBW CHKCOM ; Check for Fortran comment line BLBS R0,CHKLBL ; If not comment line, check for label MOVW R4,OUT_RAB+RAB$W_RSZ ; Comment: store record size for output $PUT RAB=OUT_RAB ; Put comment 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',R5 ; 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 CTN_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 70$ ; 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 #BIT19,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 #BIT19,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 70$ ; Yes: have no label here BSBW PCKSTM ; Check packed statement for label ON_ERROR WRTREC ; On error - statement has no label BRB 80$ ; Packed statement has label 35$: MOVL R1,R7 ; Save address of the non-blank 40$: CMPB #^A'=',(R1) ; Is non-blank an equal sign - assignmt BNEQ 80$ ; No: statement has label 70$: BRW WRTREC ; Statement has no label; write it 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 BBC #20,R12,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 #BIT17,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 BBC #20,R12,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 ; label resequence; handle as continued SCANC R9,IO_BUF+1,CHRTAB,#16 ; Get to first letter of Fortran keyword MOVL R1,R8 ; Save its address for leader builder BSBW BLDLDR ; Build the continuation line leader BSBW WRTCTN ; and write statement 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 CTN_BUF and ; may exceed 72 bytes. Next input record already in io_buf. ; 20$: MOVAL CTN_BUF,R7 ; Line may exceed 72 bytes; write it MOVL R7,OUT_RAB+RAB$L_RBF ; Change the output buffer to CTN_BUF SUBL3 R7,R10,R9 ; Compute the record's length CMPW STM_MSZ,R9 ; Is it greater than maximum allowed BGEQ 30$ ; No: just write simple record BSBW WRTCTN ; Yes: write continued statement 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 ; ; ; ; RESEQUENCE error handler - terminates current file processing. ; RESERR: MOVL R0,R4 ; Save error code in permanent register MOVW TYPE_FAB+FAB$W_IFI,R0 ; Check console IFI BNEQ 10$ ; Don't re-open console $CREATE FAB=TYPE_FAB ; Open console for output ON_ERROR 30$ ; Error while doing error recovery!! $CONNECT RAB=TYPE_RAB ; Connect console ON_ERROR 30$ ; Error while doing error recovery!! 10$: CMPL #16,R4 ; Was error an RMS error BGEQ 20$ ; No: show standard RESEQUENCE error BRW ERRRMS ; and then show the RMS message 20$: CASE R4, 30$: $EXIT_S R0 ; Error recovery error ; ; RESEQUENCE error message section. ; E0: TYPE <%RES-E-MAXLBLEXC, maximum number of labels exceeded> BRW ERRFIN E1: TYPE - <%RES-E-MAXCTNEXC, maximum number of continued lines exceeded> BRW ERRFIN E2: TYPE <%RES-E-MAXSUBEXC, maximum number of subprograms exceeded> BRW ERRFIN E3: TYPE - <%RES-E-FMTLOVLP, resequenced label overlaps user FORMAT label> BRW ERRFIN E4: TYPE <%RES-E-ILLFORTR, illegal FORTRAN> BRW ERRREC E5: TYPE <%RES-E-INVQUAVAL, invalid qualifier or value> BRW ERRFIN E6: TYPE <%RES-E-INVLBLREF, invalid label referenced> BRW ERRREC E7: TYPE <%RES-E-RECTOOBIG, FORTRAN record too big> BRW ERRFIN E8: TYPE <%RES-E-CTNBUFOVF, continuation line buffer overflow> BRW ERRREC E9: TYPE <%RES-E-FILTOOBIG, file too big> BRW ERRFIN ERRRMS: TYPE <%RES-E-FILEIO, file I/O error>; Preface with general error $EXIT_S R4 ; Show the RMS error and quit ; ; Show error causing FORTRAN record and delete output file. ; ERRREC: 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 CTN_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" ; ; Show resequence not complete warning and file specification. ; ERRFIN: MOVW IN_FAB+FAB$W_IFI,R0 ; Check input file IFI BNEQ 10$ ; Branch if open ; Error before input file opened MOVL #RMS$_NMF,R0 ; Simulate SEARCH "no more files" BRW EXIT ; to bring orderly error exit 10$: TYPE <%RES-W-ERRINPFIL, resequence error processing file -> MOVZBW IN_NAM+NAM$B_RSL,- TYPE_RAB+RAB$W_RSZ ; Store file spec size MOVAL IN_RES_STR,- TYPE_RAB+RAB$L_RBF ; Also the file spec start address $PUT RAB=TYPE_RAB ; Show input file specification MOVL #RMS$_EOF,R0 ; Send EOF signal to exit handler ; ; ; All normal termination. Confirm all files under wildcard processed. ; EXIT: CMPL #RMS$_EOF,R0 ; Check for RMS end-of-file on GET BNEQ 10$ ; If EOF, $CLOSE FAB=IN_FAB ; close input file ON_ERROR RESERR ; On error, branch to error handler MOVW OUT_FAB+FAB$W_IFI,R0 ; Check output file IFI BEQL 5$ ; Don't close file if not open $CLOSE FAB=OUT_FAB ; Close output file ON_ERROR RESERR ; On error, branch to error handler 5$: BBC #NAM$V_WILDCARD,IN_NAM+NAM$L_FNB,20$ ; All done if no wildcards BRW RESFIL ; Resume $SEARCH for next file spec ; ; Check for "No More Files" error from $SEARCH. ; 10$: CMPL #RMS$_NMF,R0 ; Not EOF; is condition no more files? BEQL 20$ ; If not, BRW RESERR ; have legitimate RMS error 20$: MOVL #^X00010001,R0 ; This is successful normal completion $EXIT_S R0 ; Done with RESEQUENCE ; Check if Fortran line is comment ; ; Inputs: ; ; R6 - Start address of record ; ; Outputs: ; ; R0 - Error code - clear if statement is comment ; R1-R3 - Destroyed ; R4 - Record size from RAB (<=72) ; R5 - Uppercase ASCII of first byte if it is non-blank (zero otherwise) ; R6 - Untouched ; CHKCOM::CLRL R5 ; Clear first byte of record output MOVZWL IN_RAB+RAB$W_RSZ,R4 ; Store record size BEQL 50$ ; If zero, treat as Fortran comment CMPW #72,R4 ; Is it greater than 72 bytes BGEQ 20$ ; No: see if record has non-blanks MOVW #72,R4 ; Effective size of record is 72... ; we ignore columns 73-80 20$: SPANC R4,(R6),CHRTAB,#4 ; Check record for any non-blank BEQL 50$ ; If just blanks, treat as comment CMPL R1,R6 ; Is non-blank in column one BNEQU 30$ ; No: see if it is "!" comment BICB3 #LCMSKB,(R6),R5 ; Mask out a lowercase alphabetic CMPB #^A'C',R5 ; Is first byte a "C" or "c" BEQL 50$ ; Yes: we have classic comment CMPB #^A'!',(R6) ; Is first byte a "!" BEQL 50$ ; Yes: we have inline comment CMPB #^A'*',(R6) ; Is first byte a "*" BEQL 50$ ; Yes: we have non-standard comment BRB 40$ ; Have non-comment Fortran 30$: CMPB #^A'!',(R1) ; Is non-blank byte a "!" BNEQ 40$ ; No: comment not possible ; May have inline comment SUBL2 #5,R1 ; Check if "!" is continuation chr by CMPL R1,R6 ; comparing adjusted address with start BNEQ 50$ ; If not in column 6, we have comment LOCC #9,#5,(R6) ; May still have comment... BNEQ 50$ ; but only if Tab is present in leader ; We have continuation line with "!" 40$: MOVB #1,R0 ; Have non-comment - Return success RSB 50$: CLRB R0 ; We are on a Fortran comment line RSB ; ; ; Interchange Old Label with New ; ; 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 return code to success 20$: RSB ; ; ; Find New Label in Label Map ; ; 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 return code 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 return code to success RSB ; ; Read Continuations ; ; Inputs: ; ; R7 - Address of delimiter byte in io_buf ; R8 - Address of first byte of Fortran keyword ; 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 CTN_BUF ; R8 - Address of io_buf ; R9 - Number of continuation lines processed ; R10 - New address of eor in CTN_BUF ; R11 - Address in ctn_data of next continued record number ; REACTN::BISL2 #BIT16,R12 ; Set the continuations read flag BSBW BLDLDR ; Build continuation line leader MOVAL IO_BUF,R8 ; Store address of the I-O buffer SUBL2 R8,R7 ; Compute distance to delimiter byte MOVAL CTN_BUF,R2 ; Store address of CTNBSZ byte buffer & ADDL2 R2,R7 ; use it to get new address of delimiter SUBL3 R8,R10,R0 ; Compute length to eor MOVC3 R0,(R8),(R2) ; Move io_buf to CTN_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 MOVZBL #6,R0 ; Field length is normal (6 bytes) CMPB #9,(R8) ; Is first character a tab BNEQ 30$ ; No: have ordinary continuation line MOVB #2,R0 ; Yes: have continued line using tab 30$: SUBW3 R0,IN_RAB+RAB$W_RSZ,R1 ; Adjust size accounting for ctn field ADDL3 R0,R8,R2 ; Compute address after ctn field SPANC R1,(R2),CHRTAB,#4 ; Get to non-blank after ctn field MOVC3 R0,(R1),(R10) ; Append continuation to CTN_BUF $GET RAB=IN_RAB ; and initiate getting next record MOVL R3,R10 ; Update eor address CMPL #CBFEND,R10 ; Have we overflowed continuation buffer BGTRU 35$ ; If no, maybe read more MOVZBL #8,R0 ; Continuation line buffer overflow BRB 40$ ; Proceed to error handler 35$: AOBLSS R9,R6,10$ ; If more continued lines: repeat MOVB #1,R0 ; Set return code to success ; Next rec already on its way 40$: RSB ; ; Build Continuation Leader ; ; Inputs: ; ; R8 - Address of first byte of Fortran keyword ; ; Outputs: ; ; R0-R6 - Destroyed ; R8 - Untouched ; BLDLDR::CLRL R6 ; Clear register for use as counters MOVAL IO_BUF,R4 ; Store record start address 10$: ADDL2 #^X00010001,R6 ; Increment both counters CMPB #9,(R4)+ ; Are we at a tabulation character BNEQ 15$ ; No: continue to next byte DIVB3 #8,R6,R0 ; Yes: how many tab stops have we got INCB R0 ; Calculate next tab stop MULB3 #8,R0,R6 ; which becomes new effective byte count BVC 15$ ; Have we too many tabs (overflow) MOVL #^X00010008,R6 ; Yes: just use an acceptable default BRB 20$ ; Continue; this should rarely happen 15$: CMPL R4,R8 ; Have we reached first letter of keywrd BNEQ 10$ ; No: examine next byte of leader 20$: EXTV #16,#8,R6,R2 ; Extract actual number of bytes MOVB #72,R1 ; Store maximum number of bytes/line SUBB3 R2,R6,R0 ; Difference between effective & actual CMPB #8,R0 ; Is difference one tab stop or more BGTR 30$ ; No: maximum is source line maximum SUBB3 R0,#80,R1 ; Yes: maximum is related to screen size 30$: MOVZBW R1,STM_MSZ ; Store statement maximum size DIVB2 #8,R6 ; Calculate number of leader tab stops BEQL 35$ ; Branch if no tab stops in leader DECB R6 ; Want one fewer tab than in stm leader MOVC5 #0,(R8),#9,R6,CTN_LDR+8 ; Move correct number of tabs to leader 35$: ADDB3 #8,R6,R2 ; Calculate actual leader size MOVZBL R2,CTN_ASZ ; and store it for later MULB2 #8,R6 ; Calculate effective leader size ADDB2 #16,R6 ; accounting for continuation constant MOVB #72,R1 ; Store maximum number of bytes/line SUBB3 R2,R6,R0 ; Difference between effective & actual CMPB #8,R0 ; Is difference one tab stop or more BGTR 40$ ; No: maximum is source line maximum SUBB3 R0,#80,R1 ; Yes: maximum is related to screen size 40$: MOVZBW R1,CTN_MSZ ; Store continuation maximum size SUBW3 R6,#80,CTN_MFSZ ; Also compute maximum Fortran size ; when part of continued line RSB ; ; 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::PUSHL R11 ; Save R11 to free up register MOVZWL STM_MSZ,R11 ; Load maximum size of source line and ; its leader (fits on one screen line) 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 R11,OUT_RAB+RAB$W_RSZ ; Set output buffer size to max size $PUT RAB=OUT_RAB ; Put partial record to output file ON_ERROR 20$ ; On error, branch to error handler MOVW #72,OUT_RAB+RAB$W_RSZ ; Reset output buffer size to default ADDL2 R11,R7 ; Calculate end of record address SUBL2 #6,R7 ; Determine default leader start addr BRB 15$ ; Prepare to write next record 10$: $PUT RAB=OUT_RAB ; Put partial record to output file ON_ERROR 20$ ; On error, branch to error handler ADDL2 #66,R7 ; Calc remaining record start address 15$: 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 return code to success 20$: POPL R11 ; Restore R11 RSB ; Return to write remaining record ; ; Advance to Character ; ; Inputs: ; ; R6 - ASCII code of alternate search byte; otherwise clear ; R7 - Address 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 ; Bit 20: cleared if alternate byte not 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 "()" BISL2 #BIT20,R12 ; Yes: set alternate byte found flag MOVL R0,R2 ; Save number of bytes to eor MOVB #1,R0 ; Set return code 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 CMPB #^A"'",(R8) ; Is next byte another "'" BNEQ 10$ ; If no, we have end of string INCL R8 ; Have quote within quote BRB 15$ ; Continue search for end quote 35$: INCB R4 ; Have "("; increment counter BRB 10$ ; and continue search for ")" 40$: SOBGTR R4,10$ ; Have ")"; repeat on counter not zero BICL2 #BIT20,R12 ; Have last corresponding ")" MOVB #1,R0 ; Set return code 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 ; ; 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 #BIT19,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 PUSHL R1 ; Save address of second "'" on stack 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 POPL R1 ; Yes: have direct access I-O; pop stack BRB 70$ ; and retire with address of "r" 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,(SP)+,R8 ; Compute address after second "'" RSB ; Return 70$: MOVL R8,R7 ; Update R7 to address of "r" in (r'u) RSB ; ; 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=" ; 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 ; Bit 18: clear ; EQLLBL::MOVB #^A',',R6 ; Set alternate delimiter to "," PUSHL R7 ; Save the address held in R7 on stack 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 BBC #20,R12,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$: POPL R7 ; Restore original address from stack BICL2 #393216,R12 ; Clear both R12 flag bits RSB ; ; Special Continuation Line Processor ; ; Inputs: ; ; R7 - Address of first byte in current record ; R10 - Eor byte address ; R11 - Maximum size of statement and leader so that it will ; fit on one VT100 screen line (without wrap around) ; ; 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) ; (but not if default processing is needed on return) ; R10 - Eor address of remaining record (same as input) ; R11 - Maximum size of continuation and leader so that it will ; fit on one VT100 screen line (without wrap around) ; WRTSPC::MOVL R7,R9 ; Save record start address MOVL SPCADD,R7 ; Get start address to be used by Advchr BICL2 #BIT21,R12 ; Clear continuation pointer moved flag MOVB #^A',',R6 ; Place comma as alternate for Advchr SUBL3 R9,R7,R0 ; Compute number of bytes from start CMPW R11,R0 ; Is it greater than max size allowed BGTR 5$ ; No: find 1st continuation break point BRW 30$ ; Yes: must use default processor 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 R11,R0 ; Is it greater than max size allowed BLSS 20$ ; Yes: write to previous comma BISL2 #BIT21,R12 ; Set continuation pointer moved flag MOVL R8,R7 ; Store address after ")" or "," BBS #20,R12,5$ ; If "," found, look for more MOVW R0,R8 ; Store length of remaining Fortran BRW 40$ ; Found ")"; return to write this record 10$: SUBL3 R7,R10,R2 ; Compute number bytes remaining CMPW CTN_MFSZ,R2 ; Will remaining Fortran fit on one line BGEQ 25$ ; Yes: write first part of record BRW 30$ ; No: must use default continuation ; processor for this record 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 in output RAB $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 character MOVL R8,R7 ; Save address of byte after comma MOVL R0,R8 ; Save length of remaining Fortran SUBL3 CTN_ASZ,R1,R9 ; Compute start address for ctn leader MOVC3 CTN_ASZ,CTN_LDR,(R9) ; Move the continuation leader to addr MOVL R9,OUT_RAB+RAB$L_RBF ; and store as new record start address CMPW CTN_MFSZ,R8 ; Is remaining Fortran too long BGEQ 35$ ; No: we are done with continuations MOVZWL CTN_MSZ,R11 ; Maximum number of bytes in source and ; leader for continuation screen line BBC #20,R12,30$ ; If "," not found, use default processr BBSC #21,R12,28$ ; If pointer has moved, do again ; Comma found and pointer not moving ; Will line and comma be written next? SUBL3 R9,R7,R0 ; No. of bytes from beginning to comma CMPW R11,R0 ; Is it greater than what can be written BLSS 30$ ; If yes, use default processor 28$: ADDL3 CTN_ASZ,R9,R7 ; Resume search just past leader BRW 5$ ; Look for next continuation break point ; Use default continuation processor 30$: MOVL R9,R7 ; Reset R7 to next output start address MOVB #1,R1 ; Indicate default processing required RSB 35$: ADDW2 CTN_ASZ,R8 ; Compute actual continuation rec length 40$: MOVL R9,R7 ; Restore last record output start addr MOVZWL R8,R9 ; Save record length MOVB #1,R0 ; Set return code to success 50$: CLRB R1 ; Indicate default processing not nec. RSB ; ; Packed Statement with Label Analyzer ; ; Inputs: ; ; R1 - Address of non-digit following suspected label digit string ; R7 - Address of first digit in label ; R10 - Address of eor ; ; Outputs: ; ; R0 - Error code: low bit clear if no label found ; R1-R6 - Scratch ; R7 - Same as input ; R8 - Scratch ; R10 - Same as input ; ; This routine checks packed statements - i.e. Fortran with no spaces. ; PCKSTM::SUBL3 R1,R10,R4 ; Compute length to eor SPANC R4,(R1),CHRTAB,#4 ; Find next non-blank character BEQL 80$ ; If none, digit string is label CMPW R4,R0 ; Is space between label and non-digit BNEQ 50$ ; Yes: check for array "(" CMPB #^A',',(R1) ; No space follows digit; have we a "," BEQL 80$ ; Yes: packed statement w/ label - done ; ; Just handled cases like "TYPE20,I" and "DO20,J=M,N". The only ; remaining legal possibilities that I know of are DO statements ; like "DO20I=M,N" or "DO20WHILE(X) - neither of which deserve to be ; RESEQUENCE'd! Try anyhow. ; CMPB #2,FTNTYP ; Have we a packed DO statement BNEQ 70$ ; No: statement has no label BSBW PCKDO ; Analyze packed DO - DO WHILE construct ON_ERROR 70$ ; Statement has no label BRB 60$ ; Confirm DO WHILE not DO1WHILE(X)=1 ; ; Check for case like "TYPE20(I)=3" or "DO200WHILE(X)=1" ; 50$: CMPB #^A'(',(R1) ; Have we an array reference BEQL 70$ ; Yes: must be assignment statement 60$: CMPB #^A'=',(R1) ; Have we assignment statement "=" BNEQ 80$ ; No: have packed statement 70$: CLRB R0 ; Indicate no label in statement RSB 80$: MOVB #1,R0 ; Packed statement has label RSB ; ; Packed Statement with Label Analyzer - DO statement ; ; Inputs: ; ; R1 - Address of non-digit following suspected label ; R4 - Number of bytes to eor from address in R1 ; R7 - Address of first digit in label ; R10 - Address of eor ; ; Outputs: ; ; R0 - Error code: low bit clear if no label found ; R1 - If DO WHILE, address of non-blank after ")", if any, otherwise, ; address of first digit in label string. ; R2-R6 - Scratch ; R7 - Same as input ; R8 - Scratch ; R10 - Same as input ; ; Checks statements of form "DO20I=5" and "DO20WHILE(X)=5". ; PCKDO:: BICL2 #BIT22,R12 ; Clear DO WHILE statement bit MOVL R1,R8 ; Save address of non-digit after label LOCC #^A'(',R4,(R8) ; Find "(" of DO WHILE construct BEQL 5$ ; If none, look for DO "=" instead BISL2 #BIT22,R12 ; Set DO WHILE statement bit SUBL3 R8,R1,R4 ; Compute length to "(" from non-digit 5$: LOCC #^A'=',R4,(R8) ; Search for "=" part of DO statement BNEQ 10$ ; If found, we may have simple DO BBS #22,R12,50$ ; No "="; if "(", may have DO WHILE BRB 90$ ; Have neither DO nor DO WHILE 10$: BICL2 #BIT22,R12 ; Clear DO WHILE statement bit SUBL3 R1,R10,R4 ; Compute length to eor MOVL R1,R8 ; Save address of DO "=" LOCC #^A"'",R4,(R8) ; Do we have character constant quote BNEQ 90$ ; Yes: Obviously not a DO statement 20$: LOCC #^A'(',R4,(R8) ; Find array "(" if any BNEQ 40$ ; Found "("; see if prior "," MOVL R10,R1 ; Comma search will be to eor 40$: SUBL2 R8,R1 ; Compute length for search LOCC #^A',',R1,(R8) ; Search for required DO "," BNEQ 80$ ; Have very "packed" DO stmt. CMPL R1,R10 ; Are we at eor (without ",") BEQL 90$ ; No: do not have a DO statement ; ; Handling case like "DO200I=A(1,3),B" or "DO200WHILE(X)". In either ; case, get passed ")". ; 50$: CLRB R6 ; Clear alternate delimiter MOVL R7,SPCADD ; Save label start pointer temporarily ADDL3 #1,R1,R7 ; Address of one after "(" BSBW ADVCHR ; Find corresponding ")" ON_ERROR 90$ ; If none, just assume no label MOVL SPCADD,R7 ; Restore label start pointer CLRL SPCADD ; Reset continue address buffer clear SUBL3 R8,R10,R4 ; Compute length to eor BBC #22,R12,20$ ; Resume search for "DO" comma ; ; After ")" of probable "DO200WHILE(X)" statement; confirm we do not ; have assignment statement - "DO200WHILE(1)=N". ; SPANC R4,(R8),CHRTAB,#4 ; Find next non-blank after ")" BNEQ 85$ ; Non-blank must not be assignment "=" 80$: MOVL R7,R1 ; Statement has label; return start addr 85$: MOVB #1,R0 ; Set error code success RSB 90$: CLRB R0 ; Statement has no label RSB .END RESFOR