ASMB,R,N
*                                         <800822.0733> 
* 
* 
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
* 
*           NAME:   EDIT0 
*           SOURCE: 92074-18003 
*           RELOC:  PART OF 92074-12001 
*           PGMR:   J.D.J.
* 
* 
      NAM EDIT0,5,50 92074-1X003 REV.2034 800818
      ENT EDIT0 
* 
      ENT ED%PS     PRINT SOURCE FILE MESSAGE 
      ENT ED%FI     READ IN NEW SOURCE FILE 
      ENT ED%CS     CLOSE SOURCE FILE 
      ENT ED%CL     CLOSE LIST FILE 
      ENT ED%EF     SET UP FOR NEW SOURCE FILE
      ENT ED%NL     GET NEW LIST LU 
      ENT ED%LP     POST LIST FILE
      ENT ED%.M     M COMMNAD 
      ENT ED%.E     E COMMAND 
      ENT ED%EX     EXIT EDIT 
      ENT ED%WR     WR, WC COMMANDS 
      ENT ED%WF     WRITF CALL
      ENT ED%PF     TURN OFF BREAK MODE PROMPTS 
      ENT ED%PN     TURN ON    "    "     " 
      ENT ED%LK     LOCK A LU 
      ENT ED%TC     CLOSE COMMAND FILE
      ENT ED%RF     READ COMMAND FROM A FILE
      ENT ED%TR     TR COMMAND
      ENT ED%PC     PANIC TRACK REQUEST 
* 
      EXT .ENTR,.MVW,.MBT,.SBT,.LBT,.DFER 
      EXT SRTN
      EXT CREAT,OPENF,READF,WRITF,CLOSE,POST,LOCF 
      EXT EXEC
      EXT TNAMR,INAMR,$CVT1 
      EXT LURQ
      EXT LUTRU 
      EXT LOGLU 
      EXT ENAMR 
* 
DEXEC EQU EXEC
* 
*  SUBROUTINES IN MAIN
* 
      EXT ./B$      SET TOP OF SOURCE FILE
      EXT ./B1      ROLL TO TOP OF SOURCE FILE
      EXT ALCAT     ALLOCATE TRACKS 
      EXT ASCII       TEST FOR DIGIT
      EXT ASK       ASK BEFORE EXCUTION 
      EXT SETOK       SUPPRES ASKING IF SLASH 
      EXT CSTRP     STRIP COMMA, BLANKS 
      EXT DOUT      WRITE DEST. FILE TO DISK
      EXT ECH       GET NEXT COMMAND CHAR 
      EXT ECHL      GET CASE FOLDED COMMAND CHAR
      EXT ENDCK     CHECK THAT ALL CHAR USED FORM E BUFF
      EXT EOFLN     GET EOF LINE NUMBER 
      EXT ERCLN     CLEAN UP AFTER ERROR
      EXT EXCER     REPORT EXEC CALL ERROR
      EXT FLLER     COPY NEXT COMMAND FORM R BUFF TO E BUFF 
      EXT I/PSB     INPUT NEXT SOURCE LINE
      EXT KILL      KILL MULKTIPLE COMMANDS 
      EXT LCASE     FOLD CASE 
      EXT LST         LIST A LINE 
      EXT OUTCR     PUT CHARACTER IN OUTPUT BUFFER
      EXT OVTST     TOO MANY LINES OVERFLAW TEST
      EXT PBKE      PUT BACK LAST CHAR
      EXT PRINT 
      EXT PRTER     PRINTER ERROR FLAG
      EXT RALLT     RELASE ALL TRACKS 
      EXT RQST      REQUEST A TRACK 
      EXT SETSO     SET UP SOURCE 
      EXT SQ        SET UP SOURCE 
      EXT SETTY     SET INPUT TO TTY
      EXT SWPET     SWAP E AND T BUFFERS
      EXT TR        TRANSFER ONE LINE TO DEST 
      EXT TRN       TRANSFER N LINES
      EXT TYPEQ     GET EQT TYPE
      EXT UNDOD     SET UP FOR UNDO 
* 
**************
* 
*  JMP TO POINTS IN MAIN
* 
      EXT ERR       REPORT ERROR
      EXT ./A0      ABORT PROGRAM 
      EXT DISPL     REPORT ERROR
      EXT NODE1     GET NEXT COMMAND
      EXT RQST4     REURN FOR PANIC TRACK REQUEST 
* 
* DATA IN MAIN
* 
      EXT B^FNM     BYTE POINTER TO FILE NAME 
      EXT COMND     FIRST CHAR OF CURRETN COMMAND 
      EXT DBEND 
*     EXT DBFP1 
      EXT DBUF$ 
      EXT DBUFP 
      EXT DCBSZ 
      EXT DVRTY 
      EXT DVTY
      EXT EBUFF 
      EXT ECCNT 
      EXT ELNG
      EXT ERFLG 
      EXT EXFLG 
      EXT FCARW 
      EXT FNAME     SAVE AREA FOR FILE NAME 
      EXT FNSIZ       AND IT'S SIZE 
      EXT FSECW 
      EXT FTYPW 
*     EXT FSIZE 
*     EXT FTYPE 
      EXT IOPT
      EXT LASTL     NUMBER OF LAST LINE IN SOURCE FILE
      EXT LDCB      LIST DCB
      EXT LINEM 
      EXT LINES 
      EXT LNAM
      EXT LOPNF     LIST FILE OPEN FLAG 
      EXT LCLOF     CLOSE LIST FILE AT NODE 1 IF SET
      EXT CTFLG     CLOSE COMMAND FILE AT NODE 1 IF SET 
      EXT LSTFG     LIST AT TR FLAG 
      EXT LSTFG     LIST AT TR FLAG 
      EXT LSLUT 
      EXT LULOG 
      EXT LUCMD 
      EXT MODFG 
      EXT NLSFG 
      EXT NOPRN       NO PRINT FLAG 
      EXT NBUF0 
      EXT NAME
      EXT NEWLU     NEW LU FROM RQST
      EXT DSCTR     SECTOR PER TRACK FOR NEW TRACK
      EXT NWTRK     NEW TRACK FROM RQST 
*     EXT NOLSF     NO LS SUPPORT 
      EXT OCCNT 
      EXT OKFLG 
      EXT PASS1 
      EXT PANIC     PANIC FLAG - IF SET USE SOURCE TRACKS 
      EXT POFFG 
      EXT PBFLG 
      EXT QCSFG     CLOSE SOURCE FLAG 
      EXT QUFLG     QUITE FLAG
      EXT QSFLG 
      EXT RCLNG 
      EXT RCCNT     CURRENT COUNT IN RBUFF
      EXT PATCH     FLAG IF THER IS ANOTHER COMMAND IN R BUFF 
      EXT SBUF$ 
      EXT SBUFP 
      EXT SCFLG 
      EXT SLNG
      EXT SPFLG 
      EXT SVSLU 
      EXT SVSSC 
      EXT SVSTR 
      EXT SVSWC 
      EXT T#REC 
      EXT T#REM 
      EXT T#SEC 
*     EXT TBUFF 
      EXT TNAME 
      EXT TSFLG     TIME STAMP FLAG 
      EXT TYDCB 
      EXT TTYDV 
      EXT TRFLG 
      EXT ^LNAM 
      EXT ROFLG 
      EXT TYOPN     COMMAND FILE OPN FLAG 
      EXT TTYLU 
      EXT LSTLU 
      EXT ALTRK     ALCAT'S PRE-ALLOCATED TRACK 
      EXT ALCLU     ALCAT'S PRE-ALLOCATED LU
      EXT #TRAK     NUMBER OF TRACK IN SOURCE FILE
* 
A     EQU 0 
B     EQU 1 
* 
************************
* 
EDIT0 JMP SRTN      JUMP BACK TO MAIN 
******************************* 
* 
* 
SPSP  ASC 1,
"C"   OCT 103 
"E"   OCT 105 
"R"   OCT 122 
"Q"   OCT 121 
"W"   OCT 127 
":"   OCT  72 
">"   OCT  76 
"."   OCT  56 
"<"   OCT  74 
.1    DEC 1 
.4    DEC 4 
.10   DEC 10
.11   DEC 11
.128  DEC 128 
.24   DEC 24
.3    DEC 3 
.30   DEC 30
.6    DEC 6 
.60   DEC 60
.75   DEC 75
* 
B37   OCT 37
B40   OCT 40
COMMA OCT 54
B60   OCT 60
B600  OCT 600 
B77   OCT 77
* 
I.1   OCT 100001
I.2   OCT 100002
I.3   OCT 100003
I.5   OCT 100005
* 
M1    DEC -1
M6    DEC -6
* 
* 
* 
* 
*************************************************************** 
* 
PC    BSS 8 
CREAS NOP 
      JSB .ENTR 
      DEF PC
      LDB PC+2      PUT THE SIZE INTO THE NAMR BLOCK
      ADB =D3 
      LDA B,I       SET FLAG BITS 
      IOR =B400 
      STA B,I 
      ADB =D4 
      LDA PC+3,I
      STA B,I 
      LDA PC+4,I    GET TYPE
      SZA,RSS       DEFAULT TYPE ZERO TO TYPE 4 
      LDA =D4 
      STA PC+4,I
      JSB TYCHK     CHECK FOR LEGAL TYPE
      JMP CREAS,I   RETURN - ERROR CODE IN A REG
      JSB CREAT     CREATE OUTPUT FILE
      DEF *+9 
      DEF PC+0,I    DCB 
      DEF PC+1,I    ERROR BUCKET
      DEF PC+2,I    FILE NAME ( MUST BE NAMR BLOCK) 
      DEF PC+3,I    # OF BLOCKS 
      DEF PC+4,I    FILE TYPE(DEFAULT TO 4) 
      DEF PC+5,I    SECURITY CODE 
      DEF PC+6,I    CARTRIDGE ID
      DEF PC+7,I    DCB SIZE
      LDA PC+1,I      GET ERROR 
      SSA,RSS       ERROR ? 
      JMP CREA1       NO - REPORT SUCESSFUL 
      LDB PC+2         GET ADDRESS OF NAMR BLOCK
      JSB FMGRE        REPORT ERROR 
      JMP CREAS,I   RETURN
* 
CREA1 JSB ENAMR     GET FILE PARAMS 
        DEF CRENR 
        DEF PC+0,I    DCB 
        DEF TEMP      IERR
        DEF PC+2,I    NAMR BLOCK - 10 WORDS 
CRENR   EQU * 
      LDA PC+3,I    GET SIZE
      LDB PC+2      GET ADDRESS OF NAMR BLOCK 
      ADB =D7 
      STA B,I       SET SIZE INTO NAMR BLOCK AFTER ENAMR CLEARED IT 
      LDA CRMES     GET MESSAGE STRING
      LDB PC+2       AND NAMR BLOCK 
      JSB NMLST     GO LIST IT
      LDA PC+1,I    GET BACK GOOD ERROR NUMBER
      JMP CREAS,I   RETURN
* 
* 
CRMES DEF CRMS0            THIS 
CRMS0 DEC 13                 IS A 
      ASC 7,created file      TABLE.
**
      SPC 1 
************************************
* 
PO    BSS 7 
OPENS NOP 
      JSB .ENTR 
      DEF PO
      JSB OPENF     OPEN OUTPUT FILE
        DEF *+8 
        DEF PO+0,I
        DEF PO+1,I
        DEF PO+2,I
        DEF PO+3,I
        DEF PO+4,I
        DEF PO+5,I
        DEF PO+6,I
      LDA PO+1,I      GET ERROR COE 
      SSA,RSS       TEST FOR ERROR
      JMP OPEN1      NO -  GO REPORT SUCCESSFUL 
      LDB PO+2       YES - GET NAMR BLOCK 
      JSB FMGRE     GO REPORT 
      JMP OPENS,I   RETURN
* 
OPEN1 EQU * 
      JSB ENAMR     GET FILE PARAMS 
        DEF OPENR 
        DEF PO+0,I    DCB 
        DEF TEMP      IERR
        DEF PO+2,I    NAMR BLOCK - 10 WORDS 
OPENR   EQU * 
      LDA ROFLG     TEST IF WE SHOULD REPORT OPEN MESSAGE 
      SZA 
      JMP OPEN2     FLAG SET , DON'T REPORT 
      LDA OPMES     GET ADDRESS OF OPEN MESS STRING 
      LDB PO+2      AND NAMR BLOCK
      JSB NMLST       GO LIST 
OPEN2 LDA PO+2      GET TYPE
      ADA =D6 
      LDA A,I 
      JSB TYCHK     DO VALID TYPE CHECK 
      JMP OPEN3       ILLEGAL TYPE - GO CLOSE THE FILE
      LDA PO+1,I    GET BACK GOOD ERROR CODE
      JMP OPENS,I   RETURN
