         TITLE 'DOS-11 tape reader'
*++
*
* -*-ASMH-*-
*
* Program to read DOS-11 magtapes on MTS.
*
* JMBW   Nov 24/90   Created.
*
*--
T        EQU   0                  ;AC def's
A        EQU   1
B        EQU   2
C        EQU   3
D        EQU   4
E        EQU   5
F        EQU   6
G        EQU   7
RC       EQU   15                 ;return code from JSYS's
*
         MACRO
&LAB     JSYS  &DEST,&ARGS,&ERR   ;Jump to SYStem
&LAB     L     15,=V(&DEST)
         AIF   ('&ARGS' EQ '').NOARGS
         LA    1,&ARGS
.NOARGS  BASR  14,15
         AIF   ('&ERR' EQ '').NOERR
         LTR   RC,RC
         BNZ   &ERR
.NOERR   MEND
*
DOS11    CSECT
         ENTER 12,SA=REGS
* see if term is a Courier (no square brackets)
         JSYS  GETFD,=C'*MSINK* ' ;SPRINT might be redirected
         ST    T,DUMMY            ;save
         JSYS  CONTROL,=A(SNSBUF,SNSLEN,DUMMY,0) ;sense *MSINK*
         L     T,DUMMY            ;get FDUB ptr back
         JSYS  FREEFD             ;lose it
         CLC   SNSDVTYP(3),=C'327' ;Courier or 327X?
         BNE   NOTEBC             ;no, leave brackets alone
           MVC BRACK(2),=C'()'    ;change to parens
*
NOTEBC   JSYS  GETFD,=C'*MT* '    ;get FDUB ptr
         ST    T,TAPEFD           ;save
*+
*
* Command loop.
*
*-
LOOP     JSYS  SETPFX,=A(PROMPT)  ;set prefix
         MVC   CMD(80),=CL80' '   ;blank out command line
         JSYS  GUSER,=A(CMD,LEN,@UC,DUMMY),STOP ;read a line
         JSYS  SETPFX,=A(BLANK)   ;blank prefix
         CLI   CMD,C'D'           ;directory?
         BE    DIR
         CLI   CMD,C'G'           ;get tape file?
         BE    GET
         CLI   CMD,C'R'           ;rewind tape?
         BE    REW
         B     LOOP               ;loop
STOP     JSYS  FREEFD,=A(ATPFD)   ;release tape
         JSYS  EXIT
*+
*
* Display tape directory.
*
*-
DIR      JSYS  READ,=A(BUF,LEN,ZERO,DUMMY,TAPEFD),LOOP ;get label
* display directory record
         BAL   F,DIRNAM           ;get name from dir. ent
         MVC   LINE+25(15),=C'<  X>  0X-XXX-0' ;set up field
         XR    A,A                ;prot. code
         IC    A,BUF+8
         LA    C,LINE+29
         BAL   E,DEC
* date is (year-1970.)*1000.+(day within year)
         XR    G,G                ;date
         IC    G,BUF+10
         ICM   G,2,BUF+11
         XR    F,F
         D     F,=F'1000'         ;remove year (leave day in F)
         AH    G,=H'70'           ;+1970.
         LR    C,G                ;copy
         XR    B,B
         D     B,=F'100'          ;make sure we pass 2000. OK
         LR    A,B                ;get rem (=year within century)
         MVI   DAYS+1,X'1C'       ;(28) assume not leap year
         N     B,=F'3'            ;check low 2 bits
         BNZ   NOLEAP             ;nope
           MVI DAYS+1,X'1D'       ;(29) leap year
NOLEAP   LA    C,LINE+41
         BAL   E,DEC
         LA    A,MONTHS           ;pt at months
         LA    B,DAYS             ;no. of days in each
MONLP    XR    T,T                ;get # days in this month
         IC    T,0(B)
         CLR   F,T                ;is this the right month?
         BLE   GOTMON             ;yes, skip
         SR    F,T                ;no, subtract it
         LA    A,3(A)             ;advance ptrs
         LA    B,1(B)
         B     MONLP              ;loop
GOTMON   MVC   LINE+35(3),0(A)    ;copy month name
         LR    A,F                ;get day within month
         LA    C,LINE+34
         BAL   E,DEC              ;write it
