ASMB,R,L,C
      HED "%WRIS" RTE SOURCE FILE WRITE IN "LS" FORMAT
* 
*     NAME:   %WRIS 
*     SOURCE: 92068-18003 
*     RELOC:  PART OF 92067-16268 AND 92067-16035 
*     PGMR:   R.A.G.
* 
*  ***************************************************************
*  * (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.       *
*  ***************************************************************
* 
      NAM %WRIS,7 92068-1X003 REV.2013 750701   
      ENT %WRIS,%WRIN,%WEOF 
      EXT EXEC
      SPC 1 
      SPC 1 
*  PURPOSE: 
*    THIS ROUTINE WILL WRITE SOURCE DATA ON AN RTE DISC IN "LS" 
*    FORMAT.
      SPC 1 
*  USES:
*    THIS ROUTINE IS USED BY COMPILERS, EDITORS, ASSEMBLERS TO
*    WRITE SOURCE ONTO A DISC SUCH THAT THEY CAN READ IT OVER 
*    AGAIN FOR ANOTHER PASS OF THE SOURCE.  THE DATA IS WRITTEN 
*    IN " LS " FORMAT AND THE TRACKS ARE OWNED BY THE CALLING 
*    PROGRAM.  THE CALLING PROGRAM SHOULD RELEASE THE TRACKS
*    WHEN IT IS DONE WITH THEM. 
      SPC 1 
*   CALLED: 
*     ASSEMBLY ONLY 
*              JSB %WRIN     INITIALIZES
*            <ERROR RETURN>  NO DISC SPACE A=-1 
*              <RETURN>      A-REG = !15 DISCLU 8!7 TRACK# 0! 
* 
*     ASSEMBLY ONLY 
*       IF BUFFER LENGTH IS = 0, THEN IMBEDDED FILE MARK IS WRITTEN 
*       IF BUFFER LENGTH IS > 0, THEN TRUE END OF FILE MARK IS WRITTEN
*       IF BUFFER LENGTH IS < 0, THEN -(BUFLN-1)/2 WORDS ARE WRITTEN
*              JSB %WRIS     WRITES RECORD ON DISC
*              DEF *+4       GOOD RETURN
*              DEF BUFFR     POINTER TO 1ST WORD OF BUFFER
*              DEF BUFLN     NEG. NUMBER OF CHARS IN BUFFER 
*            <ERROR RETURN>  SORRY OUT OF DISC SPACE
*              <RETURN>      A-REG. = LAST WRITTEN LU/TRACK 
*     ASSEMBLY ONLY 
*              JSB %WEOF     WRITES OUT AN END OF FILE MARK 
*              <RETURN>      A-REG  = SAME AS %WRIS 
      SPC 1 
*  RETURN:
*           A-REG = DISC LOGICAL UNIT IN BITS 7-8 (LU= 2 OR 3)
*                   TRACK NUMBER IN BITS 0-7 (TRACK = 0 TO 255) 
*                   -1 IF NO TRACK AVAILABLE
      SPC 1 
*  NOTES: 
*    THE " %WRIN " ENTRY POINT IS IN THIS ROUTINE PRIMARLY TO 
*    RE-INITIALIZE A NEW FILE WRITE TO THE DISK.  THE " %WEOF " 
*    ENTRY POINT IS TO WRITE A FILE MARK AND POST THE IN MEMORY 
*    BUFFER.  A FILE MARK WRITE WITH " %WRIS " WILL WRITE A FILE
*    MARK, BUT WILL NOT POST THE POSSIBLE IN MEMORY BUFFER. 
*    CAUTION!, ALWAYS SPECIFY AN EVEN CHARACTER COUNT (OR PAD ODD 
*    CHARACTER COUNT WITH TRAILING SPACE) WHEN WRITTING A RECORD. 
*    THIS ROUTINE WILL WRITE ASCII RECORDS ON PROGRAM OWNED 
*    TRACKS OF AN RTE SYSTEM IN "LS" FORMAT.  THE BASE PAGE 
*    LS POINTER IS NOT SET HOWEVER. 
      SPC 1 
*  ERRORS:
*    THE ERROR RETURN FROM " %WRIS " IS NOT RECOVERABLE, THEREFORE
*    ANY TRACKS WRITTEN ON BEFORE SHOULD BE GIVEN BACK TO SYSTEM
      SPC 1 
%WRIS NOP           ENTRY FOR UNIT RECORD WRITE 
      LDA %WRIS,I   GET NORMAL RETURN ADDRESS 
      STA GEXIT     SAVE IN GOOD EXIT 
      ISZ %WRIS 
      LDB %WRIS 
      LDB B,I       GET WRITE BUFFER ADDRESS
      RBL,CLE,SLB,ERB TRACK DOWN INDIRECTS
      JMP *-2 
      ISZ %WRIS     GET THE LENGTH OF BUFFER IN NEG.
      LDA %WRIS,I   CHARACTERS, OR 0 IF IMBEDDED FILE MARK
      LDA A,I       OR >1 IF TRUE END OF FILE.
      ARS           CONVERT TO -WORDS.
      JSB WRITE     WRITE THE RECORD ON DISC
      JMP %WRIS,I   ERROR RETURN (OUT OF DISC SPACE)
      JMP GEXIT,I   GOOD RETURN A=LS WORD. (LU*256+TRACK) 
      SPC 1 
GEXIT NOP 
      SPC 1 
%WRIN NOP           INITIALIZATION ENTRY POINT FOR NEW FILE 
      JSB GETRK     GET A TRACK FROM SYSTEM 
      JMP %WRIN,I   NO DISC SPACE EXIT
      ISZ %WRIN     BUMP TO GOOD EXIT 
      JSB MFTAS     MOVE FORWARD TRACK AND SECTOR NUMBERS 
      JSB POST      SET-UP BUFFERS & COUNTERS 
      JMP %WRIN,I   GOOD EXIT A=LS WORD (DISKLU*265+TRACK#) 
      SPC 1 
%WEOF NOP           WRITE TRUE END OF FILE MARK 
      CLA,INA       SET BUFFER LEN POSITIVE 
      JSB WRITE     GO WRITE FILE MARK
      JMP *-2       IF OUT OF DISC TRY AGAIN
      JSB POST      FORCE WRITE OF IN CORE BUFFER 
      JMP %WEOF,I   A=LAST TRACK+DISC LU
      SPC 1 
WRITE NOP           ENTRY A=-WORD COUNT,B=BUFFER ADDRESS
IFST  JMP FIRST     CHECK IF 1ST CALL TO %WRIN
      STB SBUFR     SAVE SOURCE BUFFER ADDRESS
      CCB           SET B=-1
      ADA B         DECREMENT A-REG 
      CLB           SET UP B, JUST IN CASE
      SSA,RSS       CHECK IF WAS > 0? 
      CCA,RSS       YES, FORCE FILE MARK
      STA B         SAVE IN B 
      CMB           B= WORD COUNT 
      BLF,BLF       POSITION FOR HEDDER WORD ON DISC
      STA SRCNT     SAVE A FOR # WORDS PUT ON DISC
      JMP BEGRC     BEGIN RECORD WRITE
      SPC 1 
MORE  LDB SBUFR,I   GET NEXT WORD FROM CALLER 
      ISZ SBUFR     BUMP ADDRESS TO NEXT WORD 
BEGRC STB DSBFR,I   PUT IN DISC BUFFER
      ISZ DSBFR     BUMP ITS POINTER
      ISZ DSCNT     DISC BUFFER FULL? 
      JMP BUFNF     NO, BUFFER NOT FULL 
      LDA SECTR     YES, CHECK IF LAST SECTR ON TRACK 
      ADA D2        BUMP BY TWO 
      CPA SE/TK     EQUAL TO NUMB SECTRS PER TRACK? 
      JMP EOTRK     YES, PROCESS END OF TRACK 
      JSB POST      NO, POST THE SECTOR 
      STA SECTR     UPDATE THE SECTOR WORD
      JMP BUFNF     CONTINUE ON 
      SPC 1 
EOTRK STB WRIT1     SAVE LAST WORD ON TRACK 
      JSB GETRK     GET ANOTHER TRACK 
      JMP WRITE,I   NO TRACKS, ERROR RETURN 
      STA BUFFR+127 SAVE NEW TRACK ADDR IN LAST 
      STA LUNTR     WORD OF OLD TRACK+LET CALL KNOW 
      JSB POST      WRITE OUT LAST SECTOR OF OLD
      JSB MFTAS     MOVE FORWARD NEW TRACK ADDRESS
      LDB WRIT1     GET THE WORD THAT MISSED
      JMP BEGRC     STORE IT IN 1ST WORD OF NEW TRACK 
      SPC 1 
BUFNF ISZ SRCNT     MORE WORDS IN CALLERS BUF?
      JMP MORE      YES 
      LDA LUNTR     NO, RETURN A= DISCLU*256+TRACK
      ISZ WRITE     GOOD RETURN P+2 
      JMP WRITE,I 
      SPC 1 
SBUFR NOP 
SRCNT NOP 
DSBFR NOP 
DSCNT NOP 
D2    DEC 2 
WRIT1 NOP 
LUNTR NOP 
      SPC 1 
POST  NOP           WRITE OUT THE 128 WORD SECTOR 
      STA POST1     SAVE THE A-REG
      JSB EXEC      EXEC>>DO IT 
      DEF *+7 
      DEF D2        WRITE 
      DEF OLDLU     DISC LOGICAL UNIT 
DEFBF DEF BUFFR 
      DEF D128      128 WORDS 
      DEF OLDTK     TRACK ADDRESS 
      DEF SECTR     SECTOR ADDRESS
      LDA DEFBF     RESET THE DISC BUFFER 
      STA DSBFR 
      LDA DM128     AND THE COUNT 
      STA DSCNT 
      LDA POST1     RESTORE A-REG 
      JMP POST,I    RETURN
      SPC 1 
POST1 NOP           TEMP FOR POST ROUTINE 
D128  DEC 128 
DM128 DEC -128
      SPC 1 
MFTAS NOP           ROUTINE TO BRING FORWARD GETRK'S
      LDB NEWTK     DISC ADDRESSES
      STB OLDTK     TRACK ADDRESS 
      LDB NEWLU     DISC LU 
      STB OLDLU 
      CLB           SECTOR ADDRESS
      STB SECTR 
      JMP MFTAS,I   RETURN
      SPC 1 
OLDTK NOP 
NEWTK NOP 
OLDLU NOP 
NEWLU NOP 
SECTR NOP 
SE/TK NOP 
      SPC 1 
GETRK NOP           ROUTINE TO GET A TRACK FROM SYSTEM
      JSB EXEC      REQUEST TRACK WITHOUT WAIT
      DEF *+6 
      DEF D4        PROGRAM OWNED TRACK 
      DEF NUMTK     ONE TRACK, NO WAIT
      DEF NEWTK     RETURNED TRACK NUMBER 
      DEF NEWLU     DISC LU NUMBER 2 OR 3 
      DEF SE/TK     NUMBER SECTORS PER TRACK
      LDA NEWTK     GET THE TRACK # OR -1 IF NONE 
      LDB NEWLU     GET DISC LU 
      BLF,BLF       POSITION
      IOR B         MIRGE IN WITH TRACK NUMBER
      SSA,RSS       CHECK IF GOT ONE? 
      ISZ GETRK     YES, P+2 EXIT 
      JMP GETRK,I   NO, P+1 EXIT
      SPC 1 
NUMTK OCT 100001
D4    DEC 4 
BUFFR BSS 128 
      ORG BUFFR 
      OCT -1
FIRST STA SAVA
      STB SAVB
      LDA %WRIN     CHECK IF EVER CALLED
      SZA 
      JMP SKIP
      JSB %WRIN     INITIALIZE 1ST TIME 
      JMP WRITE,I   ERROR EXIT
SKIP  CLA 
      STA IFST      NO MORE CALLS 
      LDA SAVA      RESTORE REGISTERS 
      LDB SAVB
      JMP IFST+1
      SPC 1 
SAVA  NOP 
SAVB  NOP 
      ORR 
A     EQU 0 
B     EQU 1 
      END 
* 
*