ASMB,R
      HED ISAU1  UTILITIES TO DO FILE CALLS 
      NAM ISAU1,7 92413-16016A  REV.1644
      SPC 1 
************************************************* 
* 
* 
*     SOURCE        92413-18016  REV.1644 
*     RELOC         92413-16016  REV.1644 
* 
* 
*     BASICALLY, THIS IS A VERSION OF LARRY POMATTO'S NSW003 LIBRARY
*     WITH A FEW MODIFICATIONS. 
* 
**************************************************
      SPC 3 
* 
*     DEFINE ENTRY POINTS 
* 
      ENT A1DCB 
      ENT GT0UT 
      ENT PR1NT,PRT1
      ENT %CLU,A2DCB
      ENT F1LCK,PR0MT 
      ENT XOPEN,XCRET 
      ENT %PRSB,%PRSA,XCLOS,%NLU
      ENT %PRS1,%PRS2,%PRS3,%PRS4,%PRS5 
      ENT %PR21,%PR31,%PR41,%PR51,A3DCB 
      ENT XSTK,P.TR.,XPUSH,N0PRT
      ENT A3DB3 
      ENT CLSF1 
      SPC 2 
* 
*     DEFINE EXTERNALS
* 
      EXT WRITF,EXEC,CLOSE
      EXT CREAT,OPEN,READF,CNUMD
      EXT .ENTR 
      EXT PARSE,IFBRK 
      SPC 2 
* 
*     DEFINE A AND B REG
* 
A     EQU 0 
B     EQU 1 
      SUP 
      SKP 
* 
N0PRT NOP 
%NLU NOP
UP377 OCT 177400
* 
*     SUBROUTINE TO CLOSE AND PURGE ALL FILES 
*     CURRENTLY OPEN TO PROGRAM INCASE OF ERROR 
*     JSB JSB GT0UT 
* 
*     NOTE: 
*     I AM CHEATING...GEORGE HAS INDICATED THAT IT
*     IS POSSIBLE TO PURGE A FILE IF ALL I HAVE IS
*     A DCB. THE WAY THIS IS DONE IS AS FOLLOWS 
*     SET EXTENT POINTER TO 0...MAIN...GET RID OF SEMENTS 
*     GET THE # OF SECTORS IN FILE AND DIVIDE BY 2
*     TO GIVE YOU THE # OF BLOCKS.
*     DO A CLOSE AND TRUNCATE ALL BLOCKS, WHICH MAKES 
*     THE FILE MANAGER ROUTINES DO EFFECTLY A PURGE.
*     THUS WE HAVE DONE A PURGE WITHOUT THE NAME
*     THIS IS DEPENDENT ON DCB MEANING...IF IT CHANGES
*     BYE.... 
* 
* 
GT0UT NOP 
      LDA D14       GO PR1NT ABORT
      LDB DFABM      MESSAGE TO THE 
      JSB LOUT        OUTPUT LIST FILE
      LDA A1DCB+9   SEE IF FILE OPEN
      CPA 1717B     THATS OUR ID SEGMENT ADDRESS
      RSS           YES 
      JMP GTOT1     NO
      CLA           CLEAR OUT EXTENTS 
      LDB A1DCB+2   SEE IF TYPE 0 
      SZB,RSS 
      JMP CLSAB     IT IS, DON'T PURGE FILE 
      STA A1DCB+15
      LDA A1DCB+5   GET # OF SECTORS
      CLE,ERA       CONVERT TO BLOCKS 
CLSAB STA BLKS      AND SAVE IT 
      JSB XCLOS     PURGE THE FILE!!! 
      DEF *+4 
      DEF A1DCB 
      DEF FERR
      DEF BLKS
GTOT1 JSB XCLOS     CLOSE LIST FILE 
      DEF *+3 
      DEF A2DCB 
      DEF ZERO
      JSB XCLOS     CLOSE INPUT FILE
      DEF *+3 
      DEF A3DCB 
      DEF FERR
