moshix.mvs/PC370_orig/Diskette/full/CBL/TESTCIO.ALC

	TITLE 'TESTCIO - PC/370 TEST COBOL SUBROUTINE I/O'
*
* AUTHOR.    Don Higgins.
* DATE.      11/13/87. (Copied and modified from PRINTDOC.ALC)
* REMARKS.   PC/370 COBOL SUBROUTINE TO READ FILE NAME PASSED FROM
*            COBOL and print it with page control.
*
* COPYRIGHT. None.  This is a public domain program.
*
* MAINTENANCE.
*
* 11/20/87 ADD SYNERROR CALL TO DISPLAY ANY I/O ERRORS AND EXIT
*          RELOCATE ROUTINE REQUIRED TO CONVERT DCB AND EXTERNAL
*          ADDRESS CONSTANTS TO V=R.  CLEAR R15 RETURN CODE.
* INPUT
*
*  1.  CALL 'TESTCIO' USING FILE-NAME.
*
*      FILE-NAME = MS-DOS DRIVE\PATH\FILENAME WITH TRAILING BLANKS.
*
* OUTPUT
*
*  1.  File will be printed on the standard printer device with
*      page control added via TITLE, EJECT, and SPACE statements as
*      defined in standard OS/VS assembler.
*
TESTCIO  CSECT
	STM   R14,R12,12(R13)
	LR    R10,R15
	USING TESTCIO,R10
	L     R1,0(R1)
	MVC   DSNUT1,0(R1) MOVE FILE NAME TO WORK AREA
	LA    R2,=C'PC/370 TESTCIO FILE PRINT SUBROUTINE$'
	SVC   WTO
	LA    R2,=C' $'
	SVC   WTO
	BAL   R14,RELOCATE ADJUST DCB ADDRESSES TO ABS. ADDR.
	BAL   R14,GETPARM
	LTR   R15,R15
	BNZ   EOJ
	BAL   R12,OPENFILE
	LTR   R15,R15
	BNZ   EOJ
	LA    R1,ASCTITLE
	LA    R2,L'ASCTITLE+L'ASCEJECT+L'ASCSPACE
	SVC   EBCASC
	LA    R2,=C'ENTER P FOR PRINTER OUTPUT OR ANY KEY FOR CONSOLE$'
	SVC   WTO
	SVC   READKEY
	STC   R0,OPTION
MAINLOOP EQU   *
	BAL   R12,GETREC
	LTR   R15,R15         TEST FOR END OF FILE
	BNZ   ENDFILE
	BAL   R14,SCAN
	LTR   R15,R15         TEST FOR COMMAND AND SKIP PRINTING IT
	BNZ   MAINLOOP
	AP    LINE,=P'1'
	CP    LINE,MAXLINE
	BNH   NEXTLINE
	BAL   R11,NEWPAGE
NEXTLINE EQU   *
	LA    R0,RECORD
	BAL   R12,PUTREC
	B     MAINLOOP
ENDFILE  EQU   *
	BAL   R12,CLOSEFIL
EOJ      EQU   *
	LM    R14,R12,12(R13)
	XR    R15,R15
	BR    R14
	TITLE  'GETPARM - MOVE PARM TO DCB'
GETPARM  EQU   *
	LA    R1,DSNUT1
	LA    R2,L'DSNUT1
FNDBLK   EQU   *
	CLI   0(R1),C' '  FIND FIRST BLANK
	BE    HITBLK
	LA    R1,1(R1)
	BCT   R2,FNDBLK
	LA    R2,=C'NO BLANK FOUND AFTER FILENAME$'
	SVC   WTO
	LA    R15,16
	BR    R14
HITBLK   EQU   *
	MVI   0(R1),0     PLACE TRAILING NULL FOR OPEN
	SR    R15,R15
	BR    R14
	TITLE 'SCAN FOR TITLE, EJECT, AND SPACE COMMANDS'
SCAN     EQU   *
	CLI   RECORD,ASCBLK
	BE    SCANOP
	CLI   RECORD,ASCTAB
	BNE   SCANEXIT        EXIT IF FIRST CHAR. NOT BLANK OR TAB
SCANOP   EQU   *
	LA    R4,RECORD+1
SKIPBLK  EQU   *
	CLI   0(R4),ASCLF
	BE    SCANEXIT
	CLI   0(R4),ASCBLK
	LA    R4,1(R4)
	BE    SKIPBLK
	BCTR  R4,0
	CLC   0(5,R4),ASCTITLE
	BE    TITLE
	CLC   0(5,R4),ASCEJECT
	BE    EJECT
	CLC   0(5,R4),ASCSPACE
	BE    SPACE
SCANEXIT EQU   *
	SR    R15,R15
	BR    R14
