RMAC TITLE 'Program to Transfer a Macintosh File to CMS' 00001000 RMAC CSECT 00002000 EXTRN CRCTAB,SCRNIO 00003000 PRINT NOGEN 00004000 REGEQU 00005000 USING *,R15 00006000 STM R0,R15,RDSAVE SAVE ALL REGISTERS 00007000 LR R10,R15 00008000 LA R11,2048(R10) 00009000 LA R11,2048(R11) 00010000 LA R12,2048(R11) 00011000 LA R12,2048(R12) 00012000 DROP R15 00013000 USING RMAC,R10,R11,R12 R10 - R12 = RMAC BASE REGISTERS 00014000 USING NUCON,0 ALSO ADDRESS NUCON 00015000 SR R15,R15 00016000 ST R15,RTNCODE RETURN CODE INITIALIZED TO ZERO 00017000 ST R15,BUFSIZE OUTPUT BUFFER EMPTY 00018000 ST R15,RETRYCNT TOTAL RETRY COUNT = 0 00019000 ST R15,TOTCHRS INITIALIZE TIMING DATA 00020000 ST R15,TOTSECS 00021000 ST R15,TOTSECS+4 00022000 STH R15,UNSOLIS Init. count of unsolicited ints. 00023000 MVI FLAGS,NOMENU INITIALIZE FLAGS 00024000 MVI FLAGS2,0 00025000 MVI FLAGS3,0 00026000 MVI TRMFLAGS,0 ALSO TERMINAL FLAGS 00027000 BAL R14,ZEROLAST ZERO RECVLAST BUFFER 00028000 MVC RECVATTR(18),=18C'0' INITIALIZE FILE ATTRIBUTES 00029000 MVC VERSDATA(5),=C' 0000' INITIALIZE VERSION DATA 00030000 MVC XFSPEED(4),=C'0000' INITIALIZE TRANSFER RATE 00031000 LA R9,OUTFILE R9 -> OUTPUT FILE FSCB 00032000 USING FSCBD,R9 00033000 EJECT 00034000 * INTERPRET FILE ID ARGUMENTS: 00035000 MVC FSCBFM(2),=CL2'A1' DEFAULT FM IS "A1" 00036000 MVC DSKMODE(1),=CL2'A1' 00037000 CLI 8(R1),X'FF' ERROR IF FN OR FT IS 00038000 BE BADID MISSING OR "*" 00039000 CLI 8(R1),C'*' 00040000 BE BADID 00041000 CLI 16(R1),X'FF' 00042000 BE BADID 00043000 CLI 16(R1),C'*' 00044000 BE BADID 00045000 MVC FSCBFN(16),8(R1) SAVE VALID FN AND FT 00046000 CLI FSCBFT,C'.' FT BEGINS WITH A PERIOD? 00047000 BNE KEEPFT NO, KEEP FT AS IS 00048000 MVC FSCBFT(7),FSCBFT+1 SHIFT CHARACTERS OVER 00049000 MVI FSCBFT+7,C' ' PUT BLANK AT END 00050000 MVI DELIM,C'.' USE "." FOR MAC DELIMITER 00051000 KEEPFT EQU * 00052000 CLI 24(R1),C'*' SAVE FM IF GIVEN AND NOT "*" 00053000 BE BADID 00054000 CLC 24(8,R1),=C'(' OPTIONS MAY START HERE ALSO 00055000 BE HAVEID 00056000 CLI 24(R1),X'FF' 00057000 BE DOSTATE 00058000 MVC FSCBFM(2),24(R1) SAVE CALLER'S FM 00059000 MVC DSKMODE(1),24(R1) 00060000 B HAVEID 00061000 SPACE 00062000 * SAVE AREA LOCATED HERE FOR ADDRESSABILITY 00063000 RDSAVE DS 8D REGISTER SAVE AREA 00064000 RTNCODE EQU RDSAVE+60 RETURN CODE AT LOCATION FOR R15 00065000 SPACE 00066000 BADID EQU * FILE ID ERROR 00067000 LINEDIT TEXT='DMSRMC001E Fileid incomplete or contains "*"', X00068000 DISP=ERRMSG 00069000 MVI RTNCODE+3,24 00070000 B CMSRTN 00071000 EJECT 00072000 * INTERPRET OPTIONS: 00073000 HAVEID EQU * FSCB FILEID COMPLETE 00074000 LA R2,32(R1) R2 = OPTION POINTER 00075000 OPTLOOP EQU * PROCESS OPTIONS 00076000 CLC 0(8,R2),=8X'FF' END AT X'FF' 00077000 BE DOSTATE 00078000 CLC 0(8,R2),=CL8')' ALSO ")" 00079000 BE DOSTATE 00080000 CLC 0(8,R2),=CL8'(' SKIP "(" 00081000 BE NEXTOPT 00082000 LA R5,8 GET LENGTH IN R5 00083000 LA R4,7(R2) R4 -> LAST BYTE 00084000 LENLOOP EQU * LOOP TO GET LENGTH 00085000 CLI 0(R4),C' ' AT NON-BLANK? 00086000 BNE HAVELEN YES, LENGTH IN R5 00087000 BCTR R4,0 R4 -> PREVIOUS BYTE 00088000 BCT R5,LENLOOP DECREMENT & REPEAT 00089000 B OPTERR ALL BLANK IS ERROR 00090000 SPACE 00091000 HAVELEN BCTR R5,0 DECREMENT LENGTH FOR EX 00092000 LA R4,OPTTAB R4 -> OPTION TABLE 00093000 TABCHECK EQU * LOOK FOR MATCH IN TABLE 00094000 CLI 0(R4),X'FF' AT TABLE END? 00095000 BE OPTERR YES, BAD OPTION 00096000 EX R5,TABCLC FOUND A MATCH? 00097000 BE USEOPT YES, HANDLE OPTION 00098000 LA R4,12(R4) R4 -> NEXT OPTION 00099000 B TABCHECK TRY AGAIN 00100000 SPACE 00101000 USEOPT L R3,8(R4) GET ADDRESS OF ROUTINE 00102000 BR R3 EXECUTE CODE FOR OPTION 00103000 SPACE 00104000 NEXTOPT EQU * OPTION CODE RETURN HERE 00105000 LA R2,8(R2) CHECK OUT NEXT TOKEN 00106000 B OPTLOOP 00107000 SPACE 00108000 TABCLC CLC 0(*-*,R4),0(R2) COMPARE TABLE ENTRY TO OPTION 00109000 SPACE 00110000 MENUOPT NI FLAGS,255-NOMENU RESET FLAG 00111000 B NEXTOPT 00112000 SPACE 00113000 NOMENOPT OI FLAGS,NOMENU SET FLAG 00114000 B NEXTOPT 00115000 SPACE 00116000 BINOPT OI FLAGS2,BINXF SET FLAG 00117000 B NEXTOPT 00118000 SPACE 00119000 NOBINOPT NI FLAGS2,255-BINXF RESET FLAG 00120000 B NEXTOPT 00121000 SPACE 00122000 STDXOPT OI FLAGS3,STDTR SET STANDARD XLATE FLAG 00123000 B NEXTOPT 00124000 SPACE 00125000 OPTERR LINEDIT TEXT='DMSRMC003E Invalid option ''........''', X00126000 SUB=(CHARA,(R2)),DISP=ERRMSG 00127000 MVI RTNCODE+3,24 00128000 B CMSRTN 00129000 EJECT 00130000 DOSTATE EQU * 00131000 LA R1,OUTFILE CALL STATEW FOR INPUT FILE 00132000 MVC 0(8,R1),=CL8'STATEW' 00133000 SVC 202 00134000 DC AL4(*+4) 00135000 C R15,=F'28' ERROR IF "FILE NOT FOUND" 00136000 BE TRMINIT NOT RETURNED 00137000 ST R15,RTNCODE SAVE RETURN CODE 00138000 C R15,=F'36' ERROR 36 IS DISK NOT ACCESSED 00139000 BE NODISK 00140000 C R15,=F'0' ELSE IF NON-ZERO, ASSUME STATEW 00141000 BNE CMSRTN TYPED MESSAGE 00142000 LINEDIT TEXT='DMSRMC002E Output file already exists', X00143000 DISP=ERRMSG 00144000 MVI RTNCODE+3,28 00145000 B CMSRTN 00146000 SPACE 00147000 NODISK LINEDIT TEXT='DMSRMC069E Disk ''..'' not accessed', X00148000 SUB=(CHARA,DSKMODE),DISP=ERRMSG 00149000 B CMSRTN 00150000 SPACE 00151000 * 00152000 * PERFORM ONE-TIME INITIALIZATION 00153000 * 00154000 TRMINIT BAL R14,TERMTYPE DETERMINE TERMINAL TYPE 00155000 OI FLAGS2,TERMINIT REMEMBER TERM INIT. DONE 00156000 TM TRMFLAGS,MAC3270 MAC3270? 00157000 BZ BINCHECK NO, CHECK FOR BINARY XFER 00158000 CLC M3270VER+1(4),=C'0110' NEW ENOUGH? 00159000 BNL INITCONT YES, CONTINUE 00160000 MVC M3270VER(2),M3270VER+1 FORMAT VERSION NUMBER 00161000 MVI M3270VER+2,C'.' 00162000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00163000 LINEDIT TEXT='DMSRMC013E This version of Mac3270 (.....) does X00164000 not support file transfer', X00165000 SUB=(CHARA,M3270VER),DISP=ERRMSG 00166000 LA R15,36 STORE RETURN CODE & RETURN 00167000 ST R15,RTNCODE 00168000 B CMSRTN 00169000 SPACE 00170000 BINCHECK TM FLAGS2,BINXF BINARY SPECIFIED WHEN NOT MAC3270? 00171000 BZ INITCONT NO, CONTINUE 00172000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00173000 LINEDIT TEXT='DMSRMC014E Mac3270 must be used for binary file X00174000 transfers',DISP=ERRMSG 00175000 LA R15,36 STORE RETURN CODE & RETURN 00176000 ST R15,RTNCODE 00177000 B CMSRTN 00178000 EJECT 00179000 INITCONT EQU * 00180000 * INITIALIZE TRANSLATION TABLES 00181000 TM TRMFLAGS,MAC3270 USE EXTENDED ASCII FOR MAC3270 00182000 BO EXTTBL 00183000 TM FLAGS3,STDTR STANDARD TABLES WANTED? 00184000 BO STDASC YES, USE THEM 00185000 LCLASC EQU * LOCAL 7-BIT ASCII TABLES 00186000 MVC EBCTOASC(4),=V(TOASCLCL) 00187000 MVC ASCTOEBC(4),=V(FRASCLCL) 00188000 B TBLSOK 00189000 SPACE 00190000 STDASC EQU * STANDARD 7-BIT ASCII TABLES 00191000 MVC EBCTOASC(4),=V(TOASCSTD) 00192000 MVC ASCTOEBC(4),=V(FRASCSTD) 00193000 B TBLSOK 00194000 SPACE 00195000 EXTTBL TM FLAGS3,STDTR STANDARD TABLES WANTED? 00196000 BO STDEXT YES, USE THEM 00197000 LCLEXT EQU * LOCAL EXTENDED ASCII TABLES 00198000 MVC EBCTOASC(4),=V(TOEXTLCL) 00199000 MVC ASCTOEBC(4),=V(FREXTLCL) 00200000 B TBLSOK 00201000 SPACE 00202000 STDEXT EQU * STANDARD EXTENDED ASCII TABLES 00203000 MVC EBCTOASC(4),=V(TOEXTSTD) 00204000 MVC ASCTOEBC(4),=V(FREXTSTD) 00205000 * B TBLSOK 00206000 TBLSOK EQU * TRANSLATION TABLES DEFINED 00207000 TM TRMFLAGS,GRAFTRM 3270 TERMINAL? 00208000 BO CPOK2 YES, SKIP ASCII INIT. 00209000 * DO ASCII INITIALIZATION 00210000 MVC INTAB(4),AINTRTBL SAVE "SET INPUT" TABLE 00211000 MVC OUTTAB(4),AOUTRTBL SAVE "SET OUTPUT" TABLE 00212000 DMSEXS XC,AINTRTBL(4),AINTRTBL RESET INPUT TRANSLATION 00213000 DMSEXS XC,AOUTRTBL(4),AOUTRTBL RESET OUTPUT TRANSLATION 00214000 LINEDIT TEXT='SET LINEDIT OFF',DOT=NO,DISP=CPCOMM 00215000 LTR R15,R15 CHECK FOR ERROR FROM CP 00216000 BZ CPOK1 00217000 ST R15,RTNCODE SAVE RETURN CODE 00218000 LINEDIT TEXT='DMSRMC010E Error from CP "SET" command', X00219000 DISP=ERRMSG 00220000 B CMSRTN 00221000 SPACE 00222000 CPOK1 EQU * No linesize limit 00223000 LINEDIT TEXT='TERM LINESIZE OFF',DOT=NO,DISP=CPCOMM 00224000 LTR R15,R15 CHECK FOR ERROR FROM CP 00225000 BZ CPOK2 00226000 CPERR ST R15,RTNCODE SAVE RETURN CODE 00227000 LINEDIT TEXT='DMSRMC010E Error from CP "TERM" command', X00228000 DISP=ERRMSG 00229000 B CMSRTN 00230000 SPACE 00231000 CPOK2 EQU * HAVE MAC ENTER XFER MODE 00232000 LA R1,CTLFS R1 -> STRING 00233000 LA R2,2 R2 = LENGTH 00234000 BAL R14,WRITE OUTPUT STRING 00235000 EJECT 00236000 * 00237000 * ATTEMPT TO GET VERSION INFORMATION. END FILE TRANSFER IF 00238000 * NOT A MACINTOSH SYSTEM. 00239000 * 00240000 MVI VERSDATA,C'M' SET MACINTOSH DEFAULT 00241000 MVC SENDDATA(2),=C'VR' "VR" FOR VERSION REQUEST 00242000 LA R1,2 COMMAND LENGTH IS 2 00243000 STH R1,SENDLEN 00244000 BAL R14,CPMCMMD EXECUTE COMMAND 00245000 CLC RECVDATA(2),=C'VI' DID WE GET VERSION INFO.? 00246000 BNE CHKSYS NO, KEEP DEFAULT 00247000 MVC VERSDATA(5),RECVDATA+2 COPY VERSION DATA 00248000 CHKSYS CLI VERSDATA,C'M' IS IT A MACINTOSH SYSTEM? 00249000 BE SYSOK YES, CAN CONTINUE 00250000 CLI VERSDATA,C'C' IS IT A CP/M SYSTEM? 00251000 BE SYSOK YES, CAN CONTINUE 00252000 LA R1,2 COMMAND LENGTH IS 2 00253000 STH R1,SENDLEN 00254000 MVC SENDDATA(2),=C'EX' "EXIT" COMMAND 00255000 BAL R14,CPMCMMD EXECUTE COMMAND, IGNORE RESULTS 00256000 BAL R14,ENDFS 00257000 LINEDIT TEXT='DMSRMC012E Remote system type is unknown', X00258000 DISP=ERRMSG 00259000 LA R15,36 STORE RETURN CODE & RETURN 00260000 ST R15,RTNCODE 00261000 B CMSRTN 00262000 SPACE 00263000 SYSOK EQU * 00264000 TM TRMFLAGS,MAC3270 MAC3270? 00265000 BZ TRMOK NO, NOTHING SPECIAL 00266000 CLC VERSDATA+1(4),=C'0231' EXT. ASCII & NATIONAL LANG.? 00267000 BL TRMOK 00268000 MVC SENDDATA(2),=C'XL' "XL" FOR XTAB REQUEST 00269000 LA R1,2 COMMAND LENGTH IS 2 00270000 STH R1,SENDLEN 00271000 BAL R14,CPMCMMD EXECUTE COMMAND 00272000 BAL R14,USEXL GENERATE XTAB FROM RESPONSE 00273000 TRMOK EQU * FILL-IN FSCB (NEED VERSION INFO): 00274000 MVI FSCBFV,C'V' RECFM = V 00275000 MVC FSCBITNO(2),=H'0' ITEM NO. = 0 00276000 LA R1,OUTBUF 00277000 ST R1,FSCBBUFF STORE BUFFER ADDRESS 00278000 MVC FSCBNOIT(2),=H'1' NO. OF ITEMS TO WRITE = 1 00279000 MVC MACID(8),FSCBFN INITIALIZE ID WITH FILENAME 00280000 MVC MACID+8(9),=CL9' ' 00281000 LA R1,MACID R1 -> FIRST BLANK IN ID 00282000 IDLOOP CLI 0(R1),C' ' LOOP UNTIL BLANK REACHED 00283000 BE MOVEFT 00284000 LA R1,1(R1) 00285000 B IDLOOP 00286000 SPACE 00287000 MOVEFT CLI VERSDATA,C'C' CP/M? 00288000 BE CPMMFT YES, DIFFERENT ID FORMAT 00289000 MVC 0(1,R1),DELIM APPEND DELIMITER 00290000 MVC 1(8,R1),FSCBFT AND FILETYPE 00291000 L R2,=V(TOLOWER) TRANSLATE TO LOWER CASE 00292000 TR MACID(17),0(R2) TRANSLATE TO LOWER CASE 00293000 B USEFT 00294000 SPACE 00295000 CPMMFT MVI 0(R1),C'.' APPEND PERIOD AND 00296000 MVC 1(3,R1),FSCBFT START OF FILETYPE 00297000 USEFT EQU * 00298000 EJECT 00299000 * 00300000 * OPEN MAC FILE FOR INPUT 00301000 * 00302000 ***** FSERASE 'RMAC DEBUG A' ***** 00303000 MVC SENDDATA(2),=C'OI' "OI" TO OPEN FOR INPUT 00304000 TM FLAGS2,BINXF BINARY SPECIFIED? 00305000 BZ KEEPOI NO, KEEP OI COMMAND 00306000 MVC SENDDATA(2),=C'BI' "BI" FOR BINARY INPUT 00307000 NI FLAGS2,255-BINXF RESET FLAG 00308000 KEEPOI MVC SENDDATA+2(17),MACID FOLLOWED BY MAC FILE ID 00309000 LA R1,19 R1 = MAXIMUM LENGTH 00310000 LA R2,SENDDATA+18 R2 -> LAST BYTE 00311000 CLI VERSDATA,C'C' CP/M SYSTEM? 00312000 BNE TRUNLP NO, CAN KEEP LENGTHS 00313000 LA R1,14 R1 = MAXIMUM LENGTH 00314000 LA R2,SENDDATA+13 R2 -> LAST BYTE 00315000 TRUNLP CLI 0(R2),C' ' LOOP: ADJUST LENGTH TO REMOVE 00316000 BNE USELEN TRAILING BLANKS 00317000 BCTR R1,0 DECREMENT LENGTH 00318000 BCTR R2,0 DECREMENT ADDRESS 00319000 B TRUNLP 00320000 SPACE 00321000 USELEN STH R1,SENDLEN STORE COMPUTED LENGTH 00322000 TM FLAGS,NOMENU MENU SUPPRESSED? 00323000 BZ EXOPEN NO, CONTINUE 00324000 CLI VERSDATA,C'C' LIKEWISE IF CP/M 00325000 BE EXOPEN 00326000 LA R2,SENDDATA(R1) APPEND "*" AT END 00327000 MVI 0(R2),C'*' 00328000 LA R1,1(R1) INCREMENT LENGTH 00329000 STH R1,SENDLEN STORE UPDATED VALUE 00330000 EXOPEN EQU * 00331000 BAL R14,CPMCMMD EXECUTE COMMAND 00332000 CLC RECVDATA(2),=C'AT' DID WE GET ATTRIBUTES? 00333000 BE SAVEATR YES, SAVE THEM 00334000 CLC RECVDATA(2),=C'BT' LIKEWISE BINARY ATTR. 00335000 BE BINATR 00336000 BAL R14,READRC GET RETURN CODE IN R1 00337000 * END XFER MODE 00338000 LR R2,R1 COPY RC FOR LINEDIT 00339000 LA R1,2 COMMAND LENGTH IS 2 00340000 STH R1,SENDLEN 00341000 MVC SENDDATA(2),=C'EX' "EXIT" COMMAND 00342000 BAL R14,CPMCMMD EXECUTE COMMAND, IGNORE RESULTS 00343000 BAL R14,ENDFS END FULL-SCREEN MODE 00344000 C R2,=F'1' ERROR 1 IS CP/M FILE NOT FOUND 00345000 BE NOFILE 00346000 * ELSE TYPE ERROR NUMBER 00347000 LINEDIT TEXT='DMSRMC004E Mac error .... opening ''.................'X00348000 '',SUB=(DEC,(R2),CHARA,MACID),DISP=ERRMSG,RENT=NO 00349000 LA R15,100(R2) STORE RETURN CODE & RETURN 00350000 ST R15,RTNCODE 00351000 B CMSRTN 00352000 SPACE 00353000 NOFILE EQU * 00354000 LINEDIT TEXT='DMSRMC005E Mac file ''.................'' not founX00355000 d',SUB=(CHARA,MACID),DISP=ERRMSG 00356000 LA R15,100(R2) 00357000 ST R15,RTNCODE 00358000 B CMSRTN 00359000 SPACE 00360000 BINATR OI FLAGS2,BINXF BT LIKE AT, BUT BINARY XFER 00361000 MVI FSCBFV,C'F' CHANGE RECFM TO F 00362000 SAVEATR MVC RECVATTR(18),RECVDATA+2 SAVE ATTRIBUTES TO USE LATER 00363000 EJECT 00364000 * 00365000 * READ AND PROCESS CP/M DATA BLOCKS 00366000 * 00367000 RDBGN SR R4,R4 R4 = CP/M BLOCK NO. OFFSET 00368000 B RDCVT SKIP INITIAL INCREMENT 00369000 RDLOOP EQU * LOOP TO PROCESS BLOCKS 00370000 LA R4,1(R4) R4 = NEXT BLOCK NUMBER 00371000 RDCVT MVC SENDDATA(6),=X'402120202020' CONVERT BLOCK NUMBER 00372000 CVD R4,DECBUF 00373000 ED SENDDATA(6),DECBUF+5 00374000 MVC SENDDATA(2),=C'RB' STORE READ BLOCK COMMAND 00375000 LA R1,6 00376000 CLC VERSDATA+1(4),=C'0000' IS XFSPEED SUPPORTED? 00377000 BE NOSPEED NO, KEEP JUST BLOCK NO. 00378000 MVC SENDDATA+6(4),XFSPEED APPEND XFSPEED 00379000 LA R1,10 CHANGE LENGTH TO 10 00380000 NOSPEED EQU * 00381000 STH R1,SENDLEN STORE COMMAND LENGTH 00382000 TM TRMFLAGS,VTAM VTAM CONNECTION? 00383000 BZ RBCMMD NO, READY FOR COMMAND 00384000 OI FLAGS2,VTAMRB INDICATE VTAM PREP. NEEDED 00385000 RBCMMD BAL R14,CPMCMMD EXECUTE COMMAND 00386000 NI FLAGS2,255-VTAMRB RESET VTAM PREP. FLAG 00387000 CLC RECVDATA(2),=C'DB' DID WE GET THE DATA BLOCK? 00388000 BNE RDEND IF NOT, PROCESS RC 00389000 TM FLAGS2,BINXF BINARY TRANSFER? 00390000 BO RDBIN YES, PROCESS SEPARATELY 00391000 BAL R14,PROCBLK PROCESS DATA BLOCK 00392000 B RDLOOP TRY FOR NEXT BLOCK 00393000 SPACE 00394000 RDBIN BAL R14,PROCBIN PROCESS BINARY DATA 00395000 B RDLOOP 00396000 SPACE 00397000 RDEND BAL R14,READRC GET RETURN CODE IN R1 00398000 * END XFER MODE 00399000 C R1,=F'1' TYPE MESSAGE IF NOT NORMAL EOF 00400000 BE RDCLOSE 00401000 LR R3,R1 COPY RETURN CODE FOR LINEDIT 00402000 LA R1,SUBCODE R1 -> STRING 00403000 LA R2,1 R2 = LENGTH 00404000 BAL R14,WRITE TELL VMXFER TO CALL "SUBSET" 00405000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00406000 C R3,=F'11' CHECK FOR USER ABORT 00407000 BE USRABORT 00408000 LINEDIT TEXT='DMSRMC006E Error ...... from Mac read', X00409000 SUB=(DEC,(R3)),DISP=ERRMSG 00410000 LA R15,100(R3) STORE RETURN CODE 00411000 ST R15,RTNCODE 00412000 BAL R14,BEGINFS RESTORE FULL-SCREEN MODE 00413000 LA R1,SUBCODE R1 -> STRING 00414000 LA R2,1 R2 = LENGTH 00415000 BAL R14,WRITE TELL VMXFER TO EXIT "SUBSET" 00416000 B RDCLOSE 00417000 SPACE 00418000 USRABORT LINEDIT TEXT='DMSRMC011E Transfer aborted by user', X00419000 DISP=ERRMSG 00420000 LA R15,100(R3) STORE RETURN CODE 00421000 ST R15,RTNCODE 00422000 BAL R14,BEGINFS RESTORE FULL-SCREEN MODE 00423000 LA R1,SUBCODE R1 -> STRING 00424000 LA R2,1 R2 = LENGTH 00425000 BAL R14,WRITE TELL VMXFER TO EXIT "SUBSET" 00426000 RDCLOSE LA R1,2 COMMAND LENGTH IS 2 00427000 STH R1,SENDLEN 00428000 MVC SENDDATA(2),=C'CI' CLOSE INPUT FILE 00429000 BAL R14,CPMCMMD EXECUTE COMMAND 00430000 BAL R14,READRC GET RETURN CODE IN R1 00431000 LTR R1,R1 TYPE MESSAGE IF NOT ZERO 00432000 BZ RDEXIT 00433000 LR R3,R1 COPY RETURN CODE FOR LINEDIT 00434000 LA R1,SUBCODE R1 -> STRING 00435000 LA R2,1 R2 = LENGTH 00436000 BAL R14,WRITE TELL VMXFER TO CALL "SUBSET" 00437000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00438000 LINEDIT TEXT='DMSRMC009E Error ...... from Mac close', X00439000 SUB=(DEC,(R3)),DISP=ERRMSG 00440000 LA R15,100(R3) STORE RETURN CODE 00441000 ST R15,RTNCODE 00442000 BAL R14,BEGINFS RESTORE FULL-SCREEN MODE 00443000 LA R1,SUBCODE R1 -> STRING 00444000 LA R2,1 R2 = LENGTH 00445000 BAL R14,WRITE TELL VMXFER TO EXIT "SUBSET" 00446000 RDEXIT LA R1,2 COMMAND LENGTH IS 2 00447000 STH R1,SENDLEN 00448000 MVC SENDDATA(2),=C'EX' "EXIT" COMMAND 00449000 BAL R14,CPMCMMD EXECUTE COMMAND, IGNORE RESULTS 00450000 B CMSRTN RETURN 00451000 EJECT 00452000 * 00453000 * LOOP TO PROCESS A BLOCK OF CP/M DATA A BYTE AT A TIME 00454000 * 00455000 PROCBLK EQU * 00456000 STM R0,R15,BLKSAVE SAVE REGISTERS 00457000 LH R6,RECVLEN R6 = NUMBER OF BYTES 00458000 S R6,=F'2' 00459000 BNP PROCRET RETURN IF NOT > 0 00460000 LA R2,RECVDATA+2 R2 -> FIRST DATA BYTE 00461000 LA R6,0(R2,R6) R6 -> PAST LAST DATA BYTE 00462000 BYTELOOP EQU * 00463000 TM FLAGS,EOF IGNORE DATA LINE IF 00464000 BO PROCRET EOF SIGNALLED 00465000 CLI 0(R2),X'3F' > X'3F' IS GOOD DATA 00466000 BH ADDBYTE 00467000 BE SETEOF X'3F' IS CP/M EOF CODE 00468000 CLI 0(R2),X'0B' X'0B' IS TRANSLATED CR 00469000 BE NEWLINE 00470000 CLI 0(R2),X'25' X'25' (LF) IS IGNORED 00471000 BE NXTBYTE 00472000 * KEEP ANY OTHER CONTROL CHARACTERS 00473000 * (THERE SHOULDN'T BE ANY) 00474000 ADDBYTE L R3,BUFSIZE IS OUTPUT BUFFER FULL ? 00475000 C R3,=F'256' 00476000 BL ADDCONT 00477000 BAL R8,WRITEBUF YES - ADD IT TO DISK FILE 00478000 L R3,BUFSIZE R3 = BYTES NOW (SHOULD BE 0) 00479000 IC R4,CENTSGN BEGIN CONTINUATION LINE 00480000 STC R4,OUTBUF(R3) WITH A CENT SIGN 00481000 LA R3,1(R3) (A NON-ASCII CHARACTER) 00482000 ADDCONT IC R4,0(R2) ADD CHAR. FROM CP/M TO 00483000 STC R4,OUTBUF(R3) OUTPUT BUFFER 00484000 LA R3,1(R3) 00485000 ST R3,BUFSIZE UPDATE BUFFER SIZE 00486000 B NXTBYTE READY FOR A NEW CHARACTER 00487000 SPACE 00488000 SETEOF OI FLAGS,EOF SET EOF WHEN CTL-Z RECEIVED 00489000 B PROCRET IGNORE REST OF DATA LINE 00490000 SPACE 00491000 NEWLINE BAL R8,WRITEBUF ADD BUFFER TO FILE 00492000 * WHEN CR RECEIVED 00493000 NXTBYTE EQU * READY FOR NEXT CP/M BYTE 00494000 LA R2,1(R2) 00495000 CR R2,R6 00496000 BL BYTELOOP PROCESS NEXT BYTE 00497000 PROCRET LM R0,R15,BLKSAVE RESTORE REGISTERS 00498000 BR R14 RETURN AFTER PROCESSING ENTIRE BLOCK 00499000 SPACE 00500000 BLKSAVE DS 8D LOCAL REGISTER SAVE AREA 00501000 EJECT 00502000 * 00503000 * PROCESS BLOCKS OF BINARY DATA WHICH HAVE BEEN READ 00504000 * 00505000 PROCBIN EQU * 00506000 STM R0,R15,BINSAVE SAVE REGISTERS 00507000 LH R5,RECVLEN R5 = NUMBER OF BYTES 00508000 S R5,=F'2' 00509000 BNP BINRET RETURN IF NOT > 0 00510000 LA R2,RECVDATA+2 R2 -> FIRST DATA BYTE 00511000 LA R6,127(R5) GET NUMBER OF 128 BYTE BLOCKS 00512000 SRL R6,7 00513000 LR R4,R6 R4 = NUMBER OF BYTES TO WRITE 00514000 SLL R4,7 00515000 SR R4,R5 MORE THAN WE READ? 00516000 BNP BINLOOP NO, CONTINUE 00517000 BCTR R4,0 DECREMENT FOR EX 00518000 LA R3,0(R2,R5) R3 -> PAST LAST BYTE 00519000 EX R4,BINXC FILL END WITH ZEROS 00520000 BINLOOP EQU * LOOP TO WRITE BLOCKS 00521000 MVC BUFSIZE(4),=F'128' SET BUFSIZE TO 128 00522000 MVC OUTBUF(128),0(R2) COPY DATA TO BUFFER 00523000 BAL R8,WRITEBUF WRITE DATA TO DISK 00524000 LA R2,128(R2) R2 -> NEXT DATA BLOCK 00525000 BCT R6,BINLOOP REPEAT FOR ALL BLOCKS 00526000 BINRET LM R0,R15,BINSAVE RESTORE REGISTERS 00527000 BR R14 RETURN AFTER PROCESSING ENTIRE BLOCK 00528000 SPACE 00529000 BINSAVE DS 8D LOCAL REGISTER SAVE AREA 00530000 BINXC XC 0(*-*,R3),0(R3) GENERATE ZEROS FOR SHORT BLOCK 00531000 EJECT 00532000 * 00533000 * SUBROUTINE TO WRITE OUTPUT BUFFER TO DISK 00534000 * 00535000 WRITEBUF L R5,BUFSIZE IF BUFFER IS EMPTY, 00536000 LTR R5,R5 USE ONE BLANK FOR LINE 00537000 BP NOTNULL 00538000 MVI OUTBUF,C' ' 00539000 LA R5,1 00540000 NOTNULL EQU * BUFFER LENGTH IN R5 00541000 TM FLAGS2,BINXF BINARY TRANSFER? 00542000 BO NLOK YES, SKIP NL TRANSLATION 00543000 TM FLAGS3,STDTR STANDARD TRANSLATION WANTED? 00544000 BO NLOK YES, SKIP NL TRANSLATION 00545000 TM FLAGS3,NLXT NL TABLE DEFINED? 00546000 BZ NLOK NO, SKIP NL TRANSLATION 00547000 L R0,=A(NLXTAB) R0 -> NL TRANSLATION TABLE 00548000 LA R1,OUTBUF R1 -> DATA BUFFER 00549000 LR R15,R2 SAVE R2 00550000 LR R2,R5 R2 = DATA LENGTH 00551000 BAL R14,LONGTR TRANSLATE DATA 00552000 LR R2,R15 RESTORE R2 00553000 NLOK EQU * 00554000 ST R5,FSCBSIZE TELL WRBUF BUFFER LENGTH 00555000 OI FLAGS,FINIS SET FLAG TO CLOSE FILE 00556000 FSWRITE FSCB=OUTFILE CALL WRBUF 00557000 LTR R15,R15 CHECK FOR ERRORS 00558000 BNZ WRERR 00559000 ST R15,BUFSIZE RESET BUFFER SIZE 00560000 BR R8 RETURN TO CALLER 00561000 SPACE 00562000 WRERR C R15,=F'12' IS DISK R/O? 00563000 BNE ISRW NO 00564000 OI FLAGS,ROERR ELSE REMEMBER NO UPDATING 00565000 ISRW LR R3,R15 COPY RC FOR LINEDIT 00566000 XC BUFSIZE(4),BUFSIZE ENSURE CMSRTN WON'T CALL US AGAIN 00567000 LA R1,SUBCODE R1 -> STRING 00568000 LA R2,1 R2 = LENGTH 00569000 BAL R14,WRITE TELL VMXFER TO CALL "SUBSET" 00570000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00571000 LINEDIT TEXT='DMSRMC105S Error ''.....'' writing file ''......X00572000 ..............'' on disk', X00573000 SUB=(DEC,(R3),CHAR8A,FSCBFN),DISP=ERRMSG,RENT=NO 00574000 LA R15,100 STORE RETURN CODE 00575000 ST R15,RTNCODE 00576000 BAL R14,BEGINFS RESTORE FULL-SCREEN MODE 00577000 LA R1,SUBCODE R1 -> STRING 00578000 LA R2,1 R2 = LENGTH 00579000 BAL R14,WRITE TELL VMXFER TO EXIT "SUBSET" 00580000 B RDCLOSE 00581000 EJECT 00582000 * 00583000 * RETURN TO CMS 00584000 * 00585000 CMSRTN L R3,BUFSIZE ANY DATA LEFT IN BUFFER ? 00586000 LTR R3,R3 IF SO, WRITE IT TO DISK 00587000 BZ FILDONE 00588000 BAL R8,WRITEBUF 00589000 FILDONE TM FLAGS2,TERMINIT TERMINAL TYPE KNOWN? 00590000 BZ RTNCLOSE NO, SKIP CLEANUP 00591000 TM TRMFLAGS,GRAFTRM 3270 TERMINAL? 00592000 BO RTN3270 YES, END FULL-SCREEN MODE 00593000 * CLEANUP FOR ASCII: 00594000 LINEDIT TEXT='SET LINEDIT ON',DOT=NO,DISP=CPCOMM 00595000 LINEDIT TEXT='TERM LINESIZE 80',DOT=NO,DISP=CPCOMM 00596000 DMSEXS MVC,AINTRTBL(4),INTAB RESTORE XLATE TABLES 00597000 DMSEXS MVC,AOUTRTBL(4),OUTTAB 00598000 B RTNCLOSE 00599000 SPACE 00600000 RTN3270 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00601000 TM FLAGS3,PATHOPEN Console path open? 00602000 BZ RTNCLOSE No, skip close 00603000 CONSOLE CLOSE,PATH='ONE' 00604000 RTNCLOSE TM FLAGS,FINIS 00605000 BZ NOTOPEN 00606000 FSCLOSE '* * *' FORCE FILE TO BE CLOSED 00607000 TM FLAGS,ROERR R/O ERROR FROM FSWRITE? 00608000 BO NOTOPEN YES, DON'T ATTEMPT TO WRITE 00609000 CLI VERSDATA,C'C' CP/M SYSTEM? 00610000 BE CPMDATE YES, GO HANDLE 00611000 CLC RECVATTR+4(14),=18C'0' CHECK IF DATE/TIME 00612000 BE NOTOPEN IF NOT, SKIP UPDATE 00613000 BAL R14,SETDATE SET DATE AND TIME FOR FILE 00614000 B NOTOPEN 00615000 SPACE 00616000 CPMDATE CLC RECVATTR+4(8),=12C'0' CHECK IF DATE/TIME 00617000 BE NOTOPEN IF NOT, SKIP UPDATE 00618000 BAL R14,SETDATEC SET DATE AND TIME FOR FILE 00619000 NOTOPEN L R2,RETRYCNT TYPE NON-ZERO RETRY COUNT 00620000 LTR R2,R2 00621000 BZ NORETRY 00622000 LINEDIT TEXT='DMSRMC008I ...... block retransmission(s)', X00623000 SUB=(DEC,(R2)),DISP=ERRMSG 00624000 NORETRY LM R0,R15,RDSAVE RESTORE REGISTERS AND RETURN 00625000 BR R14 00626000 EJECT 00627000 * SEND COMMAND TO CP/M SYSTEM AND 00628000 * READ RESPONSE 00629000 CPMCMMD EQU * 00630000 STM R0,R15,CMMDSAVE SAVE REGISTERS 00631000 SR R4,R4 RETRY COUNT = 0 00632000 LH R0,SENDLEN CALCULATE CHECKSUM (4 BYTES) 00633000 LA R1,SENDDATA 00634000 BAL R14,CHKCALC RESULT BYTES ARE IN R2 00635000 * APPEND CHECKSUM TO SENDDATA 00636000 AR R1,R0 R1 -> AFTER LAST BYTE OF DATA 00637000 MVI 0(R1),X'01' STORE CHECKSUM DELIMITER 00638000 LA R1,1(R1) STORE CHECKSUM BYTES 00639000 STCM R2,B'1111',0(R1) 00640000 LH R2,SENDLEN ADD 5 TO LENGTH 00641000 LA R2,5(R2) (DELIMITER, 4-BYTE CHECKSUM) 00642000 STH R2,SENDLEN 00643000 CMDLOOP BAL R14,ZERODATA ZERO RESPONSE BUFFER 00644000 LH R2,SENDLEN GET LENGTH FOR WRITE 00645000 TM TRMFLAGS,MAC3270 APPLETALK CONNECTION? 00646000 BZ CMDSCODE NO, NEED START CODES 00647000 LA R1,SENDDATA ELSE JUST RESTORE R1 -> DATA 00648000 B CMDSOK 00649000 SPACE 00650000 CMDSCODE LA R2,2(R2) ADJUST FOR START BYTE CODES 00651000 LA R1,SENDSTRT R1 -> FIRST BYTE 00652000 CMDSOK EQU * START CODE ADDED, IF NEEDED 00653000 STCK STRTTIME SAVE TOD CLOCK FOR RATE CALC. 00654000 ST R2,WRCNT SAVE BYTE COUNT 00655000 TM FLAGS2,VTAMRB VTAM PREP. NEEDED? 00656000 BZ CMDWRITE NO, READY FOR COMMAND 00657000 LR R5,R1 SAVE R1, R2 FOR WRITERD 00658000 LR R6,R2 00659000 LA R1,VTAMCCW R1 -> VTAM INIT. CCW 00660000 LH R2,CONADDR R2 = CONSOLE ADDRESS 00661000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 00662000 LA R13,R13SAVE R13 -> SAVE AREA 00663000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 00664000 BALR R14,R15 SEND PREP. SCREEN 00665000 LA R1,RCCW R1 -> READ MOD. CCW 00666000 LH R2,CONADDR R2 = CONSOLE ADDRESS 00667000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 00668000 LA R13,R13SAVE R13 -> SAVE AREA 00669000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 00670000 BALR R14,R15 ISSUE READ MOD. FOR VTAM 00671000 ***** L R2,=F'4096' ***** 00672000 ***** SR R2,R0 ***** 00673000 ***** L R3,=A(GRAFDATA) ***** 00674000 ***** FSWRITE 'RMAC DEBUG A',BUFFER=(R3),BSIZE=(R2),RECFM=V 00675000 LR R1,R5 RESTORE R1, R2 00676000 LR R2,R6 00677000 CMDWRITE BAL R14,WRITERD WRITE DATA TO TERMINAL 00678000 * ALSO READ RESPONSE IF 3270 00679000 TM TRMFLAGS,GRAFTRM 3270 TERMINAL? 00680000 BO SKIPREAD RDTERM NOT NEEDED 00681000 RDTERM RECVDATA,EDIT=PHYS,LENGTH=1032 READ RESPONSE 00682000 STH R0,RECVLEN 00683000 SKIPREAD LH R0,RECVLEN READ LENGTH IN R0 00684000 ST R0,RDCNT SAVE BYTE COUNT 00685000 STCK ENDTIME SAVE TOD CLOCK FOR RATE CALC. 00686000 C R0,=F'6' ERROR IF < 6 BYTES 00687000 BL RETRY 00688000 LA R1,RECVDATA CHECK FOR CHECKSUM DELIMITER 00689000 AR R1,R0 00690000 S R1,=F'5' R1 -> WHERE DELIMITER SHOULD BE 00691000 CLI 0(R1),X'01' RETRY IF NOT THERE 00692000 BNE RETRY 00693000 SR R3,R3 GET CHECKSUM BYTES IN R3 00694000 ICM R3,B'1111',1(R1) 00695000 S R0,=F'5' R0 = DATA LENGTH 00696000 STH R0,RECVLEN SAVE LENGTH 00697000 LA R1,RECVDATA R1 -> DATA 00698000 BAL R14,CHKCALC GET CHECKSUM BYTES IN R2 00699000 CR R2,R3 IF MATCH, USE DATA 00700000 BE CMDRTN 00701000 RETRY C R4,=F'5' RETRY LIMIT REACHED? 00702000 BNL ABORT IF SO, ABORT XFER 00703000 LA R4,1(R4) INCREMENT COUNT 00704000 L R1,RETRYCNT INCREMENT GLOBAL COUNT 00705000 LA R1,1(R1) 00706000 ST R1,RETRYCNT 00707000 LA R1,SUBCODE R1 -> STRING 00708000 LA R2,1 R2 = LENGTH 00709000 BAL R14,WRITE TELL VMXFER TO CALL "SUBSET" 00710000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00711000 WRTERM RETRYMSG,RMSGL,EDIT=NO TYPE MESSAGE TO USER 00712000 BAL R14,BEGINFS RESUME FULL-SCREEN MODE 00713000 LA R1,SUBCODE R1 -> STRING 00714000 LA R2,1 R2 = LENGTH 00715000 BAL R14,WRITE TELL VMXFER TO EXIT "SUBSET" 00716000 B CMDLOOP SEND COMMAND AGAIN 00717000 SPACE 00718000 CMDRTN EQU * VALID DATA HAS BEEN READ 00719000 CLC RECVDATA(2),=C'DB' WAS IT A DATA BLOCK? 00720000 BNE CMDSUB NO, SKIP THIS CHECK 00721000 TM TRMFLAGS,GRAFTRM ALWAYS SKIP FOR 3270S 00722000 BO CMDSUB 00723000 BAL R14,COMPDATA SAME AS LAST READ? 00724000 BNE NOTSAME NO, THAT'S TYPICAL 00725000 * ELSE VERY SUSPICIOUS, SO TRY AGAIN 00726000 BAL R14,ZEROLAST DON'T REPEAT THIS 00727000 LA R1,SYN R1 -> STRING 00728000 LA R2,3 R2 = LENGTH 00729000 BAL R14,WRITE WRITE BAD COMMAND 00730000 SYNLOOP RDTERM RECVDATA,EDIT=PHYS,LENGTH=1032 WAIT FOR BAD RESPONSE 00731000 LTR R0,R0 00732000 BNZ SYNLOOP 00733000 B CMDLOOP ASK FOR THIS DATA ONCE MORE 00734000 SPACE 00735000 NOTSAME BAL R14,COPYDATA SAVE DATA WE READ 00736000 CMDSUB BAL R14,TIMEUPD UPDATE XFER RATE 00737000 BAL R14,SUBCHK CHECK FOR SUBSET MODE 00738000 BNZ CMDLOOP IF SUBSET, REPEAT COMMAND 00739000 LM R0,R15,CMMDSAVE RESTORE REGISTERS 00740000 BR R14 RETURN TO CALLER 00741000 SPACE 00742000 ABORT LA R1,ABORTSTR R1 -> STRING 00743000 CLI VERSDATA,C'C' CP/M SYSTEM? 00744000 BNE ASTROK NO, KEEP ABORTSTR 00745000 LA R1,ABRTSTRC USE DIFFERENT STRING 00746000 ASTROK LA R2,3 R2 = LENGTH 00747000 BAL R14,WRITE SEND ABORT COMMAND 00748000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 00749000 LINEDIT TEXT='DMSRMC007E Retry count exceeded', X00750000 DISP=ERRMSG 00751000 LA R15,256 STORE RETURN CODE 00752000 ST R15,RTNCODE 00753000 B CMSRTN RETURN TO CMS 00754000 SPACE 00755000 CMMDSAVE DS 8D LOCAL SAVE AREA 00756000 EJECT 00757000 * RETURN RC IN RECVDATA BUFFER 00758000 * OR 999 IF NO VALID RC 00759000 READRC EQU * 00760000 STM R2,R15,RCSAVE SAVE REGISTERS 00761000 LA R1,999 SET DEFAULT RETURN CODE 00762000 LH R2,RECVLEN MUST HAVE AT LEAST 6 BYTES 00763000 C R2,=F'6' 00764000 BL RCRTN 00765000 CLC RECVDATA(2),=C'RC' MUST START WITH "RC" 00766000 BNE RCRTN 00767000 LA R3,4 R3 = DIGIT COUNT 00768000 LA R4,RECVDATA+2 R4 -> FIRST DIGIT 00769000 SR R5,R5 R5 = RESULT 00770000 CVTLOOP EQU * 00771000 CLI 0(R4),C'0' CHECK FOR VALID DIGIT 00772000 BL RCRTN 00773000 CLI 0(R4),C'9' 00774000 BH RCRTN 00775000 SR R6,R6 CONVERT DIGIT TO BINARY 00776000 IC R6,0(R4) 00777000 S R6,=F'240' 00778000 CVTMULT MH R5,=H'10' RESULT = RESULT*10 + DIGIT 00779000 AR R5,R6 00780000 LA R4,1(R4) R4 -> NEXT DIGIT 00781000 BCT R3,CVTLOOP REPEAT FOR EACH DIGIT 00782000 LR R1,R5 COPY RESULT INTO R1 00783000 RCRTN LM R2,R15,RCSAVE RESTORE REGISTERS 00784000 BR R14 00785000 SPACE 00786000 RCSAVE DS 7D LOCAL SAVE AREA 00787000 EJECT 00788000 * CALCULATE CHECKSUM FOR STRING: R0 = LENGTH, R1 -> CHARACTERS. 00789000 * FOUR-BYTE CHECKSUM RETURNED IN R2. 00790000 CHKCALC EQU * 00791000 STM R0,R15,CHKSAVE SAVE REGISTERS 00792000 SR R5,R5 CHECKSUM = 0 00793000 STC R5,CHKFLAG FLAGS = 0 00794000 L R3,EBCTOASC R3 -> TRANSLATE TABLE 00795000 TM FLAGS2,BINXF ASCII XFER? 00796000 BZ CHKZERO NO, CONTINUE NORMALLY 00797000 C R0,=F'3' AT LEAST 3 CHARACTERS? 00798000 BL CHKZERO NO, CONTINUE NORMALLY 00799000 CLC 0(2,R1),=C'DB' DB RESPONSE? 00800000 BNE CHKZERO 00801000 OI CHKFLAG,CHKBIN SUPPRESS TRANSLATION 00802000 TR 0(2,R1),0(R3) TRANSLATE 'DB' TO ASCII 00803000 CHKZERO LTR R7,R0 00804000 BZ CHKCVT IF LENGTH 0, KEEP 0 CHECKSUM 00805000 LR R6,R1 R6 -> FIRST BYTE, R7 = BCT COUNT 00806000 L R8,=V(CRCTAB) R8 -> CRCTAB 00807000 CHKLOOP EQU * LOOP TO PROCESS EACH BYTE 00808000 SR R4,R4 R4 = DATA BYTE 00809000 IC R4,0(R6) 00810000 TM CHKFLAG,CHKBIN BINARY DATA? 00811000 BO CHKXOR YES, SKIP TRANSLATION 00812000 IC R4,0(R3,R4) TRANSLATE TO ASCII 00813000 CHKXOR XR R4,R5 XOR WITH LOW CHECKSUM BYTE 00814000 N R4,=X'000000FF' 00815000 SRL R5,8 SHIFT CRC RIGHT 8 BITS 00816000 SLL R4,1 GET TABLE INDEX 00817000 LH R4,0(R4,R8) R4 = HALFWORD FROM TABLE 00818000 N R4,=X'0000FFFF' 00819000 XR R5,R4 XOR WITH CHECKSUM 00820000 LA R6,1(R6) R6 -> NEXT BYTE 00821000 BCT R7,CHKLOOP CONTINUE TO END 00822000 CHKCVT STCM R5,B'0011',CHKDATA STORE FINAL CHECKSUM 00823000 UNPK CHKCHAR(5),CHKDATA(3) CONVERT TO HEX CHARS. 00824000 TR CHKCHAR(4),HEXCHARS-240 00825000 MVC CHKSAVE+8(4),CHKCHAR RETURN RESULT IN R2 00826000 TM CHKFLAG,CHKBIN BINARY DATA? 00827000 BZ CHKRTN NO, READY TO RETURN 00828000 MVC 0(2,R1),=C'DB' RESTORE 'DB' IN EBCDIC 00829000 CHKRTN LM R0,R15,CHKSAVE RESTORE REGISTERS 00830000 BR R14 00831000 CHKSAVE DS 8D LOCAL SAVE AREA 00832000 HEXCHARS DC C'0123456789ABCDEF' CHARACTERS FOR HEX CONVERSION 00833000 CHKDATA DS 2X CHECKSUM BYTES 00834000 DS 1X EXTRA BYTE FOR UNPK 00835000 CHKCHAR DS 5X CHARACTER CHECKSUM 00836000 CHKFLAG DS 1X LOCAL FLAG BYTE 00837000 CHKBIN EQU X'01' BINARY DATA 00838000 EJECT 00839000 * 00840000 * "WRITE" OUTPUTS A CHARACTER STRING TO THE TERMINAL. NO EXTRA 00841000 * BYTES (E.G. DC3) ARE TRANSMITTED FOLLOWING THE STRING. 00842000 * AT ENTRY, R1 -> STRING, AND R2 CONTAINS THE STRING LENGTH. 00843000 * 00844000 WRITE DS 0H 00845000 MVI WMODE,0 INDICATE WRITE ONLY 00846000 B WRBOTH 00847000 SPACE 00848000 WRITERD DS 0H 00849000 MVI WMODE,X'FF' INDICATE READ ALSO 00850000 WRBOTH STM R0,R15,WRSAVE SAVE REGISTERS 00851000 TM TRMFLAGS,GRAFTRM 3270 TERMINAL? 00852000 BO WRITEGRF YES, DO 3270 I/O 00853000 LR R3,R1 COPY STRING ADDRESS INTO R3 00854000 * R2 = LENGTH, R3 = ADDRESS OF STRING 00855000 LTR R2,R2 ANY BYTES LEFT? 00856000 BNP WRRTN IF NOT, RETURN 00857000 WRTERM (R3),(R2),EDIT=LONG WRITE (R2) BYTES FROM (R3) 00858000 B WRRTN RETURN 00859000 EJECT 00860000 WRITEGRF EQU * 3270 OUTPUT 00861000 LTR R2,R2 IF NO BYTES, JUST RETURN 00862000 BZ WRRTN 00863000 ***** LR R3,R1 ***** 00864000 ***** FSWRITE 'RMAC DEBUG A',BUFFER=(R3),BSIZE=(R2),RECFM=V ***** 00865000 ***** LR R1,R3 ***** 00866000 * STORE XPARENT OR WSF PREFIX 00867000 TM TRMFLAGS,MAC3270 WSF FOR MAC3270 00868000 BO WSFPFX 00869000 MVC GRAFDATA(7),=X'F3115D7F110000' XPARENT WRITE CODE 00870000 LA R3,7 00871000 CLI WMODE,0 JUST WRITE? 00872000 BE ADDPFX YES, HAVE THE RIGHT PREFIX 00873000 MVI GRAFDATA+6,X'01' ELSE CHANGE TO WRITE/READ 00874000 LA R4,0(R1,R2) R4 -> PAST LAST BYTE 00875000 MVC 0(4,R4),=X'0D256E12' SIMULATE LINE MODE PROMPT 00876000 LA R2,4(R2) ADJUST LENGTH 00877000 B ADDPFX 00878000 SPACE 00879000 WSFPFX EQU * Generate WSF command 00880000 CLI WMODE,0 Just write? 00881000 BE WSFPFXW Yes, go do that 00882000 LA R3,6 R3 = length of 3270DS field 00883000 STCM R3,B'0011',GRAFDATA 00884000 MVC GRAFDATA+2(4),=X'4000F1C2' Unlock keyboard 00885000 LA R3,3(R2) Get xfer WSF length and store 00886000 STCM R3,B'0011',GRAFDATA+6 00887000 MVI GRAFDATA+8,X'20' APPEND XFER CODE 00888000 LA R3,9 R3 = TOTAL LENGTH 00889000 B ADDPFX 00890000 SPACE 00891000 WSFPFXW EQU * 00892000 LA R3,3(R2) GET WSF LENGTH AND STORE 00893000 STCM R3,B'0011',GRAFDATA 00894000 MVI GRAFDATA+2,X'20' APPEND XFER CODE 00895000 LA R3,3 R3 = TOTAL LENGTH 00896000 SPACE 00897000 ADDPFX LA R4,GRAFDATA(R3) R4 -> PAST PREFIX 00898000 LR R6,R1 R6 -> SOURCE DATA 00899000 LR R1,R4 SAVE NEW LOCATION IN R1 00900000 LR R5,R2 R5, R7 = LENGTH 00901000 LR R7,R2 00902000 MVCL R4,R6 COPY DATA TO BUFFER 00903000 L R0,EBCTOASC R0 -> TRANSLATE TABLE 00904000 * R1 = ADDR., R2 = LENGTH 00905000 BAL R14,LONGTR TRANSLATE TO ASCII 00906000 TM TRMFLAGS,MAC3270 SKIP NEXT XLATE IF MAC3270 00907000 BO WRDEFCCW 00908000 L R0,=V(HBITTAB) R0 -> TABLE 00909000 BAL R14,LONGTR TURN ON HIGH BIT OF ALL DATA 00910000 WRDEFCCW LA R3,0(R2,R3) R3 = TOTAL LENGTH 00911000 LH R2,CONADDR R2 = CONSOLE ADDRESS 00912000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 00913000 LA R13,R13SAVE R13 -> SAVE AREA 00914000 TM TRMFLAGS,MAC3270 USE WSF FOR MAC3270 00915000 BO WRWSF 00916000 * ELSE 7171 XPARENT WRITE 00917000 STH R3,WCCWLEN STORE DATA SIZE 00918000 LA R1,WCCW R1 -> CCW 00919000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 00920000 BALR R14,R15 EXECUTE TRANSPARENT WRITE 00921000 BNZ WRRTN RETURN IF ERROR 00922000 BAL R14,READ3270 WAIT FOR ATTN & ISSUE READ 00923000 CLI WMODE,0 JUST WRITE? 00924000 BE WRRTN YES, THEN RETURN NOW 00925000 B WRREAD PROCESS READ 00926000 SPACE 00927000 WRWSF STH R3,WSFCCWLN STORE LENGTH 00928000 LA R1,WSFCCW3 R1 -> CCW 00929000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 00930000 BALR R14,R15 EXECUTE WSF 00931000 BNZ WRRTN RETURN IF ERROR 00932000 CLI WMODE,0 JUST WRITE? 00933000 BE WRRTN YES, THEN RETURN NOW 00934000 BAL R14,READ3270 WAIT FOR ATTN & ISSUE READ 00935000 WRREAD EQU * PROCESS READ 00936000 LA R1,GRAFDATA R1 -> DATA 00937000 LH R2,GRAFLEN R2 = LENGTH 00938000 XC RECVLEN(2),RECVLEN SET LENGTH TO ZERO 00939000 LTR R2,R2 ANY BYTES READ? 00940000 BNP WRRTN NO, JUST RETURN 00941000 ***** LR R3,R1 ***** 00942000 ***** FSWRITE 'RMAC DEBUG A',BUFFER=(R3),BSIZE=(R2),RECFM=V ***** 00943000 ***** LR R1,R3 ***** 00944000 TM TRMFLAGS,MAC3270 FOR MAC3270 SKIP AID 00945000 BO SKIPAID 00946000 CLI 0(R1),X'E8' CHECK FOR NULL AID 00947000 BNE WRRTN RETURN IF NOT THERE 00948000 LA R1,3(R1) SKIP 7171 AID AND ADDR. 00949000 S R2,=F'4' ALSO SKIP CR AT END 00950000 B WRRDCOM 00951000 SPACE 00952000 SKIPAID CLI 0(R1),X'88' CHECK FOR WSF REPLY AID 00953000 BNE WRRTN RETURN IF NOT THERE 00954000 LA R1,1(R1) SKIP AID 00955000 BCTR R2,0 ADJUST LENGTH 00956000 WRRDCOM LTR R2,R2 ANY BYTES LEFT 00957000 BNP WRRTN NO, JUST RETURN 00958000 STH R2,RECVLEN STORE LENGTH FOR RECEIVE 00959000 LR R3,R2 R3, R5 = LENGTH 00960000 LR R5,R2 00961000 LA R2,RECVDATA R2 -> DESTINATION 00962000 LR R4,R1 R4 -> SOURCE 00963000 MVCL R2,R4 MOVE DATA 00964000 L R0,ASCTOEBC R0 -> TRANSLATE TABLE 00965000 LA R1,RECVDATA R1 -> DATA 00966000 LH R2,RECVLEN R2 = LENGTH 00967000 TM FLAGS2,BINXF BINARY TRANSFER? 00968000 BZ WRTXTTR NO, NORMAL TRANSLATE 00969000 C R2,=F'7' AT LEAST DB, CHECKSUM? 00970000 BL WRTXTTR NO, NORMAL TRANSLATE 00971000 CLC 0(2,R1),=X'4442' ASCII 'DB' AT START? 00972000 BNE WRTXTTR NO, NORMAL TRASLATE 00973000 LR R3,R0 R3 -> TRANSLATE TABLE 00974000 TR 0(2,R1),0(R3) TRANSLATE 'DB' 00975000 LA R2,0(R1,R2) R2 -> PAST LAST BYTE 00976000 S R2,=F'5' R2 -> CHECKSUM DELIMITER 00977000 TR 0(5,R2),0(R3) TRANSLATE CD, CHECKSUM 00978000 B WRRTN READY TO RETURN 00979000 SPACE 00980000 WRTXTTR BAL R14,LONGTR TRANSLATE DATA TO EBCDIC 00981000 WRRTN LM R0,R15,WRSAVE RESTORE REGISTERS 00982000 BR R14 RETURN TO CALLER 00983000 SPACE 00984000 WRSAVE DC 8D'0' SAVE AREA FOR R0-R15 00985000 WMODE DS 1X >0 = WRITE, READ FOR 3270 00986000 EJECT 00987000 * 00988000 * SUBCHK - CHECK FOR SUBSET MODE 00989000 * IF THE LAST COMMAND RESULTED IN RETURN CODE 11, ENTER SUBSET MODE, 00990000 * OR KEEP THE RETURN CODE AS IS TO ABORT THE TRANSFER. 00991000 * 00992000 SUBCHK DS 0H 00993000 STM R0,R15,SUBSAVE SAVE REGISTERS 00994000 SR R8,R8 R8 = 0 FOR NORMAL RETURN 00995000 CLC RECVDATA(6),=C'RC0011' ABORT/SUBSET RETURN CODE? 00996000 BNE SUBRETN IF NOT, CONTINUE NORMALLY 00997000 * RESTORE NORMAL TERMINAL ENVIRONMENT TEMPORARILY 00998000 TM TRMFLAGS,GRAFTRM SKIP ASCII STUFF IF 3270 00999000 BO WSUBCODE 01000000 LINEDIT TEXT='TERM LINESIZE 80',DISP=CPCOMM,DOT=NO 01001000 LINEDIT TEXT='SET LINEDIT ON',DISP=CPCOMM,DOT=NO 01002000 DMSEXS MVC,AINTRTBL(4),INTAB RESTORE XLATE TABLES 01003000 DMSEXS MVC,AOUTRTBL(4),OUTTAB 01004000 WSUBCODE LA R1,SUBCODE R1 -> STRING 01005000 LA R2,1 R2 = LENGTH 01006000 BAL R14,WRITE TELL VMXFER TO CALL "SUBSET" 01007000 BAL R14,ENDFS EXIT FULL-SCREEN MODE 01008000 SUBPRMT WRTERM 'Enter ABORT, CONTINUE, or SUBSET',EDIT=NO 01009000 RDTERM RDRESP READ RESPONSE 01010000 CLC RDRESP(7),=CL7'SUBSET' ENTER SUBSET MODE IF WANTED 01011000 BE SUBSET 01012000 CLC RDRESP(6),=CL6'ABORT' ABORT IF WANTED 01013000 BE SUBREST 01014000 CLC RDRESP(9),=CL9'CONTINUE' JUST CONTINUE IF SPECIFIED 01015000 BE SUBCONT 01016000 B SUBPRMT ELSE TRY AGAIN FOR VALID ANSWER 01017000 SPACE 01018000 SUBSET LA R1,SUBCMMD ENTER SUBSET MODE 01019000 SVC 202 "SUBSET" COMMAND 01020000 DC AL4(*+4) 01021000 SUBCONT LA R8,1 INDICATE CP/M COMMAND RETRY 01022000 SUBREST EQU * RESTORE XFER ENVIRONMENT 01023000 BAL R14,BEGINFS RESTORE FULL-SCREEN MODE 01024000 LA R1,SUBCODE R1 -> STRING 01025000 LA R2,1 R2 = LENGTH 01026000 BAL R14,WRITE TELL VMXFER TO RETURN TO MAIN LOOP 01027000 TM TRMFLAGS,GRAFTRM IF 3270, READY TO RETURN 01028000 BO SUBRETN 01029000 MVC INTAB(4),AINTRTBL SAVE "SET INPUT" TABLE 01030000 MVC OUTTAB(4),AOUTRTBL SAVE "SET OUTPUT" TABLE 01031000 DMSEXS XC,AINTRTBL(4),AINTRTBL RESET INPUT TRANSLATION 01032000 DMSEXS XC,AOUTRTBL(4),AOUTRTBL RESET OUTPUT TRANSLATION 01033000 LINEDIT TEXT='SET LINEDIT OFF',DISP=CPCOMM,DOT=NO 01034000 LINEDIT TEXT='TERM LINESIZE OFF',DISP=CPCOMM,DOT=NO 01035000 SUBRETN LTR R8,R8 SET CC FOR CPMCMMD 01036000 LM R0,R15,SUBSAVE RESTORE REGISTERS 01037000 BR R14 RETURN TO CPMCMMD 01038000 SPACE 01039000 SUBSAVE DC 8D'0' SAVE AREA R0-R15 01040000 SUBCMMD DC CL8'SUBSET' "SUBSET" COMMAND 01041000 DC 8X'FF' 01042000 SUBCODE DC X'3C' DC4 IS VMXFER SUBSET CODE 01043000 EJECT 01044000 * 01045000 * CHANGE DATE OF NEW FILE TO DATE OF MAC FILE 01046000 * 01047000 SETDATE DS 0H 01048000 STM R0,R15,SDSAVE SAVE REGISTERS 01049000 DMSKEY NUCLEUS WILL NEED SYSTEM KEY 01050000 * GET EDF DATE FROM CP/M DATE 01051000 PACK HEXBUFF(8),RECVATTR+4(15) CONVERT TO BINARY 01052000 MVC EDFDATE(6),HEXBUFF+1 COPY DATE AND TIME 01053000 YRUNPK UNPK CDFYEAR(3),EDFDATE(2) CHARACTER YEAR FOR CDF FST 01054000 * NOW READY TO UPDATE FST 01055000 LA R1,OUTFILE CALL FSTLKP FOR OUTPUT FILE 01056000 L R15,VCFSTLKP 01057000 BALR R14,R15 01058000 LTR R15,R15 01059000 BNZ SDRTN GIVE UP IF NOT FOUND (STRANGE) 01060000 L R5,AFVS ADDRESS FVSECT 01061000 USING FVSECT,R5 01062000 LR R2,R0 R0 -> ADT 01063000 USING ADTSECT,R2 01064000 LR R3,R1 R1 -> REAL FST 01065000 USING FSTSECT,R3 01066000 OI UFDBUSY,ERBIT UPDATING DISK- PREVENT HX 01067000 TM ADTFLG4,ADTEDF EDF DISK? 01068000 BO SETEDFD YES- SET EDF DATE 01069000 MVC FSTD(4),EDFDATE+1 COPY MM DD HH MM 01070000 MVC FSTYR(2),CDFYEAR COPY CHARACTER YEAR 01071000 B SDEND 01072000 SPACE 01073000 SETEDFD MVC FSTADATI(6),EDFDATE COPY YY MM DD HH MM SS 01074000 SDEND EQU * SET CENTURY FLAG APPROPRIATELY 01075000 OI FSTFB,FSTCNTRY SET BIT (INDICATES 20XX) 01076000 CLI HEXBUFF,X'20' IS YEAR 20XX? 01077000 BE CNTRYOK YES, KEEP AS IS 01078000 NI FSTFB,255-FSTCNTRY FOR 19XX, RESET FLAG 01079000 CNTRYOK EQU * 01080000 L R4,ADTCHBA INDICATE HYPERBLOCK CHANGED 01081000 USING DCHSECT,R4 01082000 OI DCHFLG1,DCHCHGD 01083000 DROP R2,R3,R4 01084000 LR R0,R2 RESTORE POINTER TO ADT 01085000 SR R1,R1 R1 = 0 FOR TFINIS 01086000 L R15,ATFINIS 01087000 BALR R14,R15 CALL TFINIS FOR DISK 01088000 LA R1,1 R1 > 0 FOR UPDISK 01089000 L R15,AUPDISK 01090000 BALR R14,R15 UPDATE DISK DIRECTORY 01091000 KXCHK ERBIT CHECK FOR HX NOW 01092000 DROP R5 END FVSECT ADDRESSING 01093000 SDRTN DMSKEY RESET RESTORE USER KEY 01094000 LM R0,R15,SDSAVE RESTORE REGISTERS 01095000 BR R14 RETURN TO CALLER 01096000 SPACE 01097000 SDSAVE DS 8D REGISTER SAVE AREA 01098000 HEXBUFF DS 1D BUFFER FOR PACK 01099000 EDFDATE DS 6X YY MM DD HH MM SS 01100000 CDFYEAR DS 3X CHARACTER YEAR FOR CDF FST 01101000 EJECT 01102000 * 01103000 * CHANGE DATE OF NEW FILE TO DATE OF CP/M FILE 01104000 * 01105000 SETDATEC DS 0H 01106000 STM R0,R15,SDSAVE SAVE REGISTERS 01107000 DMSKEY NUCLEUS WILL NEED SYSTEM KEY 01108000 * GET EDF DATE FROM CP/M DATE 01109000 TR RECVATTR+4(8),UNHEXTAB "C1" -> "FA" ETC. 01110000 PACK HEXBUFF(5),RECVATTR+4(9) CONVERT TO BINARY 01111000 MVC EDFDATE+3(2),HEXBUFF+2 COPY HOURS, MINUTES 01112000 MVI EDFDATE+5,0 SECONDS = 0 01113000 SR R3,R3 R3 = JULIAN DATE 01114000 ICM R3,B'0011',HEXBUFF 01115000 A R3,=F'28429' ADD CP/M ADJUSTMENT 01116000 * GET 4*JDATE + 3 01117000 SLL R3,2 01118000 LA R3,3(R3) 01119000 SR R2,R2 DIVIDE BY 1461 01120000 D R2,=F'1461' 01121000 * R2 = DAY, R3 = YEAR 01122000 SRL R2,2 DAY = DAY/4 + 1 01123000 LA R2,1(R2) 01124000 MH R2,=H'5' GET (5*DAY-3)/153 01125000 S R2,=F'3' 01126000 SR R4,R4 01127000 LR R5,R2 01128000 D R4,=F'153' 01129000 * R4 = DAY, R5 = MONTH 01130000 LR R2,R5 R2 = MONTH 01131000 SR R0,R0 DAY = DAY/5 + 1 01132000 LR R1,R4 01133000 D R0,=F'5' 01134000 LA R1,1(R1) R1 = DAY, R2 = MONTH, R3 = YEAR 01135000 LA R2,3(R2) MONTH = MONTH + 3 01136000 C R2,=F'12' IF > 12, SUBTRACT 12 01137000 BNH KEEPMON 01138000 S R2,=F'12' 01139000 LA R3,1(R3) AND ADD 1 TO YEAR 01140000 KEEPMON EQU * 01141000 SR R0,R0 GET BCD DAY 01142000 D R0,=F'10' 01143000 SLL R1,4 SHIFT TENS DIGIT 01144000 AR R1,R0 ADD ONES DIGIT 01145000 STC R1,EDFDATE+2 STORE DAY 01146000 SR R0,R0 GET BCD MONTH 01147000 LR R1,R2 01148000 D R0,=F'10' 01149000 SLL R1,4 SHIFT TENS DIGIT 01150000 AR R1,R0 ADD ONES DIGIT 01151000 STC R1,EDFDATE+1 STORE MONTH 01152000 SR R0,R0 GET BCD YEAR 01153000 LR R1,R3 01154000 D R0,=F'10' 01155000 SLL R1,4 SHIFT TENS DIGIT 01156000 AR R1,R0 ADD ONES DIGIT 01157000 STC R1,EDFDATE STORE YEAR 01158000 MVI HEXBUFF,X'19' 19XX YEAR FOR SHARED CODE 01159000 B YRUNPK JOIN MAC CODE 01160000 SPACE 01161000 UNHEXTAB DC 256AL1(*-UNHEXTAB) TABLE TO PREPARE FOR PACK 01162000 ORG UNHEXTAB+C'A' 01163000 DC X'FAFBFCFDFEFF' 01164000 ORG 01165000 EJECT 01166000 ZEROLAST STM R0,R3,SAVE4 SAVE REGISTERS 01167000 L R0,=A(RECVLAST) ADDRESS OF BUFFER 01168000 LA R1,1032 SIZE OF BUFFER 01169000 SR R2,R2 ZEROS FOR SOURCE 01170000 SR R3,R3 01171000 MVCL R0,R2 ZERO BUFFER 01172000 LM R0,R3,SAVE4 RESTORE REGISTERS 01173000 BR R14 RETURN TO CALLER 01174000 SPACE 01175000 ZERODATA STM R0,R3,SAVE4 SAVE REGISTERS 01176000 LA R0,RECVDATA ADDRESS OF BUFFER 01177000 LA R1,1032 SIZE OF BUFFER 01178000 SR R2,R2 ZEROS FOR SOURCE 01179000 SR R3,R3 01180000 MVCL R0,R2 ZERO BUFFER 01181000 LM R0,R3,SAVE4 RESTORE REGISTERS 01182000 BR R14 RETURN TO CALLER 01183000 SPACE 01184000 COPYDATA STM R0,R3,SAVE4 SAVE REGISTERS 01185000 L R0,=A(RECVLAST) DESTINATION ADDR. & LENGTH 01186000 LA R1,1032 01187000 LA R2,RECVDATA SOURCE ADDR. & LENGTH 01188000 LA R3,1032 01189000 MVCL R0,R2 COPY DATA 01190000 LM R0,R3,SAVE4 RESTORE REGISTERS 01191000 BR R14 RETURN TO CALLER 01192000 SPACE 01193000 COMPDATA STM R0,R3,SAVE4 SAVE REGISTERS 01194000 L R0,=A(RECVLAST) DESTINATION ADDR. & LENGTH 01195000 LA R1,1032 01196000 LA R2,RECVDATA SOURCE ADDR. & LENGTH 01197000 LA R3,1032 01198000 CLCL R0,R2 COMPARE DATA 01199000 LM R0,R3,SAVE4 RESTORE REGISTERS 01200000 BR R14 RETURN TO CALLER 01201000 SPACE 01202000 SAVE4 DS 2D SAVE AREA R0-R15 01203000 EJECT 01204000 * 01205000 * SUBROUTINE TO UPDATE TRANSFER RATE FROM LAST COMMAND TIMING 01206000 * 01207000 TIMEUPD DS 0H 01208000 STM R0,R15,TIMESAVE SAVE REGISTERS 01209000 L R1,WRCNT GET TOTAL CHARACTER COUNT 01210000 A R1,RDCNT 01211000 CLC SENDDATA(2),=C'RB' ALWAYS USE COUNT FOR RB COMMAND 01212000 BE USECOUNT 01213000 C R1,=F'1024' IGNORE IF < 1024 01214000 BL TIMERTN 01215000 USECOUNT EQU * READY TO USE TOTAL COUNT IN R1 01216000 A R1,TOTCHRS UPDATE TOTAL CHARACTERS 01217000 ST R1,TOTCHRS 01218000 LM R2,R3,ENDTIME GET ELAPSED TIME 01219000 SRDL R2,12 SHIFT TO GET MICROSECONDS 01220000 LM R4,R5,STRTTIME 01221000 SRDL R4,12 01222000 SLR R3,R5 GET LOW-ORDER DIFFERENCE 01223000 BNM MSSUB IF NO BORROW, READY FOR REST 01224000 SL R2,=F'1' PERFORM BORROW 01225000 MSSUB SLR R2,R4 GET HIGH-ORDER DIFFERENCE 01226000 LM R4,R5,TOTSECS GET PREVIOUS TOTAL 01227000 ALR R3,R5 GET LOW-ORDER SUM 01228000 BC 12,MSADD IF NO CARRY, READY FOR REST 01229000 AL R2,=F'1' PERFORM CARRY 01230000 MSADD ALR R2,R4 GET HIGH-ORDER RUM 01231000 STM R2,R3,TOTSECS STORE NEW TOTAL 01232000 D R2,=F'1000000' DIVIDE BY 1000000 TO GET SECONDS 01233000 C R2,=F'500000' IS REMAINDER MORE THAN HALF? 01234000 BNH USESECS NO, KEEP QUOTIENT 01235000 AL R3,=F'1' ELSE ADD 1 01236000 USESECS LTR R3,R3 ZERO SECONDS? 01237000 BZ TIMERTN YES, JUST RETURN 01238000 SR R0,R0 R0,R1 = TOTAL CHARACTERS 01239000 DR R0,R3 DIVIDE TO GET CHARS./SECOND IN R1 01240000 SRL R3,1 R3 = HALF OF SECONDS 01241000 CR R0,R3 IS REMAINDER MORE THAN HALF? 01242000 BNH USERATE NO, KEEP QUOTIENT 01243000 AL R1,=F'1' ELSE ADD 1 01244000 USERATE CVD R1,DECBUF CONVERT TO PACKED DECIMAL 01245000 UNPK DECBUF(5),DECBUF+5(3) CONVERT TO CHARS. 01246000 OI DECBUF+4,X'F0' FIX FIRST NIBBLE OF LAST BYTE 01247000 MVC XFSPEED(4),DECBUF+1 UPDATE XFSPEED WITH RESULT 01248000 TIMERTN LM R0,R15,TIMESAVE RESTORE REGISTERS 01249000 BR R14 RETURN 01250000 SPACE 01251000 TIMESAVE DS 8D LOCAL SAVE AREA 01252000 EJECT 01253000 * 01254000 * TERMTYPE - subroutine to determine terminal information and 01255000 * set TRMFLAGS accordingly. The 3270 console address 01256000 * is also determined and saved. 01257000 * 01258000 TERMTYPE DS 0H 01259000 STM R0,R15,TRMSAVE SAVE REGISTERS 01260000 L R4,=F'-1' GET CONSOLE ADDR. FROM CP 01261000 DIAG R4,R5,X'24' GET CONSOLE CHARACTERISTICS 01262000 BNZ TRMDONE IF ANY ERROR, TREAT AS ASCII 01263000 STCM R4,B'0011',CONADDR SAVE CONSOLE ADDRESS 01264000 LA R4,GRTSIZE GET GRAFTAB SIZE 01265000 LA R5,GRAFTAB R5 -> START OF TABLE 01266000 GRTLOOP EQU * CHECK FOR REAL 3270 01267000 CLM R6,B'1100',0(R5) CHECK REAL CLASS & TYPE 01268000 BE TRM3270 HAVE A 3270 IF MATCH 01269000 LA R5,4(R5) R5 -> NEXT ENTRY 01270000 BCT R4,GRTLOOP LOOP THROUGH TABLE 01271000 B TRMDONE TREAT AS ASCII IF NO MATCH 01272000 SPACE 01273000 TRM3270 EQU * NOW CHECK MODEL NUMBER 01274000 TM 3(R5),WSF MIGHT WSF BE SUPPORTED? 01275000 BZ MDLINIT NO, SKIP TO MODEL TEST 01276000 OI TRMFLAGS,SFDEV INDICATE WSF MAY WORK 01277000 MDLINIT LA R4,MDLSIZE GET MDLTAB SIZE 01278000 LA R5,MDLTAB R5 -> START OF TABLE 01279000 MDLLOOP EQU * SCAN FOR MATCHING MODEL 01280000 CLM R6,B'0010',0(R5) COMPARE MODELS 01281000 BE USE3270 READY TO USE IF A MATCH 01282000 LA R5,3(R5) R5 -> NEXT ENTRY 01283000 BCT R4,MDLLOOP LOOP THROUGH TABLE 01284000 MVI TRMFLAGS,0 TREAT AS ASCII IF NO MATCH 01285000 B TRMDONE 01286000 SPACE 01287000 USE3270 OI TRMFLAGS,GRAFTRM INDICATE 3270 TERMINAL 01288000 * Open path for 3270 I/O 01289000 LH R2,CONADDR 01290000 CONSOLE OPEN,PATH='ONE',DEVICE=(R2),BUFFER=(OPENINFO,112), X01291000 EXIT=UNSOL 01292000 LTR R4,R15 01293000 BZ OPENGOOD 01294000 LINEDIT TEXT='DMSRMC015E Error ..... from CONSOLE OPEN', X01295000 SUB=(DEC,(R4)) 01296000 LA R15,100(R4) 01297000 ST R15,RTNCODE 01298000 B CMSRTN 01299000 SPACE , 01300000 OPENGOOD EQU * Console path created 01301000 OI FLAGS3,PATHOPEN Set flag to issue close later 01302000 * CHECK FOR VTAM CONNECTION 01303000 LA R1,MSGOFF R1 -> TERM BREAKIN COMMAND 01304000 LA R3,MSGOFFLB R3 = COMMAND LENGTH 01305000 ICM R3,B'1000',=X'40' INDICATE RESPONSE IN A BUFFER 01306000 LA R2,RECVDATA R2 -> BUFFER 01307000 LA R4,128 R4 = BUFFER LENGTH 01308000 DIAG R1,R3,8 EXECUTE COMMAND 01309000 LTR R3,R3 DID IT WORK? 01310000 BZ NOTVTAM YES, MUST NOT BE VTAM 01311000 OI TRMFLAGS,VTAM SET VTAM FLAG 01312000 B VTAMEND 01313000 SPACE 01314000 NOTVTAM LA R1,MSGON RESTORE BREAKIN DEFAULT 01315000 LA R3,MSGONLB 01316000 DIAG R1,R3,8 01317000 VTAMEND BAL R14,BEGINFS ENTER FULL-SCREEN MODE 01318000 TM TRMFLAGS,SFDEV ANY POINT IN ISSUING WSF? 01319000 BZ TRMDONE NO, JUST RETURN 01320000 TRYWSF1 LA R1,WSFCCW1 R1 -> WSF CCW 01321000 LH R2,CONADDR R2 = CONSOLE ADDRESS 01322000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 01323000 LA R13,R13SAVE R13 -> SAVE AREA 01324000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01325000 BALR R14,R15 EXECUTE WSF QUERY REPLY 01326000 BZ WSFREAD IF OK, READ AND INTERPRET 01327000 C R15,=X'0000008E' LINE-MODE INPUT WAITING? 01328000 BNE TRMDONE NO, MUST NOT BE SUPPORTED 01329000 RDTERM RECVDATA READ LINE MODE INPUT 01330000 B TRYWSF1 TRY AGAIN 01331000 SPACE 01332000 WSFREAD BAL R14,READ3270 READ RESPONSE INTO GRAFDATA 01333000 LA R2,GRAFDATA R2 -> START OF DATA 01334000 LH R3,GRAFLEN R3 = LENGTH OF DATA 01335000 C R3,=F'3' AT LEAST AID AND LENGTH? 01336000 BL TRMDONE IF NOT, NOTHING TO DO (STRANGE) 01337000 CLI 0(R2),X'88' CORRECT AID BYTE? 01338000 BNE TRMDONE NO, ALSO STRANGE 01339000 LA R2,1(R2) R2 -> FIRST FIELD 01340000 BCTR R3,0 R3 = BYTES REMAINING 01341000 * LOOP TO PROCESS FIELDS 01342000 QRNEWFLD EQU * START NEW FIELD 01343000 C R3,=F'4' AT LEAST 4 BYTES LEFT? 01344000 BL TRMDONE NO, MUST BE DONE 01345000 CLI 2(R2),X'81' QUERY REPLY ID? 01346000 BNE TRMDONE NO, CAN'T DEAL WITH THIS 01347000 SR R4,R4 GET FIELD LENGTH IN R4 01348000 ICM R4,B'0011',0(R2) 01349000 CR R3,R4 EXIT IF NOT THAT MUCH LEFT 01350000 BL TRMDONE (SHOULDN'T HAPPEN) 01351000 CLI 3(R2),X'80' SUMMARY CODE? 01352000 BNE QRNXTFLD NO, TRY NEXT FIELD 01353000 LA R5,4(R2) R5 -> FIRST SUMMARY CODE 01354000 LR R6,R3 R6 = COUNT OF CODES 01355000 S R6,=F'4' 01356000 BNP TRMDONE DONE IF NOT > 0 01357000 QRPQLP EQU * LOOK FOR RQPNAMES CODE 01358000 CLI 0(R5),X'A1' FOUND THE CODE 01359000 BE FOUNDRPQ YES, PROCESS 01360000 LA R5,1(R5) R5 -> NEXT CODE 01361000 BCT R6,QRPQLP TRY NEXT 01362000 B TRMDONE EXIT IF NOT FOUND 01363000 SPACE 01364000 QRNXTFLD AR R2,R4 INCREMENT POINTER 01365000 SR R3,R4 DECREMENT BYTES LEFT 01366000 B QRNEWFLD REPEAT TO END OF DATA 01367000 SPACE 01368000 FOUNDRPQ EQU * RETRIEVE RPQ NAMES DATA 01369000 TRYWSF2 LA R1,WSFCCW2 R1 -> WSF CCW 01370000 LH R2,CONADDR R2 = CONSOLE ADDRESS 01371000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 01372000 LA R13,R13SAVE R13 -> SAVE AREA 01373000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01374000 BALR R14,R15 EXECUTE WSF QUERY REPLY 01375000 BZ RPQREAD IF OK, READ AND INTERPRET 01376000 C R15,=X'0000008E' LINE-MODE INPUT WAITING? 01377000 BNE TRMDONE NO, MUST NOT BE SUPPORTED 01378000 RDTERM RECVDATA READ LINE MODE INPUT 01379000 B TRYWSF2 TRY AGAIN 01380000 SPACE 01381000 RPQREAD BAL R14,READ3270 READ RESPONSE INTO GRAFDATA 01382000 LH R2,GRAFLEN GET SIZE OF RESPONSE 01383000 C R2,=F'19' AT LEAST 19 BYTES? 01384000 BL TRMDONE NO, CAN'T USE 01385000 CLI GRAFDATA,X'88' QUERY REPLY AID? 01386000 BNE TRMDONE NO, CAN'T USE 01387000 CLC GRAFDATA+3(2),=X'81A1' CORRECT REPLY? 01388000 BNE TRMDONE NO, CAN'T USE 01389000 CLC GRAFDATA+5(4),=C'GFTM' CORRECT DEVICE? 01390000 BNE TRMDONE NO, CAN'T USE 01391000 OI TRMFLAGS,MAC3270 SET MAC3270 FLAG 01392000 MVI M3270VER,C'A' 'A' FOR APPLETALK 01393000 MVC M3270VER+1(2),GRAFDATA+14 COPY VERSION 01394000 MVC M3270VER+3(2),GRAFDATA+17 01395000 TRMDONE LM R0,R15,TRMSAVE RESTORE REGISTERS 01396000 BR R14 RETURN 01397000 TRMSAVE DS 8D LOCAL SAVE AREA 01398000 SPACE 01399000 * 3270 LIST OF RDEVTYPC, RDEVTYPE, ERASE/WRITE OR ERASE/WRITE ALT. BITS 01400000 * AND MASK FOR APL/TEXT SUPPORT 01401000 GRAFTAB EQU * 01402000 DC AL1(CLASGRAF,TYP3277),X'80',AL1(0) LOCAL 3277 01403000 DC AL1(CLASGRAF,TYP3278),X'C0',AL1(WSF) LOCAL 3278,3279 01404000 DC AL1(CLASGRAF,TYP3276),X'C0',AL1(0) LOCAL 3276 01405000 DC AL1(CLASGRAF,TYP3275),X'80',AL1(0) LOCAL 3275 01406000 DC AL1(CLASTERM,TYP3277),X'80',AL1(0) REMOTE 3277 01407000 DC AL1(CLASTERM,TYP3278),X'C0',AL1(WSF) REMOTE 3278,3279 01408000 DC AL1(CLASTERM,TYP3276),X'C0',AL1(0) REMOTE 3276 01409000 DC AL1(CLASTERM,TYP3275),X'80',AL1(0) REMOTE 3275 01410000 GRTSIZE EQU (*-GRAFTAB)/4 NUMBER OF TABLE ENTRIES 01411000 SPACE 01412000 CLASTERM EQU X'80' TERMINAL DEVICE CLASS 01413000 CLASGRAF EQU X'40' GRAPHICS DEVICE CLASS 01414000 TYP3277 EQU X'04' 3277 DISPLAY STATION 01415000 TYP3276 EQU X'03' 3276 DISPLAY STATION 01416000 TYP3275 EQU X'02' 3275 DISPLAY STATION 01417000 TYP3278 EQU X'01' 3278 DISPLAY STATION 01418000 TYP3215 EQU X'00' 3215 CONSOLE 01419000 SPACE 01420000 WSF EQU X'01' WSF IS POTENTIALLY SUPPORTED 01421000 SPACE 01422000 * TABLE OF MODEL NUMBER BYTE , ROW COUNT, AND SCREEN WIDTH 01423000 MDLTAB EQU * 01424000 DC X'02',AL1(24),AL1(80) 24 ROWS, 80 COLUMNS 01425000 DC X'2A',AL1(20),AL1(80) 20 ROWS, 80 COLUMNS 01426000 DC X'03',AL1(32),AL1(80) 32 ROWS, 80 COLUMNS 01427000 DC X'04',AL1(43),AL1(80) 43 ROWS, 80 COLUMNS 01428000 DC X'05',AL1(27),AL1(132) 27 ROWS, 132 COLUMNS 01429000 DC X'01',AL1(12),AL1(80) 12 ROWS, 80 COLUMNS 01430000 MDLSIZE EQU (*-MDLTAB)/3 NUMBER OF TABLE ENTRIES 01431000 EJECT 01432000 * 01433000 * BEGINFS and ENDFS: subroutines to enter and leave 3270 01434000 * full-screen mode 01435000 DS 0H 01436000 BEGINFS EQU * 01437000 TM TRMFLAGS,GRAFTRM 3270 TERMINAL? 01438000 BZR R14 NO, JUST IGNORE 01439000 TM FLAGS,FS3270 ALREADY IN FULL-SCREEN MODE? 01440000 BOR R14 YES, JUST RETURN 01441000 STM R0,R15,FSSAVE SAVE REGISTERS 01442000 LA R1,MSGOFF R1 -> CP COMMANDS 01443000 LA R2,MSGOFFL R2 = LENGTH 01444000 TM TRMFLAGS,VTAM VTAM CONNECTION? 01445000 BZ OFFDIAG NO, CONTINUE 01446000 LA R1,MSGOFFV R1 -> VTAM CP COMMANDS 01447000 LA R2,MSGOFFVL R2 = LENGTH 01448000 OFFDIAG DIAG R1,R2,8 EXECUTE COMMANDS TO SUPPRESS MSGS. 01449000 LA R1,CANCLCCW R1 -> CANCEL CCW 01450000 LH R2,CONADDR R2 = CONSOLE ADDRESS 01451000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 01452000 LA R13,R13SAVE R13 -> SAVE AREA 01453000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01454000 BALR R14,R15 EXECUTE CANCEL CCW 01455000 * NOTE: INTERRUPTS ARE NOW DISABLED 01456000 MVC GRAFDATA(4),=X'F3114040' WRITE WCC, SBA 01457000 MVC WCCWLEN(2),=H'4' LENGTH (OF WCC) = 1 01458000 LA R1,WCCW R1 -> CCW 01459000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01460000 BALR R14,R15 ERASE/WRITE FOR FULL-SCREEN MODE 01461000 OI FLAGS,FS3270 REMEMBER IN FULL-SCREEN MODE 01462000 LM R0,R15,FSSAVE RESTORE REGISTERS 01463000 BR R14 RETURN TO CALLER 01464000 SPACE 01465000 ENDFS EQU * END FULL-SCREEN MODE 01466000 TM FLAGS,FS3270 IN FULL-SCREEN MODE? 01467000 BZR R14 NO, JUST RETURN 01468000 STM R0,R15,FSSAVE SAVE REGISTERS 01469000 LH R2,CONADDR R2 = CONSOLE ADDRESS 01470000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 01471000 LA R13,R13SAVE R13 -> SAVE AREA 01472000 MVC GRAFDATA(4),=X'F1114040' WRITE CCW, SBA 01473000 MVC WCCWLEN(2),=H'4' LENGTH (OF WCC) = 1 01474000 LA R1,WCCW R1 -> CCW 01475000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01476000 BALR R14,R15 CLEAR SCREEN, LOCK KEYBOARD 01477000 ENABLE INTTYPE=ALL Re-enable interrupts 01478000 LA R1,MSGON R1 -> CP COMMANDS 01479000 LA R2,MSGONL R2 = LENGTH 01480000 TM TRMFLAGS,VTAM VTAM CONNECTION? 01481000 BZ ONDIAG NO, CONTINUE 01482000 LA R1,MSGONV R1 -> VTAM CP COMMANDS 01483000 LA R2,MSGONVL R2 = LENGTH 01484000 ONDIAG DIAG R1,R2,8 EXECUTE COMMANDS TO ALLOW MSGS. 01485000 NI FLAGS,255-FS3270 REMEMBER NOT IN FULL-SCREEN MODE 01486000 LM R0,R15,FSSAVE RESTORE REGISTERS 01487000 BR R14 RETURN TO CALLER 01488000 SPACE 01489000 FSSAVE DS 8D LOCAL SAVE AREA 01490000 R13SAVE DS 12D STANDARD SAVE AREA FOR SCRNIO 01491000 CANCLCCW DC X'1900000020FF0001' DISPW CANCEL CCW 01492000 MSGOFF DC C'TERM BREAKIN GUESTCTL' CP COMMANDS FOR NO MESSAGES 01493000 MSGOFFLB EQU *-MSGOFF LENGTH OF TERM BREAKIN COMMAND 01494000 DC X'15' 01495000 DC C'SET WNG OFF' 01496000 MSGOFFL EQU *-MSGOFF 01497000 MSGON DC C'TERM BREAKIN IMMED' CP COMMANDS TO RESTORE MESSAGES 01498000 MSGONLB EQU *-MSGON LENGTH OF TERM BREAKIN COMMAND 01499000 DC X'15' 01500000 DC C'SET WNG ON' 01501000 MSGONL EQU *-MSGON 01502000 MSGOFFV DC C'SET MSG OFF' VTAM CP COMMANDS FOR NO MESSAGES 01503000 DC X'15' 01504000 DC C'SET WNG OFF' 01505000 MSGOFFVL EQU *-MSGOFFV 01506000 MSGONV DC C'SET MSG ON' VTAM CP COMMANDS TO RESTORE MESSAGES 01507000 DC X'15' 01508000 DC C'SET WNG ON' 01509000 MSGONVL EQU *-MSGONV 01510000 EJECT 01511000 * 01512000 * READ3270: Wait for attention from console and issue read-modified 01513000 * 01514000 READ3270 DS 0H 01515000 STM R0,R15,RDMSAVE Save registers 01516000 LH R1,UNSOLIS Any unsolicited interrupts? 01517000 LTR R1,R1 01518000 BZ RDATTN No, wait for attention 01519000 BCTR R1,0 Decrement interrupt count 01520000 STH R1,UNSOLIS 01521000 B DORDMOD Do read-modified right away 01522000 SPACE , 01523000 RDATTN EQU * Wait for attention 01524000 CONSOLE WAIT,PATH='ONE' 01525000 LTR R15,R15 Check for an error 01526000 BNZ RDERR 01527000 DORDMOD EQU * Perform read modified 01528000 LA R1,RCCW R1 -> READ-MODIFIED CCW 01529000 LH R2,CONADDR R2 = CONSOLE ADDRESS 01530000 ICM R2,B'1000',=X'01' INDICATE CMS CONSOLE 01531000 LA R13,R13SAVE R13 -> SAVE AREA 01532000 L R15,=V(SCRNIO) R15 -> ENTRY POINT 01533000 BALR R14,R15 DO FULL-SCREEN READ 01534000 BNZ RDERR CHECK FOR ANY ERROR 01535000 L R1,=F'4096' BYTES READ = BUFFER LENGTH 01536000 SR R1,R0 - RESIDUAL COUNT 01537000 STH R1,GRAFLEN STORE READ LENGTH 01538000 B RDMRTN READY TO RETURN 01539000 SPACE 01540000 RDERR SR R1,R1 FOR ERROR, RETURN SIZE 0 01541000 STH R1,GRAFLEN 01542000 RDMRTN LM R0,R15,RDMSAVE RESTORE REGISTERS 01543000 BR R14 RETURN TO CALLER 01544000 SPACE 01545000 RDMSAVE DS 8D LOCAL SAVE AREA 01546000 SPACE 01547000 UNSOL EQU * Unsolicited interrupt handler 01548000 ST R4,R4SAVE Save work register 01549000 LH R4,UNSOLIS Increment count of interrupts 01550000 LA R4,1(R4) 01551000 STH R4,UNSOLIS 01552000 L R4,R4SAVE Restore register 01553000 BR R14 Return to whatever was executing 01554000 SPACE 01555000 R4SAVE DS 1F Save area for work register 01556000 EJECT 01557000 * 01558000 * LONGTR - execute TR for arbitrary length string 01559000 * R0 -> table, R1 -> string, R2 = length 01560000 * 01561000 LONGTR DS 0H 01562000 STM R0,R5,TRSAVE SAVE REGISTERS 01563000 LR R4,R0 R4 -> TRANSLATE TABLE 01564000 LR R3,R2 R3 = BYTES LEFT 01565000 SRL R3,8 SHIFT TO GET BCT COUNT 01566000 LTR R3,R3 IF ZERO, SKIP LOOP 01567000 BZ TREND 01568000 LTRLOOP EQU * LOOP FOR 256-BYTE PIECES 01569000 TR 0(256,R1),0(R4) DO THIS PIECES 01570000 LA R1,256(R1) INCREMENT ADDRESS 01571000 S R2,=F'256' DECREMENT LENGTH 01572000 BCT R3,LTRLOOP 01573000 TREND LTR R2,R2 RETURN IF NO BYTES LEFT 01574000 BZ TRRTN 01575000 BCTR R2,0 DECREMENT FOR EXECUTE 01576000 EX R2,TRINST 01577000 TRRTN LM R0,R5,TRSAVE RESTORE REGISTERS 01578000 BR R14 RETURN 01579000 SPACE 01580000 TRSAVE DS 3D LOCAL REGISTER SAVE AREA 01581000 TRINST TR 0(*-*,R1),0(R4) INSTRUCTION FOR EX 01582000 EJECT 01583000 * 01584000 * USEXL - Generate national language xtab from the response to 01585000 * the XL command. 01586000 * 01587000 USEXL STM R0,R15,XLSAVE Save registers 01588000 LH R2,RECVLEN R2 = size of response 01589000 C R2,=F'6' At least 6 bytes? 01590000 BL USEXLRTN No, return 01591000 L R1,=A(RECVDATA) R1 -> response 01592000 CLC 0(2,R1),=C'XI' Correct response? 01593000 BNE USEXLRTN No, return 01594000 S R2,=F'2' R2 = length of hex info. 01595000 LA R1,2(R1) R1 -> start of hex info. 01596000 L R3,=A(NLXTAB) R3 -> table we generate 01597000 LA R4,256 R4 = table size 01598000 SR R5,R5 R5 = starting value 01599000 XLINILP EQU * Initialize table 01600000 STC R5,0(R3) Store this value 01601000 LA R5,1(R5) Increment value 01602000 LA R3,1(R3) Increment pointer 01603000 BCT R4,XLINILP Repeat for entire table 01604000 L R0,=A(HEXTAB) R0 -> Hex conversion table 01605000 BAL R14,LONGTR Convert hex info. 01606000 SRL R2,2 R2 = count of hex pairs 01607000 L R6,=A(NLXTAB) R6 -> table to modify 01608000 XLCVTLP EQU * Loop to convert hex info. 01609000 CLI 0(R1),0 Exit if invalid data 01610000 BE USEXLRTN 01611000 CLI 1(R1),0 01612000 BE USEXLRTN 01613000 CLI 2(R1),0 01614000 BE USEXLRTN 01615000 CLI 3(R1),0 01616000 BE USEXLRTN 01617000 SR R3,R3 Get first hex digit 01618000 IC R3,0(R1) 01619000 S R3,=F'240' 01620000 LR R4,R3 Save in R4 01621000 SR R3,R3 Get second hex digit 01622000 IC R3,1(R1) 01623000 S R3,=F'240' 01624000 SLL R4,4 Add to first value 01625000 AR R4,R3 01626000 SR R3,R3 Get third hex digit 01627000 IC R3,2(R1) 01628000 S R3,=F'240' 01629000 LR R5,R3 Save in R5 01630000 SR R3,R3 Get fourth hex digit 01631000 IC R3,3(R1) 01632000 S R3,=F'240' 01633000 SLL R5,4 Add to second value 01634000 AR R5,R3 01635000 STC R4,0(R5,R6) Store new table value 01636000 LA R1,4(R1) R1 -> next pair 01637000 BCT R2,XLCVTLP Repeat for all hex info. 01638000 OI FLAGS3,NLXT Set table valid flag 01639000 USEXLRTN LM R0,R15,XLSAVE Restore registers 01640000 BR R14 Return 01641000 SPACE 01642000 XLSAVE DS 8D Register save area 01643000 EJECT 01644000 * 01645000 * RMAC DATA AREA: 01646000 * 01647000 ENDTIME DS 1D END TIME FOR RATE CALC. 01648000 DECBUF DS 2D BUFFER FOR CONVERSIONS 01649000 STRTTIME DS 1D START TIME FOR RATE CALC. 01650000 TOTSECS DS 1D TOTAL ELAPSED TIME 01651000 WCCW DS 0D 3270 WRITE CCW 01652000 DC X'29' OP-CODE 01653000 DC AL3(GRAFDATA) BUFFER ADDRESS 01654000 DC X'20' CCW FLAG BITS 01655000 DC X'80' CONTROL BITS FOR CP 01656000 WCCWLEN DC AL2(*-*) LENGTH 01657000 WSFCCW1 DS 0D 3270 WSF CCW 01658000 DC X'29' OP-CODE 01659000 DC AL3(WSFQRCMD) BUFFER ADDRESS 01660000 DC X'20' CCW FLAG BITS 01661000 DC X'20' CONTROL BITS FOR CP 01662000 DC AL2(5) LENGTH 01663000 WSFCCW2 DS 0D 3270 WSF CCW 01664000 DC X'29' OP-CODE 01665000 DC AL3(WSFRPQ) BUFFER ADDRESS 01666000 DC X'20' CCW FLAG BITS 01667000 DC X'20' CONTROL BITS FOR CP 01668000 DC AL2(7) LENGTH 01669000 WSFCCW3 DS 0D 3270 WSF CCW 01670000 DC X'29' OP-CODE 01671000 DC AL3(GRAFDATA) BUFFER ADDRESS 01672000 DC X'20' CCW FLAG BITS 01673000 DC X'20' CONTROL BITS FOR CP 01674000 WSFCCWLN DC AL2(*-*) LENGTH 01675000 RCCW DS 0D 3270 READ CCW 01676000 DC X'2A' OP-CODE 01677000 DC AL3(GRAFDATA) BUFFER ADDRESS 01678000 DC X'20' CCW FLAG BITS 01679000 DC X'80' CONTROL BITS FOR CP 01680000 DC AL2(4096) LENGTH 01681000 VTAMCCW DS 0D 3270 WRITE TO PREP. VTAM 01682000 DC X'29' OP-CODE 01683000 DC AL3(VTAMPREP) BUFFER ADDRESS 01684000 DC X'20' CCW FLAG BITS 01685000 DC X'80' CONTROL BITS FOR CP 01686000 DC AL2(VTAMPRPL) LENGTH 01687000 BUFSIZE DS 1F NO. OF BYTES IN OUTBUF 01688000 RETRYCNT DS 1F RETRY COUNT FOR ALL BLOCKS 01689000 WRCNT DS 1F BYTES WRITTEN FOR RATE CALC. 01690000 RDCNT DS 1F BYTES READ FOR RATE CALC. 01691000 TOTCHRS DS 1F TOTAL CHARACTERS FOR RATE CALC. 01692000 INTAB DS 1A SAVED USER INPUT TABLE 01693000 OUTTAB DS 1A SAVED USER OUTPUT TABLE 01694000 EBCTOASC DS 1A A(EBCDIC TO ASCII TABLE) 01695000 ASCTOEBC DS 1A A(ASCII TO EBCIDC TABLE) 01696000 TBLREF DC V(TRTABLES) CAUSE AUTOMATIC LOAD OF TRTABLES 01697000 OUTFILE FSCB , OUTPUT FILE CONTROL BLOCK 01698000 OUTBUF DS CL256 BUFFER FOR OUTPUT FILE DATA 01699000 EJECT 01700000 OPTTAB DS 0F OPTION PROCESSING TABLE 01701000 DC CL8'BINARY',AL4(BINOPT) 01702000 DC CL8'MENU',AL4(MENUOPT) 01703000 DC CL8'NOMENU',AL4(NOMENOPT) 01704000 DC CL8'NOBINARY',AL4(NOBINOPT) 01705000 DC CL8'STDXLATE',AL4(STDXOPT) 01706000 DC 8X'FF',AL4(-1) 01707000 SENDLEN DS 1H BYTE COUNT FOR SEND BUFFER 01708000 RECVLEN DS 1H BYTE COUNT FOR RECEIVE BUFFER 01709000 GRAFLEN DS 1H BYTE COUNT FOR 3270 BUFFER 01710000 CONADDR DS 1H 3270 CONSOLE ADDRESS 01711000 UNSOLIS DS 1H Count of unsolicited interrupts 01712000 WSFQRCMD DC X'000501FF02' WSF QUERY REPLY COMMAND 01713000 WSFRPQ DC X'000701FF0300A1' WSF QUERY LIST FOR RPQ NAMES 01714000 CTLFS DC X'2E2E' CTL-F (ACK) START XFER CODES 01715000 ABORTSTR DC X'02022F' START BYTES AND CTL-G 01716000 ABRTSTRC DC X'02022D' 01717000 RETRYMSG DC C'Retransmitting command',X'15' 01718000 DC X'2D' BELL AT END OF MESSAGE 01719000 RMSGL EQU *-RETRYMSG MESSAGE LENGTH 01720000 VTAMPREP DC X'F31340401140401DC1' 01721000 DC X'3C5D7F40' BLANKS TO END OF SCREEN 01722000 VTAMPRPL EQU *-VTAMPREP LENGTH TO SEND 01723000 DSKMODE DC CL2' ' DISK MODE FOR ERROR MESSAGE 01724000 RECVATTR DS 18C MAC FILE ATTRIBUTE DATA 01725000 MACID DC CL17' ' MACINTOSH FILE ID: FN.FT 01726000 CENTSGN DC X'4A' EBCDIC CENT SIGN 01727000 VERSDATA DS 5C VERSION DATA 01728000 M3270VER DS 5C MAC3270 VERSION DATA (FROM WSF) 01729000 XFSPEED DS 4C TRANSFER SPEED, CPS 01730000 DELIM DC C' ' DEFAULT DELIMITER 01731000 RDRESP DC CL130' ' RDTERM RESPONSE BUFFER 01732000 FLAGS DS 1X FLAG BYTE 01733000 FINIS EQU X'01' CALL FINIS FOR OUTPUT FILE 01734000 EOF EQU X'02' CP/M EOF BYTE READ 01735000 NOMENU EQU X'04' HAVE MAC SKIP FILE MENU 01736000 FS3270 EQU X'08' 3270 IN FULL SCREEN MODE 01737000 ROERR EQU X'10' FSWRITE R/O ERROR 01738000 FLAGS2 DS 1X SECOND FLAG BYTE 01739000 BINXF EQU X'01' BINARY TRANSFER 01740000 TERMINIT EQU X'02' TERMINAL INIT. DONE 01741000 VTAMRB EQU X'04' RB COMMAND WITH VTAM 01742000 FLAGS3 DS 1X THIRD FLAG BYTE 01743000 STDTR EQU X'01' USE STANDARD XLATE TABLES 01744000 NLXT EQU X'02' NLXTAB DEFINED 01745000 PATHOPEN EQU X'04' Console path opened 01746000 TRMFLAGS DS 1X FLAG BYTE FOR TERMINAL STATUS 01747000 SFDEV EQU X'01' WSF MAY BE SUPPORTED 01748000 GRAFTRM EQU X'02' 3270 TERMINAL 01749000 MAC3270 EQU X'04' MAC3270 IN USE 01750000 VTAM EQU X'08' VTAM CONNECTION 01751000 SYN DC CL3'SYN' SYNCHRONIZATION (BAD) COMMAND 01752000 LTORG 01753000 OPENINFO DS 14D Info. from path open 01754000 SENDSTRT DC 2X'02' HEADER: 2 START BYTES 01755000 SENDDATA DS CL128 SEND DATA BUFFER 01756000 RECVDATA DS CL1032 RECEIVE DATA BUFFER 01757000 RECVLAST DS CL1032 PREVIOUS RECEIVED DATA (ASCII) OR 01758000 * MORE OF RECEIVE BUFFER (MAC3270) 01759000 DS CL248 MORE OF RECEIVE BUFFER (MAC3270) 01760000 GRAFDATA DS 512D 3270 I/O BUFFER 01761000 HEXTAB DC 256X'00' TABLE FOR HEX CONVERSION 01762000 ORG HEXTAB+C'A'-X'40' ALLOW LOWERCASE A-F 01763000 DC X'FAFBFCFDFEFF' 01764000 ORG HEXTAB+C'A' ALLOW UPPERCASE A-F 01765000 DC X'FAFBFCFDFEFF' 01766000 ORG HEXTAB+C'0' 01767000 DC C'0123456789' ALLOW DIGITS 01768000 ORG 01769000 NLXTAB DS 32D NATIONAL LANGUAGE XTAB 01770000 ADT 01771000 DCH 01772000 FSCBD 01773000 FSTB 01774000 FVS 01775000 NUCON 01776000 END 01777000