* 
*     AT THIS POINT ALL FILES ARE CLOSED OR PURGED
*     TELL WORLD WE ARE DONE
* 
      JSB EXEC
      DEF *+3 
      DEF B6
      DEF ZERO
      DEF B3
* 
B1    OCT 1 
B2    OCT 2 
B6    OCT 6 
M1    DEC -1
BLKS  NOP 
DFABM DEF *+1 
      ASC 7,ISAGN ABORTED 
      SKP 
* 
*     SUBROUTINE TO WRITE ON INTERACTIVE DEVICE 
*     AND LIST FILE 
*     CALLING SEQUENCE
*     JSB PR1NT 
*     A REG= SIO LENGTH WORD
*     B REG= ADDRESS OF MESSAGE 
* 
PR1NT NOP 
      DST ABREG     SAVE A AND B REG FOR LOUT 
      JSB BYTCN     CONVERT SIO TO USUAL
      INB           SKIP OVER LEADING SPACE 
      ADA M1        CUT COUNT NOT INCLUDE SPACE 
      STA PRNTA     SAVE LENGTH 
      STB PRNTB     SAVE ADDRESS
      LDA N0PRT     DO WE PR1NT THIS MESSAGE? 
      SZA 
      JMP PRNT1     NO
      JSB WRITF     OUTPUT MESSAGE
      DEF *+5 
      DEF A3DCB      TO THE INPUT DEVICE
      DEF FERR
PRNTB NOP 
      DEF PRNTA     LENGTH
      LDA FERR
      STA PRNTB 
* 
PRNT1 DLD ABREG     GET LENGTH AGAIN
JSB   JSB LOUT      WRITE TO FILE 
      LDA PRNTB 
      SZA 
      STA FERR
      JMP PR1NT,I   AND RETURN
      SPC 1 
PRNTA NOP 
ABREG BSS 2 
PRT1  NOP 
      STA TEMP
      CLA 
      STA JSB 
      LDA TEMP
      JSB PR1NT 
      LDA .JSB
      STA JSB 
      JMP PRT1,I
* 
.JSB  JSB LOUT
TEMP  NOP 
      SKP 
      SPC 3 
* 
*     SUBROUTINE TO CONVERT SIO LENGTH TO POSITIVE WORDS
*     CALLING SEQUENCE
*     JSB BYTCN 
*     B REG UNCHANGED 
* 
BYTCN NOP 
      STA BYTCA     SAVE LENGTH FOR CHECKING LATTER 
      SSA           WORDS OR CHARACTERS?
      JMP *+3       WORDS 
      CMA,INA       CONVERT CHAR TO WORDS 
      ARS           DIVIDE BY 2+1 
      STA BYTCC     SAVE IN DOWN COUNTER
      LDA LSBFA     GET ADDRESS WHERE TO PUT OUTPUT 
      STA BYTCD     SAVE FOR MOVE 
BYTC1 LDA B,I       MOVE MESSAGE
      STA BYTCD,I 
      ISZ BYTCD 
      INB 
      ISZ BYTCC     DONE? 
      JMP BYTC1     NO
      LDB BYTCA     WORDS OR CHARACTERS?
      SSB 
      JMP BYTC2     WORDS 
      CLE,ERB       CONVERT CHARACTERS TO WORDS 
      SEZ,RSS       ODD # OF CHAR?
      JMP BYTC3     NO
      STB BYTCC     YES...SAVE COUNT FOR LATTER 
      ISZ BYTCC     INCLUDE ODD CHAR
      ADB LSBFA     GET TO END
      LDA B,I 
      AND UP377     MASK OFF LOWER HALF 
      IOR B40       OR IN A SPACE 
      STA B,I       SAVE IT 
      LDB BYTCC     GET LENGTH AGAIN
BYTC3 RSS           SKIP OVER COMPLEMENTING 
BYTC2 CMB,INB       CHANGE NEG WORDS TO + WORDS 
      LDA B         GET LENGTH IN A REG 
      LDB OTBFA     GET ADDRESS OF BUFFER...INCLUDING SPACE 
      INA           INCLUDE SPACE IN COUNT
      JMP BYTCN,I   AND RETURN
      SPC 1 