TITLE    EQU   *
	LA    R4,5(R4)
FINDQ1   EQU   *
	CLI   0(R4),ASCBLK
	BL    SCANEXIT     IGNORE TITLE IF FIRST QUOTE NOT FOUND
	CLI   0(R4),ASCQ
	LA    R4,1(R4)
	BNE   FINDQ1
	LA    R3,TITLEMSG
	LA    R5,TITLEMSG+L'TITLEMSG
FINDQ2   EQU   *
	CLI   0(R4),ASCBLK
	BL    SETTITLE     TRUNCATE IF SECOND QUOTE NOT FOUND
	CLI   0(R4),ASCQ
	BE    SETTITLE
	CLR   R3,R5
	BNL   SETTITLE     TRUNCATE IF TOO LONG
	MVC   0(1,R3),0(R4)  COPY TITLE
	LA    R3,1(R3)
	LA    R4,1(R4)
	B     FINDQ2
SETTITLE EQU   *
	CLR   R3,R5
	BNL   EJECT
	MVI   0(R3),ASCBLK    PAD WITH BLANKS
	LA    R3,1(R3)
	B     SETTITLE
EJECT    EQU   *
	BAL   R11,NEWPAGE
	LA    R15,1
	BR    R14
SPACE    EQU   *
	LA    R0,SPACEMSG
	BAL   R12,PUTREC
	LA    R0,SPACEMSG
	BAL   R12,PUTREC
	AP    LINE,=P'2'
	LA    R15,1
	BR    R14
	TITLE 'NEWPAGE - PRINT HEADING'
NEWPAGE  EQU   *
	AP    PAGE,=P'1'
	ZAP   LINE,=P'0'
	MVC   DPAGE,MASK
	ED    DPAGE,PAGE
	MVC   PAGEMSG,PAGEWORK
	LA    R1,PAGEMSG
	LA    R2,L'PAGEMSG
	SVC   EBCASC
	LA    R0,HEADING
	BAL   R12,PUTREC
	MVI   HEADCC,ASCFF   FORCE FORM FEED AFTER FIRST PAGE
	LA    R0,SPACEMSG
	BAL   R12,PUTREC     SKIP SPACE AFTER TITLE
	BR    R11
	TITLE 'OPEN/CLOSE FILE ROUTINES'
*
* NOTE SYNAD EXIT WILL CALL SYNERROR TO FORMAT ERROR AND EXIT TO R12
*
OPENFILE EQU   *
	LA    R2,SYSUT1
	SVC   OPEN
	BR    R12
CLOSEFIL EQU   *
	LA    R2,SYSUT1
	SVC   CLOSE
	BR    R12
	TITLE 'GETREC - GET NEXT TEXT RECORD OR SET EOF'
GETREC   EQU   *
	LA    R2,SYSUT1
	LA    R1,RECORD
	SVC   GET
	SR    R15,R15
	BR    R12
EOFRTN   EQU   *
	LA    R15,1
	BR    R12
SYNRTN   EQU   *
	L     R15,ASYNERR
	BALR  R14,R15
	LA    R15,16
	BR    R12
	TITLE 'PUTREC - PUT RECORD TO STD. PRINT DEVICE'
PUTREC   EQU   *
	LR    R4,R0
PUTLOOP  EQU   *
	IC    R2,0(R4)
	CLI   0(R4),ASCTAB
	LA    R3,1
	BNE   PUTCHAR
	LA    R3,9
	LA    R2,ASCBLK
PUTCHAR  EQU   *
	SVC   CONSOLEC       PRINT ON CONSOLE
	CLI   OPTION,ASCP
	BE    ISUSVC
	CLI   OPTION,ASCPL
	BE    ISUSVC
	B     PUTSKPP
ISUSVC   SVC   PRINTC         PRINT ON STD. OUTPUT DEVICE ALSO
PUTSKPP  EQU   *
	BCT   R3,PUTCHAR
	CLI   0(R4),ASCLF
	LA    R4,1(R4)
	BNE   PUTLOOP
PUTEXIT  EQU   *
	SR    R15,R15
	BR    R12
RELOCATE EQU   *              CONVERT DCB ADDRESSES TO ABSOLUTE ADDR.
	CLI   RESET,TRUE     ONLY RELOCATE ONCE
	BER   R14
	MVI   RESET,TRUE
	LR    R1,R10
	SH    R1,=AL2(X'200')    R1 = ORIGIN USED BY L370 (BIN+X'10')
	LA    R2,SYSUT1
	USING IHADCB,R2
	LR    R0,R1
	A     R0,ASYNERR         R0 = ABS. ADDR. OF SYNERROR ROUTINE
	ST    R0,ASYNERR
	LR    R0,R1
	A     R0,DCBDSN          R0 = ABS. ADDR. OF DSN
	ST    R0,DCBDSN
	LR    R0,R1
	A     R0,SYNAD
	ST    R0,SYNAD
	LR    R0,R1
	A     R0,EODAD
	ST    R0,EODAD
	LR    R0,R1
	A     R0,RCD
	ST    R0,RCD
	DROP  R2
	BR    R14
	TITLE 'DATA SECTION'
	LTORG