* 
OPEN3 JSB CLOSS     WRONG FILE TYPE - CLOSE THE FILE NOW!!!!
        DEF OPEN4 
        DEF PO+0,I
        DEF PO+1,I
        DEF ZERO     TRUNCATE SIZE
        DEF PO+2,I
OPEN4    EQU *
      LDA =D-15     GET ERROR CODE
      JMP OPENS,I     RETURN WITH ERROR 
* 
* 
ZERO  DEC 0 
OPMES DEF OPMS0           THIS
OPMS0 DEC 12                IS
      ASC 6,opened file      A TABLE. 
* 
TEMP  BSS 1 
JUNK  BSS 1 
TEMP1 BSS 1 
      SPC 1 
***************************************************** 
*  TYPE CHECK - ALLOW ANY TYPE BUT 1,2,5,6,7
*     TYPE IS IN AREG. RETRNS AT P+2 IF OK - ELSE AT P+1 , AREG = -15 
*              (-15 => ILLEGAL NAME - AS CLOSE AS I CAN COME) 
TYCHK NOP 
      CPA =D1 
      JMP TYCKE 
      CPA =D2 
      JMP TYCKE 
      CPA =D5 
      JMP TYCKE 
      CPA =D6 
      JMP TYCKE 
      CPA =D7 
      JMP TYCKE 
      ISZ TYCHK     BUMP TO GOOD RETURN 
      JMP TYCHK,I   RETURN
* 
TYCKE CCE           SET E REG FOR DECIMAL 
      JSB $CVT1     GET ASSCII
      STA TCTYP     SET IT IN THE MESSAGE 
      JSB PRINT 
      DEF TYCK1 
      DEC 13
      ASC  3,Type
TCTYP BSS  1
      ASC  9, files are illegal 
* 
TYCK1 LDA =D-15 
      JMP TYCHK,I   RETURN AT ERROR POINT 
**
* 
* 
******************************************
* 
*  REPOPRT FMGR ERROR, A REG IS ERROR, B REG. IS NAMR BLOCK 
* 
FMGRE NOP 
      STA ERSAV     SAVE ERROR NUMBER 
      STB TEMPE     SAVE ADDRESS FOR NAMR BLOCK 
      JSB PTFME     PUT ERROR IN SCB
       DEF FMGE0
       DEF ERSAV
FMGE0 EQU * 
      JSB LOGLU     MAKE SURE WE PRINT TO THE TERMINAL
        DEF FMGE1 
        DEF JUNKE 
FMGE1   EQU * 
      STA LULOG 
      CLA 
      STA NOPRN     MAKE SURE WE PRINT IT 
      LDA ERSAV     GET BACK ERROR CODE 
      LDB "SPSP 
      CCE,SSA,RSS   TEST IF ERROR IS NEGITIVE, SET E FOR $CVT1
      JMP FMGE2       POSITIVE - USE AS IS
      CMA,INA         NEGATIVE - MAKE IT POSITIVE 
      CCE             SET E FOR DECIMAL FORM $CVT1
      LDB "SPMI       GET A SPACE MINUS 
FMGE2 STB SIGN
      JSB $CVT1     CONVERT TO DECMINAL 
      STA NUMB
      LDA FEMES     GET LENGTH AN MESSAGE 
      LDB TEMPE     GET ADDRESS OF NAMR BLOCK 
      JSB NMLST     GO LIST THEM
      LDA ERSAV     GET BACK ERROR NUMBER 
      JMP FMGRE,I   RETURN
* 
ERSAV BSS 1 
TEMPE BSS 1 
JUNKE BSS 1 
* 
FEMES DEF FEMS0        THIS 
FEMS0 DEC 18             IS 
      ASC 5,FMGR error     A
SIGN  ASC 1, -              TABLE.
NUMB  ASC 3,XX on             DO NOT MOVE ! 
* 
"SPSP ASC 1,
"SPMI ASC 1, -
* 
************************************* 
* 
*  NMLST INVERSE PARSE NAMR AND LIST WITH A MESSAGE 
*        A REG HAS ADESSS OF MESSAGE IN FROM <BYTE COUNT>< ASCCII STRING> 
*        B REG HAS ADDRSS OF NAMR BLOCK 
NMLST NOP 
      STB NMNMR     SAVE NARM BUFFER. 
      LDB A,I       GET MESSAGE LENGTH
      STB TEMP      SAVE IT 
      INB           ROUND UP
      BRS             AND DIVIED BY 2 TO GET WORDS. 
      STB TEMP1 
      INA           BUMP FROM ADDRESS TO STRING 
      LDB BUFF      USE BUFF AS DESTINATION 
      JSB .MVW      MOVE THE MESSAGE THERE
      DEF TEMP1 
      NOP 
      JSB INAMR     INVERSE PARSE NAMR BLOCK
        DEF NMRTN 
NMNMR   BSS 1         NAMR BLOCK
        DEF BUFF0 
        DEF .60 
        DEF TEMP
NMRTN   EQU * 
*     LDA LULOG     RESET LIST LU TO TTY LU 
*     STA LSTLU       IN CASE OF ERROR TO LIST FILE 
      LDA BUFF      GET ADDRESS 
      CCB           REMOVE COMMA
      ADB TEMP        FROM LENGTH 
      CMB,INB       MAKE IT NEGITIVE
      STB TEMP        AND SET LENGTH. 
      LDB NOPRN     GET NO PRINT FLAG 
      SSB 
      JMP NMRT1     SET SO SKIP PRINT 
      JSB EXEC      RERPOT
        DEF NMEXE 
        DEF I.2     WRITE 
        DEF LULOG   TERMINAL'S LU 
        DEF BUFF0   BUFFER
        DEF TEMP     AND NEGITIVE LENGTH
NMEXE JSB EXCER     REPORT ERROR IF ANY 
NMRT1 JMP NMLST,I 
* 
BUFF  DEF BUFF0 
.2    DEC 2 
******************************************************* 
PR    BSS 6 
READS NOP 
      JSB .ENTR 
      DEF PR
      JSB READF     READ
        DEF *+6          SOURCE 
        DEF PR+0,I          FILE
        DEF PR+1,I
        DEF PR+2,I
        DEF PR+3,I
        DEF PR+4,I
      LDA PR+1,I      GET ERROR CODE
      SSA,RSS       TEST FOR ERROR
      JMP READS,I     NO - RETURN 
      LDB PR+5        YES - GET ADDRESS NAMR BLOCK
      JSB FMGRE     REPORT
      JMP READS,I   RETURN
      SPC 1 
******************************* 
PW    BSS 5 
WRITS NOP 
ED%WF EQU WRITS 
      JSB .ENTR 
      DEF PW
      JSB WRITF     WRITE 
      DEF *+5        RECORD 
      DEF PW+0,I     ON 
      DEF PW+1,I       OUTPUT 
      DEF PW+2,I        FILE
      DEF PW+3,I
      LDA PW+1,I      GET ERROR CODE
      SSA,RSS       TEST FOR ERROR
      JMP WRITS,I  NO - RETURN NOW
      LDB PW+4     YES - GET ADDRESS OF NAMR BLOACK 
      JSB FMGRE     LIST ERROR
      JMP WRITS,I   RETURN
* 
      SPC 1 
********************************
PCL   BSS 4 
CLOSS NOP 
      JSB .ENTR 
      DEF PCL 
* 
*     JSB LOCF        CALL LOCF TO GET FILE SIZE
*       DEF CLOCR 
*       DEF PCL+0,I   DCB 
*       DEF PCL+1,I   ERROR 
*       DEF I 
*       DEF IRB 
*       DEF I 
*       DEF JSECT 
*CLOCR   EQU *
**      LDA PCL+1,I     GET ERROR CODE
*      SSA             TEST FOR ERROR 
*      JMP CLERR         YES - GO REPORT
      JSB CLOSE     CLOSE 
        DEF *+4 
        DEF PCL+0,I     FILE DCB
        DEF PCL+1,I     IERR
        DEF PCL+2,I     TURNCATE SIZE 
      LDA PCL+1,I    GET ERROR CODE 
      SSA,RSS        TEST FOR ERROR 
      JMP CLOS1       NO  - REPORT SUCCESSFUL CLOSE 
      LDB PCL+3       YES - GET NAMR BLOCK ADDRESS
CLERR JSB FMGRE      GO REPORT
      JMP CLOSS,I   RETURN
* 
* 
CLOS1 LDA CLMES     GET ADDRESS FOR CLOSED MESSAGE STRING 
      LDB PCL+3     GET ADDRESS OF NAMR BLOCK 
      JSB NMLST     LIST MESSAGE
      JMP CLOSS,I   RETURN
* 
* 
CLMES DEF CLMS0           THIS
CLMS0 DEC 12                IS A
      ASC 6,closed file       TABLE ! 
* 
* 
      SPC 1 
********************************************* 
TPCL  BSS 3 
TCLOS NOP 
      JSB .ENTR 
      DEF TPCL
      JSB LOCF      GET FILE LOCATION 
       DEF LOCFR
       DEF TPCL+0,I 
       DEF TPCL+1,I 
       DEF I
       DEF IRB
       DEF I
       DEF JSECT
LOCFR  EQU *
      LDA TPCL+1,I  GET ERROR CODE
      SSA,RSS       ERROR ? 
      JMP LOCF1       NO  - 
      LDB TPCL+2      YES - GET ADDRESS NAMR
      JSB FMGRE       REPORT
      JMP TCLOS,I     RETURN
* 
LOCF1 LDA JSECT    ITRUN = (JSECT/2)-(IRB+1)
      ARS           DIVIDE BY 2 
      LDB IRB         GET   IRB 
      INB                 ADD ONE 
      CMB,INB                MAKE IT NEGITIVE 
      ADA B                   ADD 
      STA ITRUN                SAVE AS ITRUN. 
* 
      LDA JSECT       GET FILE SIZE IN SECTOR 
      CLE,ERA         DIVIDE BY 2 GIVES BLOCKS
      LDB ITRUN       GET TRUNCATE SIZE 
      CMB,INB 
      ADA B           REDUCE NUMBER OF BLOCKS IN FILE BY THIS SIZE
      LDB TPCL+2       COMPUTE ADDRESS OF SIZE WORD IN NAMR BLOCK 
      ADB =D7 
      STA B,I         SET IN SIZE 
* 
      JSB CLOSS     CLOSE 
      DEF TCLSR 
       DEF TPCL+0,I     FILE
       DEF TPCL+1,I 
       DEF ITRUN
       DEF TPCL+2,I  NAMR BLOCK 
TCLSR JMP TCLOS,I   RETURN
* 
I     BSS 1         USED AS A TEMP
JSECT BSS 1 
IRB   BSS 1 
ITRUN BSS 1 
      SPC 1 
********************************
PPOST BSS 3 
POSTS NOP 
      JSB .ENTR 
      DEF PPOST 
      JSB POST      POST
      DEF *+3 
      DEF PPOST+0,I 
      DEF PPOST+1,I 
      SSA,RSS        ERROR ?
      JMP POSMS       NO -GIVE MESSAGE
      LDB PPOST+2     YES - GET NAMR ADDRESS
      JSB FMGRE       REPORT
      JMP POSTS,I     RETURN
* 
POSMS STA PSAVE 
      LDA COMND     IF COMMAND IS 
      CPA "E"         THEN SUPPRESS MESSAGE 
      JMP PSMS1 
      LDA ^PMSG 
      LDB PPOST+2   NAMR BLOCK
      JSB NMLST 
PSMS1 LDA PSAVE 
      JMP POSTS,I     RETURN
* 
^PMSG DEF PMSG            THIS
PMSG  DEC 12                 IS 
      ASC 7,posted file       A TABLE 
* 
PSAVE BSS 1 
      SPC 1 
********************************
      SKP 
* 
*  CODE THAT USE TO BE IN MAIN
* 
* 
* 
ED%PS JSB KILL      KILL SPECIAL JUMP IN TTYIN
      JSB PRINT     PRINT MESSAGE ABOUT HOW TO START
      DEF LSNUL       THEN GO SET UP NUL FILE 
      DEC 16
      ASC 16,FI,namr specifies file to edit.
* 
ED%FI EQU * 
      CLA           SET UP LINE COUNTERS
      STA LASTL     FOR NEW SOURCE
      STA LINEM      CLEAR SOUREC LINE COUNTER ( MSB NOT YET USED)
      STA JUNK        SOURCE NAME LENGTH
      STA T#REC      DEST LINE COUNTER
      STA T#REM       - DOUBLE WORD BUT NOT YET USED
      STA SCFLG     SOURCE CREATE FLAG
      CLA,INA 
      STA LINES     SET SOURCE LINE NUMBER TO 1 
      CCA             SET EX FLAG 
      STA EXFLG          SO THAT THIS WILL BE NEW SOURCE
      STA PASS1     SET PASS 1 FLAG 
      LDA DBUF$     RESET DESTINATION POINTER 
      STA DBUFP 