* display the whole mess on SPRINT
         MVC   LEN,=H'41'         ;length
         JSYS  SPRINT,=A(LINE,LEN,ZERO,DUMMY) ;print it
* skip the data records
         XR    C,C                ;init count
SKPDAT   JSYS  READ,=A(BUF,LEN,ZERO,DUMMY,TAPEFD),SKPDON ;read
         XR    A,A                ;zap
         ICM   A,3,LEN            ;get length of this one
         AR    C,A                ;add to total
         B     SKPDAT             ;loop
SKPDON   MVC   LINE(17),=C'            bytes'
         LR    A,C                ;get byte count
         LA    C,LINE+11
         BAL   E,DEC
         MVC   LEN,=H'17'         ;length
         JSYS  SPRINT,=A(LINE,LEN,ZERO,DUMMY)
         B     DIR
*+
*
* Get a tape file.
*
*-
GET      JSYS  READ,=A(BUF,LEN,ZERO,DUMMY,TAPEFD),FNF ;get label
         BAL   F,DIRNAM           ;get name
* see if this is it
         CLC   LINE(25),CMD+2     ;is this the file?
         BE    RFILE              ;yes, go read it
* no, skip data
GET5     JSYS  READ,=A(BUF,LEN,ZERO,DUMMY,TAPEFD)
         LTR   RC,RC              ;tape mark?
         BZ    GET5               ;no, skip
         B     GET                ;try next dir entry
FNF      JSYS  SERCOM,=A(NOSUCH,LNOSUC,ZERO,DUMMY)
         B     LOOP               ;loop
* got it - actually read the file
RFILE    JSYS  SETPFX,=A(QUES)    ;set prompt
         MVC   CMD(80),=CL80' '   ;blank out filename
         JSYS  GUSER,=A(CMD,LEN,ZERO,DUMMY)
         JSYS  SETPFX,=A(BLANK)   ;back to blank
         JSYS  GETFD,CMD          ;get FDUB ptr
         ST    T,FILEFD           ;save it
         XR    C,C                ;init count
RFILE1   JSYS  READ,=A(BUF,LEN,ZERO,DUMMY,TAPEFD),RFILE2 ;get rec
         XR    A,A                ;get length
         ICM   A,3,LEN
         AR    C,A                ;add it in
         JSYS  WRITE,=A(BUF,LEN,ZERO,DUMMY,FILEFD) ;write a rec
         B     RFILE1             ;loop
RFILE2   JSYS  FREEFD,=A(AFLFD)   ;close the file
         MVC   LINE(29),=C'            bytes transferred'
         LR    A,C                ;get count
         LA    C,LINE+11
         BAL   E,DEC
         MVC   LEN,=H'29'         ;set length
         JSYS  SPRINT,=A(LINE,LEN,ZERO,DUMMY)
         B     LOOP               ;back to loop
*+
*
* Rewind the tape.
*
*-
REW      L     T,TAPEFD           ;get FDUB ptr
         XR    A,A                ;differentiate from name
         JSYS  REWIND#            ;rewind the tape
         B     LOOP
*+
*
* Convert directory entry in BUF into
* bFILENAME.EXT[p,pn] at LINE.
*
*-
DIRNAM   LA    D,LINE             ;pt at line buf
         MVC   0(25,D),=CL25' '   ;zap out filename
         LA    D,1(D)             ;skip carriage control
         IC    A,BUF              ;fn1-3
         ICM   A,2,BUF+1
         BAL   E,RAD50
         IC    A,BUF+2            ;fn4-6
         ICM   A,2,BUF+3
         BAL   E,RAD50
         IC    A,BUF+12           ;fn7-9
         ICM   A,2,BUF+13
         BAL   E,RAD50
         MVI   0(D),C'.'          ;extension
         LA    D,1(D)
         IC    A,BUF+4            ;ex1-3
         ICM   A,2,BUF+5
         BAL   E,RAD50
         IC    T,BRACK            ;[
         STC   T,0(D)
         XR    A,A                ;proj
         IC    A,BUF+7
         LA    C,4(D)
         BAL   E,DEC
         MVI   4(D),C','          ;,
         XR    A,A                ;prog
         IC    A,BUF+6
         LA    C,8(D)
         BAL   E,DEC
         MVC   8(1,D),BRACK+1     ;]