BYTCA NOP 
BYTCC NOP 
BYTCD NOP 
OTBFA DEF OTBUF 
LSBFA DEF OTBUF+1 
B40   OCT 40
      SKP 
* 
*     SBROUTINE TO WRITE ONTO A LIST FILE 
*     CALLING SEQUENCE
*     JSB LOUT
*     AREG = SIO LENGTH 
*     B REG= BUFFER ADDRESS 
* 
LOUT  NOP 
      JSB BYTCN     CONVERT LENGTH
      STA LOUTA 
      STB LSBF      SAVE BUFFER ADDRESS FOR OUTPUTING 
      JSB WRITF     WRITE THE RECORD
      DEF *+5 
LDCBA DEF A2DCB 
      DEF FERR
LSBF  NOP           LIST BUFFER ADDRESS HERE
      DEF LOUTA 
* 
* 
      JMP LOUT,I    AND RETURN
      SPC 1 
LOUTA NOP 
      SKP 
* 
*     SUBROUTINE TO OPEN A FILE 
*     CALLING SEQUENCE
*     JSB XOPEN     FILE OPEN 
*     DEF *+3 
*     DEF DCB ADDRESS 
*     DEF SUBFUNCTION FOR READ OR WRITE IN CASE A TYPE 0 FILE 
* 
*     ASSUMES THAT %PRS2+1=FILE NAME
*                  %PRS3+1=SECURITY CODE
*                  %PRS4+1=LU 
* 
ODCBA NOP 
SUBF  NOP 
XOPEN NOP 
      JSB .ENTR 
      DEF ODCBA 
      LDA ODCBA    GGET DCB ADDRESSPE 
      LDB SUBF,I    GET SUBFUNCTION 
      JSB TYP0      CHECK IF TYPE IS 0
      JMP XOPEN,I   YES EXIT
      JSB OPEN      TRY TO OPEN FILE
      DEF *+7 
      DEF ODCBA,I 
      DEF FERR
      DEF %PRS2+1   NAME
      DEF ZERO      OPEN OPTION 
      DEF %PRS3+1   SECURTIY CODE 
      DEF %PRS4+1   LOGICAL UNIT
      LDB ODCBA     GET DCB ADDRESS 
      CPB INDEF     IS IT INPUT FILE
      ISZ N0PRT      SET NON-ZERO(NO PR1NT) 
      JMP XOPEN,I   RETURN
      SKP 
* 
*     SUBROUTINE TO CREATE A DUMMY TYPE 0 FILE
*     CALLING SEQUENCE
*     LDA DCB ADDRESS 
*     LDB SUBFUNCTION 
*     JSB TYP0
*     RETURN HERE(P+1) IF IT IS TYPE 0
*     RETURN HERE(P+2) IF IT IS NOT TYPE 0
* 
* 
TYP0  NOP 
      STA T0DCB 
      LDA %PRS2 
      CMA,INA,SZA   IF NULL OR NUMERIC
      INA,SZA,RSS    THEN OPEN A DUMMY TYPE 0 
      JMP TYP1
      ISZ TYP0      OTHERWISE TAKE NOT
      JMP TYP0,I     TYPE 0 EXIT