PSFC3 JSB ECH       GET FIRST CHARACTER 
      JMP LSNUL      NO MORE CHAR - USE A NULL FILE 
      CPA B40       BLANK ? 
      JMP PSFC3       YES TRY NEXT CHAR 
      CPA B60       ="0"? 
      JMP LSNUL     JMP TO NULL LS CODE 
      JSB PBKE      PUSH BACK FIRST CHAR BY ADDING -1 
FPARS EQU * 
      JSB RALLT     RELEASE ALL TRACKS
      JSB GETAT     GET A FIRST TRACK FOR ALCATE
       JMP ./A0       NO TRACKS AND NO WAIT - ABORT 
      JSB ALCAT     SET UP DESTINATION FILE 
      JSB GETAT     GET A TRACK SO ALCAT WILL WORK NEXT TIME
       JMP ./A0       NO TRACKS SO ABORT NOW
      LDA NBUFF     GET WHERE TO PUT FILE NAME
      JSB SC.CR      AND GO  PARSE FILE NAME. 
        JMP STEOF       SET AND ENMPTY FILE. USE LS AREA
      JSB INSRC     FETCH FILE
        JMP NEWSC     NOT FOUND - GO TELL HIM AND GIVE UP.
* 
      CCA           SET 
      STA ERFLG       ER NAME VALID FLAG
*     LDA FCARW     GET USER'S CART. SPECIFICATION. 
*     SZA           WAS IT SUPPLIED?
*     JMP WPMSG      YES--NO NEED TO FAKE IT. 
*     LDA SBUF$,I    NO. GET FIRST WORD OF DCB. 
*     AND B77       ISOLATE THE FILE'S LOCATION LU. 
*     CMA,INA       NEGATE, AND SAVE FOR
*     STA FCARW      POSSIBLE USE IN FILE REPLACEMENT.
WPMSG LDA SBUF$     GET FLAG WORD FORM DCB
      ADA =D7 
      LDA A,I       TEST IF SECURITY CODES AGGREE 
      SSA           BIT 15 OF WORD 7 - IF SET THEN MATCH
      JMP STEOF       YES - SKIP MESSAGE
      JSB PRINT 
      DEF STEOF 
      DEC  12 
      ASC  12,File is write protected
* 
* 
STEOF CCA           SET EOF FLAG
      STA SLNG      IN SOURCE LENGTH
      LDA LASTL     SAVE LINE COUNT 
      STA JUNK
      JSB ./B1      TRANSFER PARTIAL BUFFER 
      LDA JUNK      RESTORE 
      STA LASTL      LINE COUNT 
      JMP STBUF     SET TBUFF.
      SPC 1 
*LSFIL EQU *
*      IFZ
*      JSB REMCK     TALKING REMOTE?
*      CLA,RSS       YES,TREAT LS AS UNDEFINED
*      XIF
*      CLA           ALWAYS USE NUL LS
*     LDA SFCUN     SAVE SYSTEM LS POINTER, 
LSNUL EQU * 
      LDA ELNG      NO FILE - CLEAR E BUFF SO SC.CR WILL
      STA ECCNT        FAIL.
      JMP FPARS     GO DO NORMAL FILE STUFF.
* 
*LSNUL CCB           UNLESS LS UNDEFINED. 
*     SZA,RSS 
*     STB NOLSF         ! NO LS SUPPORT 
*     STA LSLUT      IN SOURCE FILE POINTER AND 
*     JSB ALCAT     GET LS FILE AND DEST. TRACK 
*     CCA           IF THE LOGICAL SOURCE AREA          !NO 
*     CPA NOLSF      IS UNDEFINED, THEN                 !LS 
*     JMP STEOF+1     BYPASS SOURCE INPUTS, AT PRESENT. !SUPPORT
*     JMP STEOF       BYPASS SOURCE INPUTS, AT PRESENT. 
*     JSB SQ        FILL INPUT BUFFER 
STBUF EQU * 
      CLA           CLEAR THE TEMP
      STA JUNK       USE FOR NAME LENGTH
      JSB INAMR     PUT ASCII FILE NAME IN
        DEF PUTFN        SAVE AREA
        DEF NBUF0+0 
        DEF FNAME+0 
        DEF .30 
        DEF JUNK    THIS MUST POINT TO A ZERO,BECOMES COUNT 
PUTFN   EQU * 
      LDA FSECR     SAVE ORGINAL SC FOR A 
      STA FSECW      POSSIBLE ER. 
      LDA JUNK      SHORTEN NAME LENGTH BY 1
      SZA             TO REMOVE THE COMMA 
      ADA =D-1
      STA FNSIZ        AND SAVE.
      JMP DISPL     PRINT FIRST LINE
* 
NEWSC CPA M6        SOURCE NOT OPENED - IS ERROR -6  ?
      JMP NWSC1       YES - GO TELL HIM WE WILL CREATE IT 
NWSC0 JSB CLRN0        NO - WIPE OUT NAME SO ER WONT WORK 
      JMP LSNUL         USE NULL FILE 
* 
NWSC1 JSB PRINT 
      DEF NWSC3 
      DEC 29
      ASC 10,File does not exist, 
      ASC 19, an ER or the first WR will create it. 
* 
* 
NWSC3 CCA           SET 
      STA SCFLG       SOURCE CREATE FLAG
      CLA           CLEAR A FOR NUL LS
      JMP LSNUL 
* 
******
* 
GETAT NOP           ALLOCATE A TRACK AND PUT IT IN ALCAT TABLE
      JSB RQST      GET THE TRACK 
        JMP GETAT,I   NONE SO RETURN
      LDA NWTRK     COPY THE NEW TRACK NUMBER TO
      STA ALTRK       ALCAT'S AREA
      LDA NEWLU       DITTO FOR LU
      STA ALCLU 
      ISZ GETAT     BUMP TO GOOD RETURN 
      JMP GETAT,I   RETURN
* 
**********
* 
*    PANIC MODE REQSUET TRACKS - WE WILL USE THE SOURCE TRACKS
*    FIRST COPY LU AND SECT THE READT IT FIND LINK WORD 
ED%PC LDA LSLUT     GET SOURCE TRACK POINTER
      LDB .2        ASSUME LU 2 
      RAL,CLE,SLA,ERA   TEST BIT 15, CLEAR IT 
      LDB .3        IT IS LU 3 -
      STA NWTRK 
      STB NEWLU 
      LDA SECT2 
      CPB .3
      LDA SECT3 
      RAR           CONVDERT TO 128 WORD SECTORS
      STA DSCTR     SET SECTOR PER TRACK FOR RQST 
      ADA =D-1      BUMP BACK BY ONE SECTOR 
      CLE,ELA       TIMES 2 GIVES 64 WORD SECTOR NUMBER 
      STA PCSEC 
      JSB EXEC      READ THE TRACK
        DEF EDPC1 
        DEF I.1     READ/ NO ABORT
        DEF NEWLU 
        DEF BUF 
        DEF .128
        DEF NWTRK 
        DEF PCSEC 
EDPC1   JSB EXCER 
      LDA BUF+127   GET THE LINK WORD 
      STA LSLUT     SET IT AS THE START LU,TRACK
      LDA #TRAK     REDUCE OUTSTANDING TRACK COUNT BY 1 
      ADA =D-1        
      STA #TRAK 
      JMP RQST4     CONTINUE PROCESSING 
* 
SECT2 EQU 1757B     # SECTORS PER TRACK LU 2
SECT3 EQU 1760B     # SECTORS PER TRACK LU 3
PCSEC BSS 1 
* 
* 
* 
*********************************************************** 
* 
* CLOSE SOURCE FILE 
* 
* 
* 
CLMMS ASC 4,,closed 
B^CLS DBL CLMMS 
.7    DEC 7 
* 
* 
ED%CS JSB ENDCK     MAKE SURE THERE ARE NO MORE CHARAS
      LDA ERFLG     TEST IF 
      SSA,RSS         ER FILE EXIST 
      JMP ERR       NO - ERROR
      LDA SCFLG     TEST IF FILE EXIST
      SSA 
      JMP ERR       NO - ERROR
      LDA B^CLS     PATCH IN CLOSED INTO MESSAGE
      LDB B^FNM 
      ADB FNSIZ 
      JSB .MBT
      DEF .7
      NOP 
      LDA FNSIZ 
      ADA .7
      STA FNSIZ 
      JSB ERCLS     GO CLOSE FILE 
      NOP           IGNORE ERRORS 
      JMP DISPL 
********************************* 
* 
* 
ERCLS NOP           CLOSE ER FILE, RETURN AT P+2 IF SUCCESSFUL
      CCA           SET QSCFG 
      STA QCSFG 
      JSB $ERTN     AND DO IT 
        JMP ERCLS,I   ERROR RETURN
      ISZ ERCLS 
      JMP ERCLS,I      GOOD RETURN
* 
**********************************
* 
* ED%EF EDIT A DIFFERENT FILE 
*    - IF THERE IS ANY LINES IN THE FILE - ASK FIRST
*    - CHECK IF THERE IS A  ER FILE OPEN - IF SO GO CLOSE 
*    - JUMP INIT INPUT CODE 
* 
ED%EF JSB CSTRP     SRTIP COMMA, BLANKS 
      JMP ERR       NO FILE NAME GIVE SO ERR
      JSB SETOK     STRIP SLASH IF PRESENT
      LDA MODFG     HAS FILE BEEN MODIFIED ?
      SZA 
      JSB ASK         YES - ASK FIRST 
      CLA           CLAR MODIFIED FLAG
      STA MODFG       FOR NEXT TIME 
      LDA ERFLG     TEST IF ER FILE EXISTS
      SSA,RSS 
      JMP $EF1
      JSB ECLOS     CLOSE OLD FILE IF OPEN
$EF1  JMP ED%FI     GO GET NEW FILE 
* 
* 
**************************************************
$ERTN NOP         DO FILE STUFF - RETURN AT P+2 IF NO ERROR 
ED%WR EQU $ERTN 
      CCA         SET 
      STA TRFLG   TRANSFER FLAG 
      DLD T#REC    SAVE WHERE WE ARE
      DST E#REC 
      CCA 
      STA PANIC     SET PANIC FLAG IN CASE WE RUN OT OF TRACK 
      JSB ./B$       TRANSFER FILE TO DESESTION 
      CLA 
      STA PANIC 
      JSB FILWR     WRITE OUT FILE
      JMP $ERT1     ERROR RETURN
      CLA 
      STA MODFG     CLEAR MODIFIED FLAG 
      JSB ERSTR     RESTOR AFTER E CODE 
      NOP           NO RESPOSITION RETURN 
      ISZ $ERTN     BUMP
      JMP $ERTN,I      AND RETURN 
* 
$ERT1 JSB ERSTR     RESTORE BFFER STUFF 
      NOP 
      JMP $ERTN,I   RETURN
* 
* 
**************************
* ERSTR  RESTORES THINGS AFTER AN E TYPE COMMAND
*     OLD T#REC MUST BE IN E#REC
* 
ERSTR NOP 
      CLA 
      STA EXFLG     RESET EXCHANGE FLAG 
      STA PBFLG     RESET PARTIAL BUFFER FLAG 
      STA LSTFG     RESET LIST FLAG 
      CLA,INA 
      STA LINES     RESET LINE COUNTER
      JSB ALCAT     GET NEW SOUCE AND DEST. FILE
      JSB SQ        READ IN FIRST BLOCK 
      LDA E#REC+1   GET WHERE WE WERE, HIGH BITS
      SZA           IF THEY ARE ZERO THEN OK TO GO BACK 
      JMP ERSTR,I     NO - JUST RETURN
      LDA E#REC 
      SSA           TEST FOR TOO MANY 
      JMP ERSTR,I    NEGITIVE - JUST RETURN 
      JSB TRN       MOVE THE LINES TO GET BACK
      ISZ ERSTR     BUMP
      JMP ERSTR,I     AND RETURN
* 
E#REC BSS 2 
E.TBS BSS 1 
**************************************************
NLSP0 CCA           SET 
      STA NLSFG       NEW LIST LU FLAG
      STA MRGFG       MERGE FLAG
      JSB CSTRP     STRIP TO NAME 
       JMP OLDLF      DEFAULTED - GO CHECK FOR OK 
      JMP NLSP3     GO PARSE FILE NAME
* 
* NLSLU  SET UP FOR A NEW LIST LU 
* 
NLSLU NOP 
ED%NL EQU NLSLU 
*** 
* ALLOW LIST TO A FILE
*   PARSE FOR NAMR
*     JSB NUMIN     GET OPTIONAL NEW LIST LU
      JSB EFOLD     FOLD E BUFFER 
      CLA           CLEAR MERGE FLAG
      STA MRGFG 
      JSB ECH 
       JMP NLSLU,I  NOTHING DO RETURN 
      CPA PLUS      IS THIS CHAR A + FOR MERGE ?
      JMP NLSP0       YES - GO SET MERGE FLAG 
      JSB PBKE        NO - PUT IT BACK