* remove blanks
         LA    A,LINE             ;pt at line
         LA    B,25               ;length
         LR    C,A                ;output ptr
         LR    D,B                ;output len
RMBL1    CLI   0(A),C' '          ;blank?
         BE    RMBL2              ;yes, skip
         MVC   0(1,C),0(A)        ;copy char
         LA    C,1(C)             ;bump output ptr
         BCTR  D,0                ;count the char
RMBL2    LA    A,1(A)             ;bump ptr
         BCT   B,RMBL1            ;loop
RMBL3    MVI   0(C),C' '          ;blank out rest of field
         LA    C,1(C)
         BCT   D,RMBL3
         BR    F
*+
*
* Convert a radix-50 word to EBCDICK.
*
* Enter with word in A.
* Save 3 characters at D (update ptr).
*
*-
RAD50    N     A,=F'65535'        ;isolate low halfword
         XR    T,T                ;sign-extend
         D     T,=F'40'           ;/octal 50
         LR    C,T                ;get remainder (3rd char)
         XR    T,T                ;sign-extend
         D     T,=F'40'           ;/octal 50
         LR    B,T                ;copy rem to non-zero AC
         IC    T,R50(A)           ;first chr
         STC   T,0(D)
         IC    T,R50(B)           ;2nd
         STC   T,1(D)
         IC    T,R50(C)           ;3rd
         STC   T,2(D)
         LA    D,3(D)             ;bump ptr
         BR    E
*+
*
* Convert a number in A.
* Write it backwards at C.
*
*-
DEC      XR    T,T                ;sign-extend
         D     T,=F'10'           ;/10
         BCTR  C,0                ;-1
         STC   T,0(C)             ;save
         OI    0(C),C'0'          ;convert
         LTR   A,A                ;anything left?
         BNZ   DEC                ;loop if so
         BR    E
* pure data
         LTORG                    ;lits first
SNSLEN   DC    H'56'              ;length of SNS buffer
ZERO     DC    F'0'               ;modifier
@UC      DC    XL4'00000020'      ;@UC
R50      DC    C' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.%0123456789'
MONTHS   DC    C'JanFebMarAprMayJunJulAugSepOctNovDec'
ATPFD    DC    A(TAPEFD)          ;ptr to TAPEFD
AFLFD    DC    A(FILEFD)          ;ptr to FILEFD
PROMPT   DC    C'>'
QUES     DC    C'?'
BLANK    DC    C' '
LNOSUC   DC    Y(L'NOSUCH)
NOSUCH   DC    C' ?Can''t find file or account'
* initialized data
DAYS     DC    AL1(31,28,31,30,31,30,31,31,30,31,30,31) ;patch Feb
BRACK    DC    C'[]'              ;change to () on EBCDICK term
* SENSE *MSINK* to see if it's an EBCDICK terminal
SNSBUF   DC    C'SNS'             ;sense *MSINK*
SNSMDSET DS    X                  ;=0 for terminals
SNSDVNAM DS    CL4                ;device name ('N001', &c.)
SNSDVTYP DS    CL4                ;device type ('VTP ', &c.)
SNSCUNAM DS    CL4                ;ctrl unit name ('NET0', &c.)
SNSCUTYP DS    CL4                ;ctrl unit type
SNSLAID  DS    CL4                ;line adapter ID ('DIAL', &c.)
SNSTRNAM DS    CL24               ;terminal name (yeah right)
SNSTRTYP DS    CL8                ;term type (Vol. IV)
* pure storage
LEN      DS    H                  ;I/O length halfword
LINE     DS    41C                ;directory output line
CMD      DS    80C                ;command line
*
DUMMY    DS    F                  ;line #'s returned here
TAPEFD   DS    F                  ;tape FDUB ptr
FILEFD   DS    F                  ;file FDUB ptr
REGS     DS    18F                ;R13 save area
BUF      DS    32767C             ;input buffer
*
         END   DOS11