*
* REGISTER USAGE
*
R0       EQU   0 SVC RETURN CODE
R1       EQU   1 SVC ARGUMENT
R2       EQU   2 SVC ARGUMENT (DCB ADDRESS, DMA, MSG, ETC.)
R3       EQU   3 POINTER FOR MOVING TITLE
R4       EQU   4 OUTPUT BYTE PTR FOR PUTREC
R5       EQU   5 END OF TITLE AREA
R10      EQU   10 BASE
R11      EQU   11 LINK FOR NEWPAGE
R12      EQU   12 LINK FOR GETREC AND PUTREC
R13      EQU   13 SAVE
R14      EQU   14 LINK FROM MAINLINE TO ROUTINES
R15      EQU   15 RETURN CODE FROM ROUTINES
*
* PC/370 SVC'S
*
EXIT     EQU   0
OPEN     EQU   1
CLOSE    EQU   2
GET      EQU   5
PUT      EQU   6
TRACE    EQU   9
GMAIN    EQU   10
FMAIN    EQU   11
ASCEBC   EQU   12
EBCASC   EQU   13
READKEY  EQU   200+1  MS-DOS SVC 1 READ KEY
CONSOLEC EQU   200+2  MS-DOS SVC 2 DISPLAY CHAR IN R2 ON CONSOLE
PRINTC   EQU   200+5  MS-DOS SVC 5 PRINT CHAR IN R2 ON STD. PRINTER
WTO      EQU   200+9  MS-DOS SVC 9 PRINT STRING WITH ENDING $ ON CON.
*
* DATA AREAS
*
RESET    DC    AL1(FALSE) SWITCH TO RELOCATE CODE ONLY ONCE
TRUE     EQU   1
FALSE    EQU   0
TBUFF    EQU   X'80'  BUFFER FOR DIRECTORY SEARCH
ASYNERR  DC    V(SYNERROR)  SYNAD ERROR MESSAGE ROUTINE
RECORD   DS    XL256   LOGICAL RECORD AREA
ASCLF    EQU   X'0A'   ASCII LINE FEED
ASCCR    EQU   X'0D'   ASCII CARRIAGE RETURN
ASCASK   EQU   X'2A'   ASCII ASTERISK FOR ALC COMMENT CHECK
ASCBLK   EQU   X'20'   ASCII SPACE
ASCQ     EQU   X'27'   ASCII QUOTE
ASCTAB   EQU   X'09'   ASCII TAB
ASCFF    EQU   X'0C'   ASCII FORM FEED
ASCP     EQU   X'50'   UPPERCASE ASCII P
ASCPL    EQU   X'70'   LOWER CASE ASCII P
OPTION   DC    X'00'
ASCTITLE DC    C'TITLE'
ASCEJECT DC    C'EJECT'
ASCSPACE DC    C'SPACE'
PAGE     DC    PL2'0'
LINE     DC    PL2'50'
MAXLINE  DC    PL2'50'
MASK     DC    X'40202020'  EDIT MASK FOR PL2
HEADING  EQU   *
HEADCC   DC    AL1(ASCBLK)
TITLEMSG DC    0CL65' ',65AL1(ASCBLK),2AL1(ASCBLK)
PAGEMSG  DC    0CL8' ',9AL1(ASCBLK)
SPACEMSG DC    AL1(ASCCR,ASCLF)     END OF HEADING
WORK     DC    0CL20' '
PAGEWORK DC    0CL8' ',C'PAGE'
DPAGE    DC    CL4' ZZZ'
DSNUT1   DC    CL64' '
	COPY  CPY\IHADCB
TESTCIO  CSECT
SYSUT1   DC    0F'0',C'ADCB'
	DC    A(DSNUT1)           PATH/FILE NAME IN PARM
	DC    X'FFFF'
	DC    X'00'
	DC    C'SGT'               SEQ. GET TEXT
	DC    X'0A1A'
	DC    H'255'               LRECL
	DC    H'8192'              BLKSZ
	DC    A(EOFRTN)            EODAD
	DC    A(SYNRTN)            SYNAD
	DC    A(RECORD)            RECORD AREA
	DC    XL(SYSUT1+LDCB-*)'00'
	END   TESTCIO