NLSP3 LDA ECCNT     GET COMMAND CHAR COUNT
      INA           BUMP IT BECAUSE 
      STA TEMP        NAMR COUNT IS ONE MORE THAN ECH COUNT 
      JSB TNAMR     PARSE WITH NAMR 
        DEF NLS.0 
        DEF LSNAM 
        DEF EBUFF,I 
        DEF ELNG
        DEF TEMP
NLS.0 CCB          SET B TO -1
      ADB TEMP      UPDATE COMMAND  CHAR COUNT
      STB ECCNT 
NLSP4 JSB ENDCK     MAKE SURE THERE ARE NO MORE CHARS 
      LDA LSNAM+3   GET TYPE WORD 
      AND .3        MASK OUT ALL BUT FIRST
      SZA,RSS       TEST IF NULL
      JMP NLS.1     YES - SKIP NEW TEST(A REG. IS 0)
      CCB           NOT NULL -SET LIST FLAG(FOR A DELETE
      STB LSTFG         WITH LIST)
      STB NLSFG     SET NEW LIST LU FLAG
      CPA .3        IF TYPE 3 THEN A FILE 
      JMP LSTFL       FILE - GO DO FILE STUFF 
      LDA LSNAM       ELSE GET LU NUMBER
**********************
NLS.1 AND B77       SAVE JUST THE LU
      LDB 0 
      SZA,RSS       IF NOT SUPPLIED 
      JMP NLSLU,I   RETURN NOW
      IOR B600      SET ECHO AND V-BITS 
      STA LSTLU     SAVE THE LU 
**    SZB,RSS       SKIP UNLESS NOT SPECIFIED 
**    JMP NLSLU,I 
* 
      JSB TYPEQ     GET LIST DEVICE TYPE CODE.
      SZA,RSS       IF IT'S INTERACTIVE,
      JMP NLSLU,I    THEN SIMPLY RETURN; ELSE, CHECK: 
* 
*  ALLOW ANY DRIVER TYPE TO BE USED.
* 
* 
*     CPA DVR37       IS IT DVR37-- A HPIB DEVICE?
*     JMP *+6         YES, SKIP FOR ADDITIONAL PROCESSING 
*     CPA DVR23 
*     JMP +*4 
*     CPA DVR12     IS IT DVR12--A LINEPRINTER? 
*     JMP *+2        YES, SKIP FOR ADDITIONAL PROCESSING. 
*     JMP ERR        NO! OTHER DEVICES ARE UNACCEPTABLE.
      JSB LULOK     GO TO LOCK THE LIST LU
      JMP NLSLU,I   RETURN. 
***************************** 
* SET LIST TO A FILE
* 
LSTFL EQU * 
NEWFL JSB LCLOS     CLOSE ANY OPEN LIST FILE
      LDA LSNAM+7   DEFUALT SIZE TO 
      SZA,RSS         24 BLOCKS 
      LDA .24 
      STA LSNAM+7 
      JSB CREAS     CREATE LIST FILE
        DEF LSTF4 
        DEF LDCB+0
        DEF RUBSH 
        DEF LSNAM     NAME
        DEF LSNAM+7   SIZE
        DEF LSNAM+6   TYPE
        DEF LSNAM+4   SECU
        DEF LSNAM+5   CARTRIDGE 
        DEF .128
LSTF4   EQU * 
      CPA =D-2      DOES FILE ALREADY EXIST?
      JMP LSTFO     YES - GO OPEN IT
      SSA           TEST FOR ERROR
      JMP LSTF3       YES - GO REPORT 
LFRTN LDA ^LSNM     COPY NAME TO REPORING BUFFER
      LDB ^LNAM 
      JSB .MVW
      DEF .10 
      NOP 
LFSFF CCA           SET 
      STA LOPNF       LIST FILE OPEN FLAG 
      STA LSTLU       AND LIST LU TO -1 
      CLA           CLEAR 
      STA SPFLG       SPACES FLAG 
      JMP NLSLU,I   RETURN
***************************************************** 
* 
OLDLF LDA LOPNF     CONTINUE LIST TO OPEN FLIE
      SSA             TEST IF THER A FILE OPEN
      JMP LFSFF       YES - RETURN
      JMP ERR         NO - GIVE ??
* 
LSTFO JSB OPENS     OPEN NEW LIST FILE
        DEF LSTF2 
        DEF LDCB+0
        DEF RUBSH 
        DEF LSNAM 
        DEF ZERO      EXCLUSIVE OPEN
        DEF LSNAM+4   SECU CODE 
        DEF LSNAM+5   CR
        DEF .128
LSTF2 EQU * 
      SSA,RSS       ELSE IF ERROR - REPORT
      JMP LSTFA       NO ERROR - GO ASK IF IT IS OK TO OPEN 
LSTF3 JSB FMPER     CLEAN UP AFTER ERROR
      JMP NODE1     ABORT COMMAND 
* 
LSTFA EQU *     
      LDA ^LSNM     COPY NAME TO REPORING BUFFER
      LDB ^LNAM 
      JSB .MVW
      DEF .10 
      NOP 
      CCA           SET 
      STA LOPNF       LIST FILE OPEN FLAG 
      STA LCLOF       AND LIST CLOSE FLAG IN CASE ASK DO NOT RETURN 
      LDA MRGFG     TEST MERGE FLAG 
      SSA,RSS 
      JMP LSTM4     NO - SKIP MOVING TO EOF 
      JSB PRINT 
      DEF LSTM1 
      DEC 9 
      ASC 9,Appending to file.
LSTM1 JSB READS     READ UNTIL WE FIND AN EOF 
        DEF LSTM2 
        DEF LDCB  
        DEF IERR  
        DEF BUF 
        DEF ZERO      DON'T MOVE ANY WORDS  
        DEF ILEN  
        DEF LSNAM     NAMR BLOCK FOR ERRORS 
LSTM2   EQU * 
      SSA           ERROR ? 
      JMP LSTF3       YES - GO ABORT COMMAND
      LDA ILEN      AT EOF ?
      SSA,RSS         
      JMP LSTM1     NO TRY NEXT RECORD  
LSTM4 JSB ASK       GO ASK IF IT IS OK TO USE THIS FILE 
      CLA 
      STA LCLOF 
      JMP LFSFF      GOT BACK SO MUST BE OK.
* 
MRGFG BSS 1 
IERR  BSS 1 
ILEN  BSS 1 
********************
* 
* LCLOS CLOSE THE OPEN LIST FILE
* 
LCLOS NOP 
ED%CL EQU LCLOS 
      LDA LOPNF     GET LIST FILE OPEN FLAG 
      SSA,RSS        IF -1 THEN THERE A FILE OPEN 
      JMP LCLOS,I      NOTHING OPEN - RETURN
      JSB TCLOS     TRUNCATE AND CLOSE THE LIST FILE
        DEF LSTF0 
        DEF LDCB+0
        DEF RUBSH 
        DEF LNAM+0  NAMR BLOCK FOR ERROR REPORT 
LSTF0 SSA           TEST FOR ERROR
      JSB FMPER       YES - GIVE ERROR MESSAGE
      CLA           SET A TO  ZERO
      STA LOPNF     CLEAR LIST FILE OPEN FLAG 
      STA LNAM+3    AND VALID REPORT NAMR FLAG
      JMP LCLOS,I   RETURN
* 
LSNAM BSS 10
^LSNM DEF LSNAM 
PLUS  OCT 53        '+' 
**********************************************************
* 
* FILWR WRITE DESTINATION FILE TO FMP FILE
* 
FILWR NOP 
      LDA QCSFG     IS THIS A 
      SZA            CLOSE SOURCE FILE CALL ? 
      JMP .QCS1         YES - SKIP COMMAND SCAN 
      JSB ECHL    GET REPLACE,CREATE OR LS COMAND 
        JMP FWERR   NOTHING SO ERROR
*      CPA "L"       SET SYSTEM LS POINTER? 
*      RSS
*      JMP ./E3 
*      IFZ
*      JSB REMCK     REMOTE CRT?
*      JMP FWERR       YES, CAN'T ACCESS LS 
*      XIF
*      SPC 1
*      JSB $LIBR     *******************************
*      NOP           TURN OFF MEMORY PROTECT AND
*      LDA LSLUT      SET SYSTEM LS AREA POINTER
*      STA SFCUN       TO FINAL FILE ADDRESS
*      JSB $LIBX        THEN TURN MEMORY PROTECT
*      DEF *+1           BACK ON
*      DEF LSTLS     ****************************** 
*      SPC 1
*DLU.  DEF LU.
*DTRK. DEF TRK. 
*DLSB  DEF LSBUF
*DTBF0 DEF TBUF0     PERMANENT SAVE.
*LSLU  NOP           RETURN TO SCHEDULER
*LTRAK NOP           RETURN TO SCHEDULER
*LSBUF ASC 4,LS FILE X, 
*LU.   ASC 1,2, 
*TRK.  ASC 2,XXX
*      SPC 1
*LSTLS LDA TBUFF
*      STA DTBF0
*      LDA DLU. 
*      STA TBUFF
*      LDB SFCUN
*      LDA .2 
*      SSB
*      INA
*      STA LSLU 
*      CLB
*      JSB DEC       CONVERT LU TO ASCII
*      CLA
*      STA OCCNT     RESET CHAR COUNTER 
*      LDA DTRK.     POINT TO TRACK ASCII 
*      STA TBUFF
*      LDA SFCUN     GET LS TRACK 
*      CLE,ELA       SHUNT OUT LU 
*      ALF,ALF
*      STA LTRAK     B ALREADY CLEAR FROM ABOVE 
*      JSB DEC
*      LDB OCCNT     ACTUAL # OF DIGITS.
*      ADB .10       INCREASE BY PREL CHARS 
*      LDA DLSB      POINT TO MESSAGE,
*      JSB LST        AND SEND IT OUT.
*      LDA DTBF0     RESTORE PRIMARY OUTPUT 
*      STA TBUFF      POINTER AND RESET 
*      CLA             CHARACTER COUNTER. 
*      STA OCCNT
*      SPC 1
*      JSB ECHL      FETCH C OR R 
*      JMP FWEND     NONE, GO TO END MESSAGE
       STA SAVER      SAVE COMMAND MODE 
* 
*   SC.CR ALLOWS OPTIONAL COMMA 
      LDA ^LSNM     PUT FILE NAMR LSNAM AS TEMP 
      JSB SC.CR     PARSE FILE NAME 
      JMP CHEKR     /R IS VALID TO REPLACE SOURCE.
      LDA SAVER      FETCH COMMAND MODE 
      CPA "C"       IF C
      JMP CRFIL       GO TO CREATE FILE 
      CPA "R"       IF R
      JMP RPFIL       GO TO REPLACE FILE
      JMP FWERR       OTHERWISE GO TO FWERROR 
      SPC 1 
CHEKR LDA SAVER     GET COMND 
      CPA "R"       IF IT'S R, PICK UP TURN-ON
      JMP .QCS1      FILE NAME:SC:CR. 
      JMP FWERR       NOT R - F W ERROR.
* 
SAVER BSS 1 
* 
.QCS1 LDA NBUFF     CHANGE POINTER FOR SENDING
      STA SCCR^      FILE NAME. 
      JSB .DFER     MOVE IN FILE SC:CR:TYPE 
       DEF FSECR
       DEF FSECW+0
      ISZ SCFLG     TEST IF WE ARE TO CREATE  -(ONLY TRY ONCE)
      JMP .ERFL     NO  - 
      CCA           SET  A FLAG SO WE WILL SET ERFLG
      STA SERFG      IF THE CREATE IS SUCCESSFUL
      JMP CRFIL     YES - GO DO IT
.ERFL CCA           SET ER OPEN LFAG
      STA ROFLG 
      JMP RPFIL     TRY TO REPLACE. 
      SPC 1 
NBUFF DEF NBUF0+0 
FSECR BSS 1          ! THIS 
FCART BSS 1          ! IS A 
FTYPE BSS 1          ! TABLE. 
FSIZE BSS 1 
      SPC 1 