TYP1  LDA %PRS2+1  GET LU 
      SZA,RSS      IF NOT DEFINED 
      INA           DEFINE AS LU = 1
      STA %PRS2+1 
      CLA 
      JSB SET      SET DIRECTORY
      JSB SET       ADDRESS TO ZERO 
      JSB SET      ALSO SET TYPE TO 0 
      LDA %PRS2+1  GET LOGICAL UNIT 
      IOR B        MERGE IN SUBFUNCTION 
      JSB SET       AND SET IN DCB
      JSB EXEC     GET DRIVER TYPE
      DEF *+4 
      DEF D13 
      DEF %PRS2+1 
      DEF EQT5
      LDA EQT5     GET TYPE 
      ALF,ALF       ROTATE TO LOW A 
      AND B77        AND MASK 
      STA EQT5     SAVE 
      LDB B100     GET EOF CONTROL SUBFUNCTION
      ADA MD17     IF TYPE > 16 
      SSA,RSS 
      JMP SEOF      SET EOF CODE
      LDB B1000 
      LDA EQT5
      CPA D5        DVR05?? 
      CLA           YES, SET
      STA EQT5        TO TYPE 0 DEVICE! 
      CPA B2       IS DRIVER A PUNCH
      JMP SEOF     GO SET LEADER GENERATION 
      CLB 
      SZA,RSS       IF TYPE=0 DON'T DO PAGE EJECT 
      JMP SEOF
      LDB B1100    LINE SPACE OPTION
SEOF  LDA %PRS2+1  GET LU 
      IOR B        MERGE EOF CONTROL SUBFUNCTION
      JSB SET      SET IN DCB 
      CLA 
      JSB SET      SET NO SPACEING LEGAL
      LDA B1001    SET READ&WRITE LEGAL 
      JSB SET       AND SECURITY CODES AGREE
      JSB SET        AND UPDATE MODEES AGREE
      LDA 1717B    GET MY ID ADDRESS
      ISZ T0DCB    INCREMENT TO WORD 9
      JSB SET      SET OPEN FLAG
      LDA T0DCB 
      ADA B3
      STA T0DCB    SET TO WORD 13 
      CLA SET IN CORE BUFFER FLAG 
      JSB SET       TO ZERO 
      INA 
      JSB SET      SET RECORD COUNT 
      LDA EQT5     GET TYPE CODE
      LDB T0DCB    GET DCB ADDRESS
      ADB MD15     RESET TO WORD 1
      CPB INDEF    IS IT THE INPUT DEVICE 
      STA N0PRT    SAVE TO INDICATE PR1NT / NO PR1NT
      ADB B4        GET TO CONTROL FUNCTION LOCATION
      LDB B,I       GET CONTROL WORD
      STB SET       SAVE IN TEMP LOCATION 
      JSB EXEC      DO A PAGE EJECT 
      DEF *+4 
      DEF B3
      DEF SET       TEMP WHERE FUNCTION CODE LOCATED
      DEF MD17      FORCE A PAGE EJECT
      CLA          SPECIFY TYPE 0 OPEN
      STA FERR      CLEAR ERROR CODE
      JMP TYP0,I
* 
* 
SET   NOP 
      STA T0DCB,I  SET IN DCB 
      ISZ T0DCB    INCREMENT TO NEXT WORD 
      JMP SET,I 
* 
* 
INDEF DEF A3DCB 
T0DCB NOP 
EQT5  NOP 
MD17  DEC -17 
MD15  DEC -15 
B4    OCT 4 
B100  OCT 100 
B1000 OCT 1000
B1001 OCT 100001
B1100 OCT 1100
      SPC 2 
D5    DEC 5 
D13   DEC 13
B77   OCT 77
B3    OCT 3 
B400  OCT 400 
      SKP 
* 
*     SUBROUTINE TO CREATE A FILE 
*     CALLING SEQUENCE
*     JSB XCRET 
*     DEF *+5 
*     DEF DCB ADDRESS 
*     DEF SIZE
*     DEF TYPE
*     DEF SUBFUNCTION FOR READ/WRITE IN CASE A TYPE 0 FILE
* 
*     ASSUMES THAT  %PRS2+1=FILE NAME 
*                   %PRS3+1=SECURITY CODE 
*                   %PRS4+1=LU
* 
      SPC 1 
CDCBA NOP 
CSIZ  NOP 
CTYP  NOP 
CSBUF NOP 
XCRET NOP 
      JSB .ENTR 
      DEF CDCBA 
      JSB XOPEN     GO TRY TO OPEN THE FILE 
      DEF *+3 
      DEF CDCBA,I 
      DEF CSBUF,I 
      SZA,RSS       TYPE 0? 
      JMP XCRET,I   YES...RETURN
      JSB CLOSE     IF NOT CLOSE FILE IF OPEN 
      DEF *+3 
      DEF CDCBA,I 
      DEF FERR
      JSB CREAT     TRY CREATING THE FILE 
      DEF *+8 
      DEF CDCBA,I 
      DEF FERR
      DEF %PRS2+1 
      DEF CSIZ,I
      DEF CTYP,I
      DEF %PRS3+1 
      DEF %PRS4+1 
      JMP XCRET,I 
      SKP 
* 
*      SUBROUTINE TO CLOSE A FILE 
*      USED TO DETERMINE IF CLOSING A DUMMY TYPE 0
*      CALLING SEQUENCE 
*      JSB XCLOS
*      DEF *+3
*      DEF DCB ADDRESS
*      DEF TRUNCATE OPTION (DEFAULT IS ZERO)
* 
* 
CLDCB NOP 
COPTN DEF ZERO
XCLOS NOP 
      JSB .ENTR 
      DEF CLDCB 
      LDA CLDCB,I  GET DIRECTORY DISC ADDRESS 
      SZA,RSS      IF ZERO
      JMP FCLS1     THEN DUMMY DCB
      JSB CLOSE    ELSE DO STANDARD CLOSE 
      DEF *+4 
      DEF CLDCB,I 
      DEF FERR
      DEF COPTN,I 
FCLS1 LDA DFZER    RESET THE OPTION WORD
      STA COPTN     IN CASE NOT SUPPLIED NEXT TIME
      JMP XCLOS,I 
* 
* 
ZERO  OCT 0 
* 
      SKP 
* 
*     SUBROUTINE TO CLOSE THE ABSOLUTE OUTPUT FILE
* 
*     CALLING SEQUENCE
*     JSB CLSF1 
*     NORMAL RETURN 
* 
*     THIS ROUTINE WILL DELETE UNUSED FILE AREA 
* 
CLSF1 NOP 
      LDA A1DCB+5    GET #SEC 
      MPY A1DCB+15  MULT. BY THE CURRENT EXTENT NO. 
      STA TMP 
      LDA A1DCB+3   TRK 
      CMA,INA 
      ADA A1DCB+10  CTRK - TRK
      MPY A1DCB+8   (CTRK - TRK) * #SEC/TR
      LDB A1DCB+4 
      CMB,INB 
      ADA B         (CTRK - TRK) * #S/TR - SEC
      ADA A1DCB+11  (CTRK - TRK) * #S/TR - SEC + CSEC 
      ADA TMP       ADD IN NUMBER OF EXTENTS
      ARS           CONVERT TO NUMBER OF BLOCKS 
      LDB A1DCB+5   GET NUMBER OF SECS
      CLE,ERB       CONVERT TO BLOCKS 
      CMA,INA       SET CURRENT BLOCK NEG 
      ADB A         # OF BLKS - CURRENT BLK 
      CCA 
      ADB A         ONE MORE FOR GOOD MEASURE 
      STB TMP 
      JSB XCLOS 
      DEF *+3 
      DEF A1DCB 
      DEF TMP 
      JMP CLSF1,I 
* 
TMP   NOP 
      SKP 