CRFIL DLD T#REC     COMPUTE FILE SIZE NEEDED
      ASR 7           IN 128 WORD BLOCKS
      ADA T#SEC     FSIZE = 
      INA            ( T#REC/128 + T#SEC ) + 1
      LDB SCCR^     GET POINTER TO NAMR BLOCK 
      ADB =D7       BUMP TO SIZE WORD 
      LDB B,I       GET SIZE
      STB FSIZE     SET AS A SIZE FOR NOW 
      SSB            WAS A NEGITIVE SIZE GIVEN ?
      JMP CRFL2         YES -  GO SO SET EXACT SIZE 
      SZB           IF DEFAULTED ROUND TO A MULTIPLE OF 6 BLOCKS
      JMP CRFL1      HE GAVE A >0 NUMBER SO USE IT
* 
*     MAKE SURE FILE SIZE IS A MULTIPLE OF 6
* 
      STA FSIZE     SET EXACT  IN CASE OF < 6 BLOCKS
      ADA =D-7      IF LESS THAN 6 BLOCK SKIP TEST
      SSA 
      JMP CRFL1 
      ADA =D12      ROUND UP
      CLB 
      DIV .6
      MPY .6
      STA FSIZE 
CRFL1 EQU * 
      SPC 1 
**    JSB CREAT     CREATE OUTPUT FILE
      JSB CREAS     SEG CALL TO CREATE OUTPUT FILE
      DEF *+9 
      DEF DBUF$,I   DCB 
      DEF RUBSH     ERROR BUCKET
      DEF SCCR^,I   FILE NAME 
      DEF FSIZE+0   # OF BLOCKS 
      DEF FTYPE+0   FILE TYPE(DEFAULT TO 4) 
      DEF FSECR+0   SECURITY CODE 
      DEF FCART+0   CARTRIDGE ID
      DEF DCBSZ+0   DCB SIZE
      SPC 1 
      SSA           ERROR FROM CREATE?
      JMP FMPO      YES, GO GIVE UP 
      ISZ SERFG     WAS  ER DEFAULT FILE CREATE ? 
      JMP WRITR     NO - LEAVE ER FLAG UNCHANGED
      CCB           YES - SET 
      STB ROFLG         ER FILE OPEN FLAG 
      STB ERFLG     SET ER VALID FLAG 
      JMP WRITR     GO TO OUTPUT FILE 
* 
SERFG DEC 0 
* 
CRFL2 STA FSIZE     SET EXACT SIZE
      JMP CRFL1     GO CREATE FILE
* 
      SPC 1 
**RPFIL JSB OPEN      OPEN OUTPUT FILE
RPFIL JSB OPENS       SEG CALL TO OPEN OUTPUT FILE
      DEF *+8 
      DEF DBUF$,I 
      DEF RUBSH 
      DEF SCCR^,I 
      DEF ZERO
      DEF FSECR+0 
      DEF FCART+0 
      DEF DCBSZ+0 
      SPC 1 
      SSA           ERROR FROM OPEN?
      JMP FMPO      YES, PRINT ERROR MESSAGE
      SPC 1 
      LDA QCSFG     IS THIS A CLOSE SOURCE CALL ? 
      SZA 
      JMP .QCS2       YES - SKIP WRITE
WRITR JSB SETSO     SET UP TO READ SOURCE.
      JSB SQ        READ IN FIRST BLOCK 
NXREC LDB SLNG      CONVERT # CHARS. TO 
      BRS             # OF WORDS
      STB RCLNG 
      SPC 1 
      LDA TSFLG     GET TIME STAMP FLAG 
      SSA,RSS 
      JMP WRTF0     FLAG CLEAR SO DON'T TIME STAMP
      LDA B         GET RECODR LENGTH 
      LDB SBUFP     GET WORD ADDRESS
      JSB TSMPT     SET FOR TIME STAMP
        JMP WTSMP     GO DO TIME STAMP
**    JSB WRITF     WRITE 
WRTF0 JSB WRITS     SEG CALL TO WRITE 
      DEF *+6        RECORD 
      DEF DBUF$,I     ON
      DEF RUBSH        OUTPUT 
      DEF SBUFP,I       FILE
      DEF RCLNG+0 
      DEF SCCR^,I     NAMR BLOCK FOR ERROR REPORTS
      SSA           IF ERROR, PRINT MESSAGE AND 
      JMP FMPC       TRY TO RECOVER 
      LDA RCLNG     IF EOF WRITTEN
      SSA            GO TO
      JMP CLSFL       CLOSE FILE
      JSB I/PSB     READ NEXT RECORD
      JMP NXREC     CONTINUE
      SPC 1 
* 
CLSFL EQU * 
.QCS2 CLA           FLAG AS NORMAL CLOSE
      JSB FCLOS      GO CLOSE OR POST FILE
FWEND ISZ FILWR       INCR RETURN 
      JSB QCSCL     GO CLEAN UP QSC IF NEEDED 
      JMP FILWR,I     RETURN AS SUCESSFUL 
* 
WTSMP JSB @STMP     GET FOMATTED TIME 
        DEF *+1+1 
        DEF BUF     USE BUF AS A TEMP 
      LDA B^BUF 
      LDB TPNTR     GET BYTE POINTER TO START OF DATE 
      JSB .MBT      MOVE IN TIME STRING 
      DEF .11 
      NOP 
      JMP WRTF0 
* 
FMPC  EQU * 
      JSB FCLOS     GO CLOSE FILE, A REG AHS ERROR FLAG 
FMPO  JSB FMPER     GO DO SOME ERROR CLEAN UP 
      JMP FILWR,I   RETURN
* 
* 
FWERR JSB PRTER     GO PRINT '??' 
FMPC0 JMP FILWR,I    RETURN THROUGH ERROR EXIT
* 
* 
**
*** 
* 
FCLOS NOP          - CLOSE OR POST FILE 
      LDB QCSFG     IS THIS A QCS COMMAND ? 
      SZB 
      JMP FCLS0       YES - CLOSE THE FILE
      LDB ROFLG      TEST IF THIS IS DEFAULT ER 
      SZB 
      JMP FPOST     YES - JUST POST THIS FILE 
* 
**CLSFL JSB CLOSE     CLOSE FILE
FCLS0 JSB CLOSS     CALL TO CLOSE 
      DEF FCLS1      OUTPUT 
      DEF DBUF$,I     FILE
      DEF RUBSH         IERR BUCKET 
      DEF ZERO      TRUNCATE SIZE 
      DEF SCCR^,I     NAMR BLOCK FOR ERROR REPORTS
FCLS1 EQU * 
      SSA           IF ERROR PRINT MESSAGE
      JSB FMPER      AND END
      JMP FCLOS,I   RETURN
* 
FPOST SSA           IS IT AN ERROR
      JMP FCLOS,I     YES - JUST RETURN.
      JSB POSTS     POST IS IN SEG ZERO 
      DEF FPST1 
      DEF DBUF$,I 
      DEF RUBSH 
      DEF SCCR^,I   NAMR BLOCK FOR ERROR REPROT 
FPST1 JMP FCLS1     GO TEST FOR ERROR 
* 
************* 
* 
CLRN0 NOP           CLEAR ER NAME BUFFER
      LDA ^CLRN 
      LDB NBUFF 
      JSB .MVW      WIPE OUT SUBFIELDS
        DEF .10 
        NOP 
      JMP CLRN0,I   RETURN
* 
CLRNR ASC 3,             CLEAR NAMR TYPE BLOCK
      DEC 0,0,0,0,0,0,0    7   ZERO  WORDS
^CLRN DEF CLRNR 
      SPC 1 
* 
QCSCL NOP           CLEAN UP CLOSE SOURCE OPERATION 
      LDA QCSFG     GET CLOSE SOURCE FLAG 
      SZA,RSS       IS IT SET ? 
      JMP QCSCL,I     NO - JUST RETURN
      CLA              YES - CLEAR
      STA QCSFG        CLOSE SOURCE FLAG
      STA ROFLG         AND ER FILE OPEN FLAG 
      STA ERFLG         AND ER OK FLAG
      JSB CLRN0         AND NAME BUFFER 
      JMP QCSCL,I   RETURN
* 
SC.CR NOP 
      STA SCCR^     SAVE WHERE TO PUT FILE NAME(10 WORD ARRAY)
****
* OPTIONAL COMMA <JDJ>
      JSB CSTRP     REMOVE POSSIBLE COMMA 
        JMP SC.CR,I   NOTHING, SO RETURN
      JSB ECH       SEE IF THERE ARE ANY MORE CHAR
        JMP SC.CR,I   NO - SO RETURN NOW
      JSB EFOLD     FOLD E BUFFER 
      LDA ECCNT     GET COMMAND CHAR COUNT
      STA SCCRT       NAMR COUNT IS ONE MORE THAN ECH COUNT 
*                 SO WE DON'T HAVE TO PUT BACK THE LAST CHAR. 
      JSB TNAMR     PARSE WITH NAMR 
        DEF SCCR0 
SCCR^   BSS 1 
        DEF EBUFF,I 
        DEF ELNG
        DEF SCCRT 
SCCR0 EQU * 
      CCB          SET B TO -1
      ADB SCCRT     UPDATE COMMAND  CHAR COUNT
      STB ECCNT 
      SSA           TEST FOR ERROR
      JMP SC.CR,I     YES - RETURN NOW
      LDB SCCR^     FETCH 
      ADB =D4        SECURITY 
      LDA B,I         CODE
      STA FSECR        AND SAVE.
      INB           FETCH 
      LDA B,I        CARTRIDGE NUMBER 
      STA FCART       AND SAVE. 
      INB           FETCH 
      LDA B,I         FILE TYPE 
      STA FTYPE     AND SAVE
      ISZ SC.CR     BUMP RETURN ADDRESS 
      JMP SC.CR,I 
* 
SCCRT BSS 1 
* 
      SKP 
*     INSRC  FINDS AND LOADS NEW SOURCE FILE. 
* 
*       - READS SOURCE (FMGR) FILE INTO DESTINATION BUFFER, ONE RECORD
*           AT A TIME, DELETING TRAILING DOUBLE BLANKS. 
*       - WHEN DESTINATION BUFFER IS FULL, CALLS  <DOUT>  TO WRITE THE
*           BUFFER IN SYSTEM-ASSIGNED TRACK IN LS FORMAT. 
* 
TEMPI BSS 1 
* 
INSRC NOP 
***** 
* MERGE WITH NON-EXCLUSIVE OPEN    <JDJ>
* 
      CLA           EXCLUSIVE OPEN IS A ZERO
      LDB EXFLG     GET ORGINAL/MERGE FLAG
      SSB,RSS       IF SET THEN ORGINAL 
      INA             THIS IS A MERGE - NON-EXCLUSIVE OPEN
      STA TEMPI 
* 
**    JSB OPEN      OPEN INPUT FILE 
* 
      JSB OPENS     SEG CALL TO OPEN INPUT FILE 
      DEF *+8 
      DEF SBUF$,I 
      DEF RUBSH 
      DEF SCCR^,I 
      DEF TEMPI 
      DEF FSECR+0 
      DEF FCART+0 
      DEF DCBSZ+0 
      SSA,RSS       ERROR ON OPEN?
      JMP IN1       NO, READ IN FILE
      JSB FMPER     YES, PRINT ERROR
      JMP INSRC,I   ERROR RETURN
IN1   ISZ INSRC     STEP TO OK RETURN 
      CLA 
      STA TSMFG     CLEAR TIME STAMP GIVEN FLAG 
*     LDA EXFLG     ORIGINAL INPUT
*     SSA            FILE OR MERGE FILE?
**                              ALCAT NOW CALLED BEFORE INSCR IS CALLED 
*     JSB ALCAT     ORGINAL - GET FIRST DEST. TRACK 
      JMP NXTR2 
* 
      SPC 1 
NXTRC EQU * 
      LDB EXFLG     MERGE OR ORIGINAL?
      SSB 
      JMP NXTR1     ORIGINAL
      ISZ T#REC     INCREMENT DEST RECORD COUNT 
      JMP *+2        DURING READ FOR A MERGE, 
      ISZ T#REM       IN DOUBLE-WORD INTEGER. 
      JMP NXTR2 
* 
NXTR1 ISZ LASTL     BUMP LAST LINE COUNT AS WE READ IN
* 
NXTR2 LDA DBUFP     SET DBFP1 
      INA           TO
      STA DBFP1      DBUFP+1
      SPC 1 
      JSB READS     READ
      DEF *+7          SOURCE 
      DEF SBUF$,I          FILE 
      DEF RUBSH 
      DEF DBFP1,I 
      DEF .75 
      DEF DBUFP,I 
      DEF SCCR^,I   POINTER TO NAMR BLOCK FOR ERROR REPORT
      SPC 1 
      SSA           ERROR FROM READF? 
      JMP FMPA      YES, GO TO FILE MANAGER ABORT 
      LDA DBUFP,I   FETCH RECORD LENGTH 
      SSA           END OF FILE?
      JMP ENDFL     YES, GO TO END PROCESS
*** 
      JSB OVTST     TEST FOR SIZE OVERFLOW < A IS SAVED>
        JMP ISER1       YES - GO DO ERROR PROCCSSING
* 
**     THIS CODE DELETES TRAILING BLANKS FROM RECORDS 
**     READ FROM THE FILE MANAGER 
*      ADA M1        BACK UP ONE WORD 
*      SZA,RSS       IF LAST WORD IN RECORD 
*      JMP .NXT        DO NOT DELETE
*      LDB DBFP1     LOAD LAST
*      ADB A          WORD OF 
*      LDB B,I         RECORD 
*      CPB SPSP      IF LAST TWO CHARS. WERE
*      JMP DEL?       BLANK CONTINUE LOOKING
*.NXT  EQU *
*     INA           OTHERWISE BUMP WORD COUNT 
      LDB TSMFG     TEST TIME STAMP MESSAGE FLAG
      SSB 
      JMP INTSP     AREADY SET SO SKIP TEST 
      LDB DBFP1 
      JSB TSMPT     TEST FOR TIME STAMP LINE
        JMP TSMSG       FOUND - PRINT MESSAGE 
INTSP LDA DBUFP,I   FETCH RECORD LENGTH 
      ALF,ALF       MOVE RECORD LENGTH TO 
      STA DBUFP,I   UPPER BYTE
      ALF,ALF 
      ADA DBFP1     ADD PREVIOUS POINTER
      LDB DBUFP       GET OLD POINTER IN CASE OF DOUT ERROR 
      STA DBUFP     SET NEW POINTER 
      CMA           CHECK FOR AVAILABLE ROOM
      ADA DBEND     TO END OF BUFFER. 
      SSA,INA,RSS   END OF OUTPUT BUFFER? 
      JMP NXTRC     NO, READ NEXT RECORD
      STB DBPSV     SAVE THE OLD POINTER
      STA DBFP1     STORE NUMBER OF WORDS OF OVERFLOW 
      JSB DOUT      OUTPUT BUFFER 
        JMP INSER     ERROR - GO FIX UP AND QUIT
      LDA DBFP1     NO OVERFLOW 
      SZA,RSS       SO CONTINUE 
      JMP NXTRC     WITH READ 
      LDB DBEND     OTHERWISE FETCH OVERFLOW ADDRESS
OVMVR LDA B,I       MOVE
      STA DBUFP,I    BUFFER 
      INB             OVERFLOW
      ISZ DBUFP        INTO 
      ISZ DBFP1         BEGINNING OF BUFFER 
      JMP OVMVR 
      JMP NXTRC     READ NEXT RECORD
* 
DBPSV BSS 1 
* 
INSER LDA DBPSV     GET THE SAVE BUFFER POINTER 
      STA DBUFP     RESET 
ISER1 CCB 
      STB DBUFP,I       PUT IN EOF FLAG 
* 
***************** 
* 
*  LEAVE FILE OPEN WHILE WORKING ON IT <JDJ>
*    WE WILL CLOBBER DCB BUT RE-OPEN THIS OPEN FILE UPON EXIT 
* 
ENDFL EQU * 
      LDA EXFLG    GET EXCHANGE FLAG
      SSA 
      JMP ENFL1     FLAG SET -  ORGINAL FILE - SKIP CLOSE 
*** 
      JSB CLOSS     CLOSE 
      DEF *+5         MERGED
      DEF SBUF$,I       FILE
      DEF RUBSH 
      DEF ZERO      TRUNCATE SIZE 
      DEF SCCR^,I   NAMR BLOCK FOR ERROR REPORT 
      SSA           ERROR FROM CLOSE? 
      JSB FMPER     YES, GO DO SOME CLAEN UP
      JMP INSRC,I   RETURN
* 
ENFL1 JMP INSRC,I   RETURN
* 
TSMSG CCA           SET TIME
      STA TSMFG       STAMP GIVE FLAG 
      JSB PRINT 
      DEF INTSP 
      DEC 13
      ASC 13,File will be time stamped. 
* 
TSMFG BSS 1 
* 
************************************* 
* 
*  TSMPT  TIME STAMP TEST - LOOKS FOR TIME STAMP
*     A REG - WORD COUNT
*     B REG - WORD ADDRESS
* 
*     RETURN AT P+1 IF FOUND - TPNTR IS BYTES ADDRESS OF DATE 
*     RETURN AT P+2 IF NOT FOUND
* 
TSMPT NOP           TIME STAMP TEST 
      CLE,ELB       MAKE RECODR ADDRESS A BYTE ADDESS 
      CLE,ELA       CONVERT WORD COUNT TO BYTE COUNT
      ADB A         BUMP TO END OF RECORD 
      ADB =D-1
      CCA 
      STA TPNTR     SET TO ALLOW ONE CHAR 
TSMP1 JSB .LBT      GET LAST BYTE 
      ADB =D-2      BUMP POINT BACK 1 CHAR
      CPA B40       A BLANK ? 
      JMP TSMP1       YES- TRY NEXT CHAR
      CPA ">"       CLOSING BROKET ?
      JMP TSMP2       YES - GO LOOK FOR TIME STAMP
      ISZ TPNTR     FIRST NO-MATCH CHAR ? 
      JMP TSMP0       NO - NOT FOUND
      JMP TSMP1       YES - TRY AGAIN 
* 
TSMP0 ISZ TSMPT     NOT FOUND - BUMP REUTRN 
      JMP TSMPT,I 
* 
TSMP2 ADB =D-11     BUMP BACK TO START OF STRING
      JSB .LBT      GET FIST CHAR OF POSSIBLE TIME STAMP
      CPA "<"       IS IT CORRECT ? 
      JMP TSMP3       YES - CONTINUE
      JMP TSMP0        NO - GIVE UP.
* 
TSMP3 STB TPNTR     SAVE BYTE ADDRESS OF START OF TIME STAMP
      LDA =D-11     SET UP LOOP COUNT 
      STA RUBSH 
TSMP4 JSB .LBT
      CPA "."       IS IT THE DATE TIME SEPERATOR ? 
      JMP TSMP5       YES - GO CHEACT FOR CORRECT POSITION
      CPA B40       ALSO ALLOW SPACE AS SEPERATOR 
      JMP TSMP5       YES - GO CHEACT FOR CORRECT POSITION
      JSB ASCII     IS IT A DIGIT ? 
      JMP TSMP0       NO  - GIVE UP 
      JMP TSMP6       YES - CONTIUNE
* 
TSMP5 LDA =D-5      IS DAY-HOUR SEPERATOR IN RIGHT PLACE
      CPA RUBSH 
      JMP TSMP6       YES - CONTINUE
      JMP TSMP0       NO -  GIVE UP 
* 
TSMP6 ISZ RUBSH     TEST LOOP COUNT 
      JMP TSMP4 
      JMP TSMPT,I   FOUND - RETURN AT P+1 
* 
TPNTR BSS 1         BYTTE POINTER TO START OF TIME STAMP
* 
DBFP1 BSS 1 
RUBSH NOP   ANYTHING I DON'T WANT GOES HERE 
B^BUF DBL  BUF
      SPC 1 
*     FMPER         PRINTS FILE MANAGER ERROR 
* 
FMPER NOP            A REG. IS SAVED
      STA FMPET 
      JSB ERCLN     GO DO ERROR CLEAN UP
      LDA FMPET 
      JMP FMPER,I 
* 
* 
FMPET BSS 1 
* 
      SPC 1 
FMPA  JSB FMPER      DO SOME ERROR CLEAN UP 
      JMP ENDFL     THEN ABORT THE READ 
* 
************************************************************
* 
ED%.M JSB CSTRP     ALLOW OPTIONAL COMMA
      JMP ERR       NAME MUST BE SUPPLIES OR IT A ERROR 
* 
      LDA ^LSNM     PUT PARSED NAMR LSNAM 
      JSB SC.CR     GET THE FILE NAME 
      JMP ERR       ERROR IF NO FILE NAME 
      CCA           SET MODIFIED FLAG 
      STA MODFG 
      JSB TR        SEND THE PENDING LINE 
      JSB UNDOD     SET FOR AN UNDO 
      JSB INSRC     FETCH THE FILE
      NOP           IGNOR NOT FOUND ERROR 
      SPC 1 
      JSB EXEC      NOW GET 
      DEF *+7       THE OLD SOURCE
      DEF I.1       BACK IN 
      DEF SVSLU     CORE
      DEF SBUF$,I 
      DEF SVSWC+0 
      DEF SVSTR+0 
      DEF SVSSC+0 
      JSB EXCER     REPORT ERROR
      SPC 1 
      JMP DISPL 
* 
      SPC 1 
LULOK NOP           LIST LU LOCKING/UNLOCKING ROUTINE.
ED%LK EQU LULOK 
      LDA LUCMD     GET THE CURRENT COMMAND.
      XOR .1        CONVERT TO OPPOSITE ACTION. 
      STA IOPT      CONFIGURE THE CALL. 
      IFZ 
      JSB REMCK     IF THE LIST DEVICE IS REMOTE, 
      JMP LULOK,I    THEN LOCKING IS NOT REQUIRED.
      XIF 
LOKIT JSB LURQ      REQUEST 
      DEF *+4        LOCK OR
      DEF IOPT        UNLOCK
      DEF LSTLU        FOR THE SPECIFIED
      DEF .1            LIST LOGICAL UNIT.
      JMP LKERR     REPORT THE ERROR. 
* 
      CPA M1        IF NO RN'S AVAILABLE, NOW,
      JMP NORNS      THEN GO REPORT 
      CPA .1        IF LOCKED BY ANOTHER, THEN
      JMP WAITL      GO BACK TO WAIT FOR IT.
      LDA IOPT      GET LOCK OPTIONT
      IOR =B100000  MAKE SURE THE NO WAIT BIT IS SET
      STA LUCMD     AND SAVE FOR UNLOCK NEXT TIME 
      JMP LULOK,I   LOCK/UNLOCK SUCCESSFUL--RETURN. 
* 
WAITL CLA           CLEAR OK FLAG 
      STA OKFLG         SO WE ARE SURE TO ASK 
      JSB PRINT 
      DEF WTLK1 
      DEC -30 
      ASC  15,Device is locked. Is waiting _
WTLK1 JSB ASK 
      LDA =B40001   INCLUDE NO-ABORT BIT, 
      STA IOPT       AND SET COMMAND: WAIT FOR LU/RN. 
      JSB .DFER     COPY NAME TO MESAGE 
        DEF NAME1 
        DEF NAME+0
      JSB PRINT     INFORM
      DEF LOKIT      THE USER 
      DEC 15          THAT WE MUST WAIT.
NAME1 ASC 15,edit  waiting for list device. 
* 
NORNS LDA "NO"
      LDB "RN"
LKERR STA LUMSG+7 
      STB LUMSG+9  CONFIGURE ERROR MESSAGE. 
      LDA LULOG     REPORT TO THE CONSOLE, INSTEAD, 
      STA LSTLU      DUE TO LIST-DEVICE PROBLEM.
      JSB PRINT     PRINT THE ERROR MESSAGE,
      DEF ERR       AND GO TO ERROR 
      DEC 10
LUMSG ASC 10,LU LOCK ERROR XX  XX 
"NO"  ASC 1,NO
"RN"  ASC 1,RN
* 
******* 
* 
DVR07 CCA           THIS IS USED A DATA (I DON'T WHAT BUT IT WORKS)!
DVR23 OCT 11400     MAG TAPE DRIVER CODE
      SPC 1 
* 
******************************
*  POST LIST FILE 
* 
ED%LP NOP 
      JSB POSTS 
        DEF LSST1 
        DEF LDCB+0
        DEF RUBSH 
        DEF LNAM+0  NAMR BLOCK FOR ERROR REPORT 
LSST1   SSA          ERROR ?
      JSB FMPER     GO DO ANY ERROR CLAEAN UP 
      JMP ED%LP,I    RETURN 
* 
* 
* 
* 
* .EFIX THINGS AFTER AN E COMMAND KILLED THEM 
* 
.EFIX NOP 
      JSB ERSTR     RESTORE OTHER STUFF 
      JMP ERR       NOT REPSOITION RIGHT - GIVE ERROR 
      LDA COMND     RESTORE A 
      JMP .EFIX,I   RETURN
* 
* 
* 
**********************************************
* 
*  EXIT CODE
* 
* 
ED%.E DLD T#REC     AND CURRENT POSITION
      DST E#REC 
      CCA 
      STA PANIC     SET PANIC FLAG IF NO TRACKS 
      JSB ./B$      COMPLETE XFER OF SOURCE TO DEST.
      CLA 
      STA PANIC     CLEAR THE FLAG
      JSB FILWR       DO FILE WRITE 
      JMP ./EER       ERROR RETURN
      JSB RALLT      RELEASE TRACKS 
      SPC 1 
* 
****** TERMINATION HERE ********
* 
ED%EX CLA           CLEAR 
      STA SPFLG     SPACES FLAG SO THING LINE UP
      JSB SETTY     CLOSE COMMAND FILE IF NEEDED
      JSB LCLOS     CLOSE OPEN LIST FILE
      JSB ECLOS     GO CLOSE  ER FILE 
      JSB PRINT     END OF EDIT MESSAGE 
       DEF EXEC6
       DEC 8
       ASC 8,end of edit
EXEC6 JSB EXEC
      DEF *+2 
      DEF .6
* 
./EER JSB .EFIX     GO FIX UP WORK SPACE
      JMP NODE1     GET NEXT COMMAND
       SPC 1
* 
******************************************************************* 
* ECLOS             CLOSE ER FILE   WITHOUT WRITE 
* 
ECLOS NOP 
      LDA ERFLG     GET THE THE ER FLAG 
      SZA,RSS         TEST IF WE MUST CLOSE THE SOURCE
      JMP EXOPE       NO SURCE GIVEN  - QUIT NOW
      ISZ SCFLG     TEST IF FILE WAS TO BE CREATED
      JMP *+2        NO - SO WE CAN CLOSE IT
      JMP EXOPE       NO FILE TO CLOSE - GO QIUT
      LDA ROFLG     TEST IF ER DCB IS GOOD
      SZA 
      JMP EXCLS      YES - JUST CLOSE IT. 
      CCA           SET FLAG
      STA ROFLG       SO WE DON'T GIVE OPEN MESSAGE 
      JSB OPENS      NO - MUST RE-OPEN IT 
      DEF *+8 
      DEF DBUF$,I 
      DEF RUBSH 
      DEF NBUF0+0    USE ORGINAL NAME 
      DEF ZERO
      DEF FSECW       AND SEC. CODE 
      DEF FCARW        AND CART.
      DEF .128
      SPC 1 
      CLB           CLEAR 
      STB ROFLG      ER FILE OPEN FLAG
      SSA           ERROR FROM OPEN?
      JMP EXOPE     YES, SKIP CLOSE - 
EXCLS JSB CLOSS      CALL TO CLOSE
      DEF *+5        OUTPUT 
      DEF DBUF$,I     FILE
      DEF RUBSH    ERROR BUCKET 
      DEF ZERO     TRUNCATE SIZE
      DEF NBUF0+0   NAMR BLOCK FOR ERROR REPORT 
      SPC 1 
EXOPE EQU * 
      JMP ECLOS,I   RETURN - IGNORE ERRORS
* 
*** 
* 
      SPC 1 
************************************************
* 
* 
* TURN SYSTEM PROMT BACK ON AFTER A POFF
* 
PON   NOP 
ED%PN EQU PON 
* 
      LDA TTYLU 
      AND B77 
      IOR CW20
      STA TEMP
      JSB EXEC
      DEF .QSX3 
      DEF I.3 
      DEF TEMP
.QSX3 JSB EXCER       REPORT ANY ERRORS 
      CLA 
      STA POFFG       CLEAR PROMPT OFF FLAG 
      JMP PON,I   RETURN
* 
CW21  OCT 2100       DISABLE TERMINAL'S INTERRUPT PROGRAM 
CW20  OCT 2000      ENABLE TERMINAL' INTERRUPT PROGRAM
LOPTN OCT 40001     LOCK WITH WAIT, NO ABORT
UOPTN OCT 40000      UNLOCK LU,NO ABORT 
******************************************************************
* 
* DO A CONTROL REQUEST TO DISABLE INTERRUPT PROGRAM SCHEDULEING 
* 
POFF  NOP 
ED%PF EQU POFF
      JSB LUTRU     GET SYSTEM LU FOR THIS TERMINAL 
        DEF POFF1 
        DEF LULOG 
POFF1   EQU * 
      CPA =D1       IS IT LU 1? 
      JMP POFF,I      YES - DON'T LOCK SYSTEM CONSOLES
      LDA LULOG 
      IOR CW21
      STA TEMP
      CCA           SET PROMT OFF FLAG
      STA POFFG 
      JSB EXEC
      DEF ./QSE 
      DEF I.3 
      DEF TEMP
./QSE JMP ERR       ERROR RETURN
* LOCK LU SO NO ONE ELSE CAN WRITE TO IT
      JSB LULOK 
      JMP POFF,I    RETURN
* 
************************************
* EFOLD - FOLD E BUFFER 
EFOLD NOP 
      LDA ELNG      GET LENGTH
      CMA,INA,SZA,RSS MAKE IT NEGITIVE, CHECK FOR ZERO
      JMP EFOLD       ZERO - RETURN NOW 
      STA TEMP      USE AS LOOP COUNT 
      LDB EBUFF     GET WORD ADDRESS
      CLE,ELB       MAKE IR A BYTE ADDRESS
EFLD1 JSB .LBT      GET A BYTE FOR E BUFFER 
      JSB LCASE     FOLD CASE 
      ADB M1        BUMP ADDRESS BACK TO WHERE IT WAS 
      JSB .SBT      REPLACE THE BYTE
      ISZ TEMP      CHECK LOOP COUNT
      JMP EFLD1       NOT DONE - LOOP 
      JMP EFOLD,I     DONE     - RETURN 
* 
DVR12 OCT 5000      LINE PRINTER TYPE CODE. 
DVR37 OCT 17400     HPIB TYPE CODE. 
DVR05 CLA             USED AS DATA
* 
******* 
* ED%TR   TRANSFER COMMAND
* 
* 
ED%TR LDA PATCH     IS THER ANYTHING MORE ON THE LINE ? 
      SZA,RSS 
      JMP .TR0      NO - SO OK
      CCA 
      ADA RCCNT     BUMP BACK THE COMMAND SEPERATOR 
      STA RCCNT 
      JSB FLLER     COPY NEXT COMMAND TO EBUFF FOR REPORTING
      JMP ERR 
.TR0  JSB SETOK     STRIP LAST SLASH
      JSB CSTRP 
      JMP ERR       NOTHING SO ERROR
      LDA ECCNT 
      INA 
      STA NRCNT     SAVE CURRENT POSITION FOR NAMR COUNT
      JSB EFOLD 
.TR1  JSB ECH 
        JMP .TR3
      CPA B40       A BLANK ? 
      JMP .TRBK        GO LOOK FO COLON 
      CPA COMMA     A COMMA 
      JMP .TR2      YES FOUND END OF NAMR 
      JMP .TR1      TRY NEXT CHAR 
* 
.TRBK JSB ECH 
       JMP .TR3 
      CPA B40       ANOTHER BLANK ? 
       JMP .TRBK       STRIP IT 
      CPA ":" 
       JMP .TR1     YES - MORE OF NAMR
.TR2  JSB PBKE      PUT BACK DELIMTER 
.TR3  JSB CSTRP     STRIP BLANKS, COMMA 
        NOP          IGNOR DEFAULT
      LDA ECCNT 
      STA NRLEN     SAVE CURRENT COUNT AS LENGTH FOR NAMR 
      JSB ECH 
        JMP .TR4
      CPA "Q"       QUITE 
      JMP .TRQ        YES GO SET FLAG 
      JMP ERR       ELSE ERROR
* 
.TRQ  CCA           SET 
      STA QUFLG       QUITE FLAG
.TR4  JSB ENDCK     MAKE SURE WE AT AT THE END
      JSB TNAMR     PARSE NAME
       DEF .TR5 
       DEF TNAME+0
       DEF EBUFF,I
       DEF NRLEN    LENGTH
       DEF NRCNT    COUNT 
.TR5   EQU *
      SSA 
      JMP ERR       YES - GO GIVE ERROR 
      LDA TNAME+3 
      AND =D3 
      SZA,RSS 
      JMP ERR 
      CPA =D1       LU ?
      JMP .TRLU       YES - GO SET UP 
      LDA TYOPN     IS THERE A COMMNAND FILE OPEN ? 
      SSA,RSS 
      JMP .TR8      NO - GO OPEN NEW ONE
      JSB CLOSS 
       DEF .TR7 
        DEF TYDCB+0 
        DEF NRCNT   ERROR BUCKET
        DEF ZERO    TRUCNACTE SIZE
        DEF TNAME   NAMR  FOR ERROR 
.TR7    EQU * 
      SSA 
      JMP NODE1     ERROR - GO ABORT COMMAND
.TR8  JSB OPENS     NO FILE GO OPEN IT
        DEF .TR9
        DEF TYDCB+0 
        DEF NRCNT 
        DEF TNAME+0 
        DEF ZERO
        DEF TNAME+4 
        DEF TNAME+5 
        DEF .128
.TR9  EQU * 
      SSA           ERROR ON OPEN ? 
      JMP NODE1       YES - SKIP COMAMND
      CCA 
      STA CTFLG     SET CLOSE COMMAND FILE FLAG 
      JSB ASK 
      CLA 
      STA CTFLG     CLEAR THE FLAG
      CCA           SET SIGN BIT OF TTYLU TO MEAN FILE
      STA TYOPN     SET THERES A COMMAND FILE OPEN FLAG 
      STA TTYLU 
      STA TTYDV 
.TREX LDA QUFLG 
      STA NOPRN     SET NO PRINT FLAG 
      JMP NODE1 
* 
.TRLU JSB ASK 
      LDA TNAME 
      SZA,RSS 
      JMP ERR 
      STA TTYLU     SAVE AS INPUT LU
      IOR =B400 
      STA TEMP
      JSB EXEC      REWIND THE LU 
        DEF ./QT1 
        DEF I.3       CONTROL REQUEST - REWIND THE LU 
        DEF TEMP
./QT1   JMP ERR       REPORT ERROR IF THERE WAS ONE 
      LDA TTYLU 
      IOR B600      SET ECHO BITS 
      STA TTYLU 
      JSB TYPEQ     CHECK EQT TYPE
      LDA DVTY      RESET TYPE LU 
      STA TTYDV 
      JMP .TREX     GET NEXT COMMNAD
* 
NRLEN BSS 1 
NRCNT BSS 1 
* 
********************************* 
**
*  ED%RF            READ COMMAND FROM A FILE
* 
RFBUF BSS 1 
ED%RF NOP 
      JSB .ENTR 
        DEF RFBUF 
      JSB READS 
        DEF .RF1
        DEF TYDCB+0 
        DEF NRCNT 
        DEF RFBUF,I 
        DEF .75 
        DEF NRLEN 
        DEF TNAME+0 
.RF1    EQU * 
      SSA 
      JMP .RFER     ERROR - GO HANDLE 
      LDB NRLEN     GET LENGTH
      SSB           EOF ? 
      JMP .RFEF        YES  - USE ERROR RETURN
      CLE,ELB        MAKE IT BYTE COUNT 
      CLA 
      STA SPFLG 
      STB ELNG      SET AS LENGTH 
      LDA RFBUF 
      JSB LST       LIST LINE 
      CCA 
      STA SPFLG 
      CLA            MAKE SURE WE HAVE A ZERO IN A
      LDB ELNG       GET BACK LENGTH
.RF9  ISZ ED%RF      NO ERROR - BUMP RETURN 
      JMP ED%RF,I 
* 
.RFEF CCA           SET ALL BITS IN AREG
      CLB           CLEAR B REG 
      JMP .RF9      GO RETURN 
* 
.RFER CCA           PUT A -1 IN A 
      JMP ED%RF,I    RETURN 
* 
********* 
* 
*   CLOSE COMMAND FILE
* 
ED%TC NOP 
      JSB CLOSS 
        DEF .TYC1 
        DEF TYDCB+0 
        DEF NRCNT 
        DEF ZERO
        DEF TNAME+0 
.TYC1   EQU * 
      CLA           CLEAR 
      STA TYOPN       COMMAND FILE OPEN FLAG
      JMP ED%TC,I   RETURN
* 
* 
      SKP 
      HED NAMRT,7 2017 WHH NAMR typing routine
* 
* ROUTINE TO CALCULATE THE NAMR TYPE OF A 16 BIT QUANTITY 
* THIS ROUTINE IS USED BY ALL 'SH' UTILITIES SO THAT THEY ALL THINK 
*    THE SAME WAY AND APPEAR CONSISTENT TO THE USER 
* RETURNS 1 IF A NUMBER, 3 IF AN ALPHANUMERIC, 0 IF A NULL
* CALL IS:
*    <NAMR-TYPE-CODE> = NAMRT(VALUE)
* 
      ENT NAMRT 
      EXT .ENTR 
CHAR1 BSS 1 
CHAR2 BSS 1 
PARAM BSS 1         ;PARAMETER POINTER
NAMRT BSS 1 
      JSB .ENTR 
      DEF PARAM 
      LDA PARAM,I   ;IF ZERO, RETURN ZERO 
      SZA,RSS 
      JMP NAMRT,I 
      AND =B377     ;SEPARATE THE BYTES 
      STA CHAR2 
      LDA PARAM,I 
      ALF,ALF 
      AND =B377 
      STA CHAR1 
* 
* CHECK BOTH CHARACTERS TO MAKE SURE THAT THEY ARE APPROPRIATE
*    FOR ASCII DISPLAY
* 
      LDA CHAR1 
      ADA =D-33 
      AND =B177700
      SZA 
      JMP RET1
      LDA CHAR2 
      ADA =D-32 
      AND =B177700
      SZA,RSS 
      JMP RET3
RET1  CLA,INA,RSS   ;RETURN 1 
RET3  LDA =D3       ;RETURN 3 
      JMP NAMRT,I 
      SKP 
      HED CLUCR,7 2015 WHH Convert LU to CR 
* 
* ROUTINE TO CONVERT A LU TO ITS CARTRIDGE REFERENCE
* RETURNS -LU IF THE CARTRIDGE LIST DOES NOT CONTAIN THAT LU
*    (FOR MANY APPLICATIONS THIS IS SUFFICIENT) 
* CALL IS:
*    <CARTRIDGE> = CLUCR(<LU>)
* 
      ENT CLUCR 
      EXT .ENTR,FSTAT 
* 
* DO IT 
* 
LU    BSS 1 
CLUCR BSS 1 
      JSB .ENTR 
      DEF LU
      JSB FSTAT     ;GET CARTRIDGE LIST FOR THIS SESSION
      DEF *+5 
      DEF BUF 
      DEF BUFSZ 
      DEF ZERO      ;OLD FASHION FORMAT 
      DEF ZERO      ;THIS SESSION ONLY
* 
* TRY TO FIND THIS LU THERE 
* KEEP THE BUFFER POINTER IN B-REG
* 
      LDB ^BUF
LOOP  LDA 1,I       ;GET THE LU 
      SZA,RSS       ;END OF LIST? 
      JMP RETLU     ;YES, RETURN NEGATED LU 
      CPA LU,I      ;NO, COMPAIR LUS
      JMP FOUND     ;FOUND IT!
      ADB =D4       ;NO, BUMP POINTER 
      JMP LOOP      ;KEEP TRYING
* 
* HERE IF WE FIND THE LU IN THE CR LIST 
* 
FOUND ADB =D2       ;GET THE CARTRIDGE NAME 
      LDA 1,I 
      JMP CLUCR,I 
* 
* HERE TO RETURN NEGATED LU 
* 
RETLU LDA LU,I
      CMA,INA 
      JMP CLUCR,I 
* 
* DATA
* 
BUFSZ DEC 256       ;BUFFER SIZE
BUF   BSS 256       ;CARTRIDGE LIST BUFFER < 256 WORDS> 
BUFF0 EQU BUF 
^BUF  DEF BUF 
* 
* 
      SKP 
      HED PTFME,7 2015 WHH Put FMGR err in SCB
      ENT PTFME 
      EXT .ENTR,PTERR,.DIV
* 
*     FMGR ERROR CODE PRINTER 
*     CALL IS 
*         CALL PTFME(<INTEGER-ERROR-CODE>)
* 
ERROR BSS 1 
PTFME BSS 1 
      JSB .ENTR 
      DEF ERROR 
      LDA ERROR,I   GET ABSOLUTE VALUE OF ERROR 
      LDB 0 
      SSA 
      CMA,INA 
      STA ABS 
      LDA MSG1      DETERMINE SPACE OR MINUS
      SSB 
      LDA MSG2
      STA FMBUF+2 
      LDA ABS       GET HIGH DIGIT OF ERROR CODE
      CLB 
      JSB .DIV
      DEF D100
      STB ABS 
      ADA FMBUF+2 
      STA FMBUF+2 
      LDA ABS 
      CLB 
      JSB .DIV
      DEF D10 
      ALF,ALF 
      ADA 1 
      ADA MSG3
      STA FMBUF+3 
      JSB PTERR     PUT INTO SCB
      DEF *+2 
      DEF FMBUF 
      JMP PTFME,I   RETURN
MSG1  ASC 1, 0
MSG2  ASC 1,-0
MSG3  ASC 1,00
D100  DEC 100 
D10   DEC 10
FMBUF ASC 4,FMGRxxxx
ABS   BSS 1 
      SKP 
      HED ISHFT,8 2015 WHH Logical shift routine
      EXT .ENTR 
      ENT ISHFT 
* 
* FORTRAN FUNCTION TO DO A LOGICAL SHIFT
* CALL IS:
*       <SHIFTED-INTEGER-VALUE> = ISHFT(<INITIAL-VALUE>,<HOW-FAR>)
* IF SHIFTING DISTANCE IS > 0, SHIFT LEFT 
* IF SHIFTING DISTANCE IS = 0, DON'T SHIFT ANY
* IF SHIFTING DISTANCE IS < 0, SHIFT RIGHT
* 
* THE SHIFT DISTANCE IS ASSUMED TO BE IN THE RANGE -15 TO +15 
* NO ERROR IS GIVEN IF THE DISTANCE IS OUT OF RANGE 
* 
VAL   NOP 
FAR   NOP 
ISHFT NOP 
      JSB .ENTR     CLEAN ENTRY 
      DEF VAL 
      LDA FAR,I     FIND OUT WHICH DIRECTION TO GO
      SSA           RIGHT (DISTANCE < 0)? 
      JMP RIGHT     YES 
      SZA           NO, HOW ABOUT LEFT? 
      JMP LEFT      YES, GO LEFT
      LDA VAL,I     ZERO, RETURN VALUE UNCHANGED
      JMP ISHFT,I 
* 
* HERE TO SHIFT LEFT
* 
LEFT  AND =B17      BUILD LDL INSTRUCTION 
      IOR =B100040
      STA LSLXX 
      LDA VAL,I     DO IT 
LSLXX LSL 1 
      JMP ISHFT,I 
* 
* HERE TO SHIFT RIGHT 
* 
RIGHT CMA,INA       NEGATE HOW FAR
      AND =B17      AND BUILD A LSR INSTRUCTION 
      IOR =B101040
      STA LSRXX 
      LDA VAL,I 
      CLB 
LSRXX LSR 1         DO IT 
      JMP ISHFT,I 
***** 
* 
* 
      HED PASCAL/1000 TIME STRING HANDLER 
*     NAM TIME,7 92832-1X140 REV.2040 800611
********************************************************************* 
* 
* 
*  NAME:   TIME 
*  SOURCE: 92832-18140
*  RELOC:  92832-1X140
*  PGMR:   SKJ,JWS
* 
********************************************************************* 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.                       * 
* ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAMMING LANGUAGE WITHOUT * 
* THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.             * 
********************************************************************* 
* 
* 
* 
* 
* 
********************************************************************* 
* 
* 
*     ENT @TIME, @STMP
* 
*     EXT EXEC, .ENTR, .MVW 
* 
      SUP PRESS 
* 
AM    ASC 1,am
PM    ASC 1,pm
COLON ASC 1, :
DOT   ASC 1, .
D6    DEC 6 
D11   DEC 11
D13   DEC 13
DAYS  DEF *+1 
      ASC 14,Fri Sat Sun Mon Tue Wed Thu
MONTH DEF *-1 
      ASC 12,Mar Apr May Jun Jul Aug
      ASC 12,Sep Oct Nov Dec Jan Feb
* 
TIME  EQU * 
MSEC  BSS 1 
SEC   BSS 1 
MINUT BSS 1 
HOUR  BSS 1 
DAY   BSS 1 
YEAR  BSS 1 
* 
      SKP 
**********************************************************************
* 
*   @TIME     TIME STRING FOR PASCAL/1000 RUN-TIME LIBRARY
*   @STMP     TIME STAMP FOR PASCAL/1000 RUN-TIME LIBRARY 
* 
*   THESE ROUTINES RETURN THE TIME IN TWO DIFFERENT FORMATS 
* 
*   THE TIME STRING IS OF THE FORM: 
*      Thu May 24, 1979   2:52 pm 
* 
*   CALLING SEQUENCE
*      JSB @TIME
*      DEF *+2
*      DEF <26 character string>
* 
*   THE TIME STAMP IS OF THE FORM:
*      790524.1452
* 
*   CALLING SEQUENCE
*      JSB @STMP
*      DEF *+2
*      DEF <12 character string>
* 
*   ERRORS
*     NO ERROR CONDITIONS 
* 
***************************** 
* BASIC ALGORITHM FROM CLIB * 
**********************************************************************
      SKP 
* 
********************************* 
* ENTRY POINT TO GET TIME STAMP * 
********************************* 
* 
NAMS@ DEF @NAMS 
@NAMS BSS 6 
* 
STMPP BSS 1 
@STMP NOP 
      JSB .ENTR 
      DEF STMPP 
      JSB DOIT
      LDA NAMS@ 
      LDB STMPP 
      JSB .MVW
      DEF D6
      NOP 
      JMP @STMP,I 
* 
**********************************
* ENTRY POINT TO GET TIME STRING *
**********************************
* 
TIMS@ DEF @TIMS 
@TIMS BSS 5 
      ASC 2,, 19
      BSS 1 
      ASC 1,
      BSS 4 
* 
TIMEP BSS 1 
@TIME NOP 
      JSB .ENTR 
      DEF TIMEP 
      JSB DOIT
      LDA TIMS@ 
      LDB TIMEP 
      JSB .MVW
      DEF D13 
      NOP 
      JMP @TIME,I 
      SKP 
* 
**********************************
* ACTUAL TIME CONVERSION ROUTINE *
* GENERATES BOTH REPRESENTATIONS *
**********************************
* 
DOIT  NOP 
* 
* PICK UP THE TIME INFORMATION, THEN FORMAT IT
* 
      JSB EXEC
      DEF *+4 
      DEF D11 
      DEF TIME
      DEF YEAR
* 
* MINUTES FOR TIME STRING 
* 
      LDA MINUT 
      JSB ASCDI 
      LDB COLON      A <= MINS, B <= ' :' 
      IOR =B30000    PUT IN LEADING ZERO, IF NECESSARY
      STA MINUT      SAVE MINUTES FOR TIME STAMP
      RRR 8          A <= ':', 10 MINS. B <= 1 MINS, ' '
      DST @TIMS+10   MINUTES TO TIME STRING 
* 
* AM OR PM FOR TIME STRING
* 
      LDA HOUR
      LDB PM
      ADA =D-12 
      SSA,RSS 
      JMP ITSPM 
* 
      LDB AM
      LDA HOUR
ITSPM STB @TIMS+12   AM OR PM TO TIME STRING
* 
* HOURS FOR TIME STRING 
* 
      SZA,RSS       MIDNIGHT? 
      LDA =D12      YES 
      JSB ASCDI 
      STA @TIMS+9   HOUR TO TIME STRING 
* 
* HOURS AND MINUTES FOR TIME STAMP
* 
      LDA HOUR      WANT 24 HOUR TIME WHICH MIGHT 
      JSB ASCDI     HAVE BEEN 'CORRECTED' OUT ABOVE 
      LDB DOT 
      IOR =B30000   PUT IN LEADING ZERO IF NECESSARY
      RRR 8         A <= '.', 10 HRS. B <= 1 HRS, ' '.
      STA @NAMS+3   '.' AND 10 HRS TO TIME STAMP
      BLF 
      BLF           B <= ' ', 1 HRS.
      LDA MINUT     A <= MINS.
      RRR 8         A <= 1 HRS, 10 MINS. B <= 1 MINS, ' '.
      DST @NAMS+4   1S OF HRS, 10S OF MINS, 1S OF MINS, ' ' TO TIME STAMP 
* 
* YEAR
* 
      LDA YEAR
      ADA =D-1900 
      JSB ASCDI 
      STA @TIMS+7   YEAR TO TIME STRING 
      STA @NAMS+0   YEAR TO TIME STAMP
* 
* DAY & MONTH 
* 
      LDB DAY 
      ADB =D-60 
      LDA YEAR
      AND =D3 
      SZA 
      SSB 
      ADB =D-1
      SSB 
      ADB =D366 
      ADB =D31
      LDA B 
      RAL,RAL 
      ADA B 
      CLB 
      DIV =D153 
* 
      STA TIME     SAVE THE MONTH FOR A WHILE 
      LDA B 
      CLB 
      DIV =D5 
      INA 
      JSB ASCDI 
      STA @TIMS+4  DATE TO TIME STRING
      IOR =B30000  LEADING ZERO?
      STA @NAMS+2  DATE TO TIME STAMP 
* 
* MONTH FOR TIME STRING 
* 
      LDB TIME
      BLS 
      ADB MONTH    INDEX INTO MONTH TABLE 
      DLD B,I 
      DST @TIMS+2  MONTH TO TIME STRING 
* 
* MONTH FOR TIME STAMP
* 
      LDA TIME     FOR TIME STAMP 
      ADA =D-11 
      SSA          JAN, FEB  0,1
      ADA =D12     MAR..DEC  -10..-1
      INA 
      JSB ASCDI 
      IOR =B30000  LEADING ZERO 
      STA @NAMS+1  MONTH TO TIME STAMP
* 
* DAY OF THE WEEK FOR TIME STRING 
* 
      CCA 
      ADA YEAR
      ARS,ARS 
      ADA YEAR
      ADA DAY 
      CLB 
      DIV =D7 
      BLS 
      ADB DAYS     INDEX INTO DAY TABLE 
      DLD B,I 
      DST @TIMS    STUFF IT INTO TIME BUFFER
* 
* RETURN
* 
      JMP DOIT,I   RETURN 
* 
**************************
* DIGIT TO ASCII ROUTINE *
**************************
* 
ASCDI NOP 
      CLB 
      DIV =D10
      SZA 
      ADA =A 0
      ALF,ALF 
      ADA B 
      IOR =A 0
      JMP ASCDI,I  RETURN 
* 
      END EDIT0 
                                      