* 
*     SUBROUTINE TO PR1NT COMMAND AND ACCEPT
*     INPUT.
*     CALLING SEQUENCE
*     JSB PRMT
*     DEF *+6 
*     DEF PR1NT MESSAGE BUFFER
*     DEF LENGTH (IN SIO FORMAT)
*     DEF REPLY ADDRESS 
*     DEF LENGTH (IN + # OF CHARACTERS) 
*     DEF PARSE BUFFER
* 
*     A REG= + NUMBER OF CHARACTERS 
* 
PMEMB NOP 
PMEML NOP 
PRADD NOP 
PRLEN NOP 
PPARS NOP 
PR0MT  NOP
      JSB .ENTR 
      DEF PMEMB 
PRMT1 LDB PMEMB     GET BUFFER ADDRESS
      LDA PMEML,I   GET LENGTH
      JSB PR1NT     PR1NT QUESTION
* 
      LDA FERR
      STA AWAY
      LDA PRLEN,I   GET LENGTH
      INA           CONVERT TO WORDS
      CLE,ERA 
      STA PRMTA     SAVE LENGTH 
      CMA,INA       CONVERT TO NEGATIVE WORD COUNT
      STA PRMTB     SAVE IN TEMP
      LDB PRADD     GET ADDRESS WHERE TO SPACE FILL 
      LDA C4040     SPACE WORD
      STA B,I 
      INB 
      ISZ PRMTB     DONE? 
      JMP *-3       NO
      JSB READF      GO GET INPUT 
      DEF *+6 
      DEF A3DCB     FROM INPUT DEVICE 
      DEF FERR
      DEF PRADD,I 
      DEF PRMTA 
      DEF PRMTB 
* 
      LDA AWAY
      SZA 
      STA FERR
      LDA FERR
      STA AWAY
* 
      JSB BRKCK     SEE IF WE WANT OUT
      LDA PRMTB     GET LENGTH FOR PR1NT ON FILE
      SSA,RSS       IS IT A END OF FILE 
      JMP PRMT2     NO
      LDA TR        YES GO SIMIULATE A TR 
      STA PRADD,I    COMMAND TO POP 
      LDA PRADD       THE STACK 
      LDB B2
      JMP PRMT3 
PRMT2 CLE,ELA       CONVERT TO CHARACTERS 
      STA PRMTB 
      LDB PRADD     GET INPUT 
      JSB LOUT      WRITE IT ONTO OUTPUT FILE 
* 
      LDA AWAY
      SZA 
      STA FERR
* 
      LDA PRADD,I   SEE IF THEY WANT OUT? 
      CPA !!
      JSB GT0UT     YES...GET OUT 
      JSB PARSE 
      DEF *+4 
      DEF PRADD,I 
      DEF PRMTB 
      DEF PPARS,I 
      LDA PPARS        GET FIRST 2 CHARS. 
      INA 
      LDA A,I 
      CPA TR       TRANSFER COMMAND?
      RSS 
      JMP PRMT4    NO - GO EXIT 
      LDA PRADD     GET BUFFER ADDRESS
      LDB PRMTB     GET LENGTH
PRMT3 JSB TRCHK    GO DO TR THING 
      JMP PRMT1    GO RETRY COMMAND 
PRMT4 LDA PRMTB     GET ACTUAL REPLY LENTH
      JMP PR0MT,I    AND RETURN 
      SPC 1 
C4040 ASC 1,
!!    ASC 1,!!
TR    ASC 1,TR
AWAY  NOP 
PRMTA NOP 
PRMTB NOP 
      SKP 
* 
*     SUBROUTINE TO DETERMIN IF STACK IS TO 
*     BE XPUSHED OR POPED 
* 
*     IF XPUSHED, IT CLOSES THE CURRENT FILE, 
*     SAVES RC,AND OPENS NEW FILE 
* 
*     IF POPED, IT CLOSES THE CURRENT FILE, 
*     OPEN STHE PREVIOUS FILE, AND POSITIONS
*     IT TO THE PROPER RECORD 
* 
      SPC 1 
TRCHK NOP 
      STB PRMTB     SAVE LENGTH 
      STA TRCH1     SET BUFF ADDR.
      JSB PARSE     GO REPARSE
      DEF *+4 
TRCH1 NOP 
      DEF PRMTB 
      DEF %PRSB 
      LDA %PRS2     GET FILE TYPE 
      SZA           IF NOT NULL 
      JMP TR3       GO TO XPUSH 
* 
TR1   JSB XCLOS     CLOSE THE CURRENT FILE
      DEF *+3 
      DEF A3DCB 
DFZER DEF ZERO
TR4   JSB POP       GO POP STACK
      SEZ 
      JSB GT0UT     ERROR, NO MORE ENTRIES
      STA RC        SAVE RECORD COUNT 
      JSB XOPEN     OPEN PREVIOUS FILE
      DEF *+3 
      DEF A3DCB 
      DEF B400
      JSB F1LCK 
      SEZ 
      JMP TRCHK,I 
      LDA A3DCB+2   GET TYPE
      SZA,RSS       IF TYPE 0 
      JMP TRCHK,I   EXIT
      LDA RC        GET RECORD COUNT
      CMA,INA       SET NEGATIVE AND
      STA COUNT     SAVE
TR2   ISZ COUNT     ARE WE THERE YET? 
      RSS 
      JMP TRCHK,I   YES...GET OUT 
      JSB READF     READ A RECORD 
      DEF *+6 
      DEF A3DCB 
      DEF FERR
      DEF PRADD,I 
      DEF ZERO
      DEF RL
* 
      JSB F1LCK 
      SEZ 
      JSB GT0UT 
* 
      LDA RL
      SSA           IF EOF...POP STACK
      JMP TR1 
      JMP TR2       GET NEXT RECORD 
      SKP 
* 
*     PLACE NEW INPUT FILE ON STACK AND XPUSH 
* 
TR3   LDA A3DCB+14  GET REC NUMBER OF NEXT RECORD 
      STA RC        SAVE AS CURRENT RECORD #
      JSB XCLOS     GO CLOSE THE FILE 
      DEF *+3 
      DEF A3DCB 
      DEF ZERO
      LDA RC        GET RECORD COUNT
      JSB XPUSH      GO XPUSH STACK 
      SEZ 
      JSB GT0UT     ERROR STACK OVERFLOW
      JSB XOPEN     GO OPEN NEW FILE
      DEF *+3 
      DEF A3DCB 
      DEF B400
      JSB F1LCK     ERROR?
      SEZ 
      JMP TR4       YES, POP STACK
      JMP TRCHK,I   NO, RETURN
* 
* 
COUNT NOP 
RC    NOP 
RL    NOP 
      SKP 
* 
*     SUBROUTINE TO XPUSH AND POP A STACK 
*     STACK DEFINITION
*     WORD 4=       RECORD COUNT FOR NEXT RECORD TO READ
*     WORD 3=       0 ELSE CH5&CH6
*     WORD 2=       0 ELSE CH3&CH4
*     WORD 1=       LU ELSE CH1&CH2 
*     WORD 0=       TYPE...1=TYPE 0, 2=REGULAR
* 
*     XPUSH-PLACES FILE NAME AND TYPE ON STACK
*     LEAVES POINTER AT RECORD COUNT (WORD 4) 
*     ASSUMES %PRS2 CONTAINS INFO NEEDED
*     CALLING SEQUNCE 
*     LDA RC        OF CURRENT FILE 
*     JSB XPUSH 
*     ERROR RETURN  STACK OVERFLOW
*     NORMAL RETURN 
* 
      SPC 1 
XPUSH  NOP
      STA P.TR.,I    SAVE CURRENT RECORD COUNT
      ISZ P.TR.      INCREMENT TO BEGINNING OF NEXT ENTRY 
      LDA ENDST     GET END OF STACK ADDRESS
      CPA P.TR.      IF = 
      CCE,RSS 
      JMP *+2 
      JMP XPUSH,I    THEN OVERFLOW
      DLD %PRS2     SAVE TYPE 
      DST P.TR.,I 
      ISZ P.TR. 
      ISZ P.TR. 
      DLD %PRS2+2   STORE CHARS 3-6 
      DST P.TR.,I 
      ISZ P.TR. 
      ISZ P.TR. 
      CLE           SET FOR NORMAL RETURN 
      JMP XPUSH,I    AND RETURN 
      SKP 
* 
*     SUBROUTINE THAT MOVES THE POINTER TO PREVIOUS 
*     STACK ENTRY 
*     PLACES RECORD COUNT IN A REG
*     LEAVES POINTER AT REC. COUNT
* 
*     CALLING SEQUENCE
*     JSB POP 
*     ERROR RETURN
*     NORMAL RETURN 
*     A REG=REC. COUNT
* 
      SPC 1 
POP   NOP 
      LDA P.TR.      GET CURRENT POINTER
      ADA MD9       DECREMENT TO PREVIOUS ENTRY 
      LDB XSTK     GET STACK ADDRESS
      CMB,INB 
      ADB A         IF CURRENT LESS THAN
      SSB,RSS       START OF STACK
      JMP POP1
      CCE 
      JMP POP,I     NO MORE ENTRIES 
POP1  STA P.TR.      SET AS NEW POINTER 
      DLD P.TR.,I    GET OLD ENTRY
      DST %PRS2 
      ISZ P.TR.      INCREMENT TO WORDS 3 AND 4 
      ISZ P.TR. 
      DLD P.TR.,I 
      DST %PRS2+2 
      ISZ P.TR. 
      ISZ P.TR. 
      LDA P.TR.,I    GET RECORD COUNT 
      CLE           GET NORMAL RETURN 
      JMP POP,I     AND RETURN
      SPC 2 
XSTK DEF STACK
      BSS 1 
STACK BSS 25
ENDST DEF * 
P.TR. DEF STACK-1 
MD9   DEC -9
      SKP 
* 
*     FILE CHECK ROUTINE
*     CALLING SEQUENCE
*     JSB F1LCK 
*     NORMAL RETURN 
*     MUST SEND ERROR PRAM TO FERR
* 
F1LCK NOP 
      LDA FERR
      SSA,RSS       ANY ERRORS? 
      JMP FNOER 
      CMA,INA       SET POS FOR CONVERT 
      STA FERR
      JSB CNUMD     GET DEC ERROR CODE
      DEF *+3 
      DEF FERR
      DEF FERMA     ERROR MESSAGE ADDRESS 
      LDA FERMA+2   GET LAST TWO CHARACTERS 
      STA FERMA     SAVE FOR MESSAGE
      JSB EXEC      SEND ERROR TO USER
      DEF *+5 
      DEF B2
      DEF B1
      DEF FILEA 
      DEF D7  
      CCE,RSS 
FNOER CLE           GET NORMAL RETURN IF NO ERROR 
      JMP F1LCK,I   AND RETURN
      SPC 2 
FILEA ASC 5,FILE ERROR
      ASC 1, -
FERMA ASC 4,
FERR  NOP 
D14   DEC 14
D7    DEC 7 
      SKP 
* 
*     SUBROUTINE TO CHECK IF WE SHOULD ABORT
*     CALLING SEQUENCE
*     JSB BRKCK 
*     NORMAL RETURN 
*     NOTE: 
*     ROUTINE WILL NOT RETURN IF WE WANT OUT
* 
BRKCK NOP 
      JSB IFBRK 
      DEF *+1 
      SZA,RSS       WANT OUT? 
      JMP BRKCK,I   NO
      JSB GT0UT     YES 
      SKP 
* 
*     CONSTANTS TABLES WHAT NOT 
* 
      SPC 3 
.     EQU * 
%PRS1 BSS 4 
..    EQU * 
%PRS2 BSS 1 
%PR21 BSS 3 
%PRS3 BSS 1 
%PR31 BSS 3 
%PRS4 BSS 1 
%PR41 BSS 3 
%PRS5 BSS 1 
%PR51 BSS 3 
      SPC 1 
      ORG . 
%PRSB BSS 34
      ORG ..
%PRSA BSS 34
      SPC 3 
      SPC 2 
* 
*     I-O LU #
* 
%CLU EQU %PRS2+1
      SPC 1 
* 
*     PR1NT BUFFER
* 
OTBUF ASC 1,
      BSS 30
      SPC 4 
* 
*     DEFINE DCB'S
* 
A1DCB BSS 144 
A2DCB BSS 144 
A3DCB BSS 3 
A3DB3 BSS 141 
      SPC 2 
      END 
                                                                                                                                                                                                                                              