BINHEX TITLE 'Program to Process BinHex and MacBinary Format Files' 00001000 BINHEX CSECT 00002000 SPACE 00003000 *********************************************************************** 00004000 * * 00005000 * Name: * 00006000 * BINHEX * 00007000 * * 00008000 * Author: * 00009000 * Peter DiCamillo * 00010000 * Brown University Computer Center * 00011000 * Box 1885 * 00012000 * Providence, RI 02912 * 00013000 * (401) 863-2221 * 00014000 * BITNET: CMSMAINT@BROWNVM * 00015000 * Internet: CMSMAINT@brownvm.browm.edu * 00016000 * * 00017000 * Function: * 00018000 * BINHEX checks, describes, and converts Macintosh files * 00019000 * stored in CMS. It is able to work with both MacBinary for- * 00020000 * mat (Macterminal, BinHex 5.0) and BinHex format (BinHex 4.0) * 00021000 * files. * 00022000 * * 00023000 * Command format: * 00024000 * BINHEX ?|Check|Describe|COnvert fn > <( options <)>> * 00025000 * See the HELP file for detailed information. * 00026000 * * 00027000 * Normal Exits: * 00028000 * Returns to CMS with R15 = 0. For the ?, Check, and Describe * 00029000 * operands, repsonses are generated before returning. * 00030000 * * 00031000 * Error Conditions: * 00032000 * Returns to CMS with a non-zero return code after typing an * 00033000 * error message. Errors messgae and return codes are listed in * 00034000 * the HELP file. * 00035000 * * 00036000 * CMS System Calls: * 00037000 * CMS nucleus routines called via BALR: * 00038000 * ESTATE, ESTATEW, ADTLKP, RDBUF, WRBUF, FINIS * 00039000 * CMS routines called via SVC 202 or 203: * 00040000 * IDENTIFY, CONWAIT, TYPLIN, ATTN, EXECCOMM, DMSERR, LINEDIT * 00041000 * * 00042000 * External References: * 00043000 * For CRC calculation, BINHEX uses a table defined in XMDMTAB * 00044000 * ASSEMBLE. * 00045000 * * 00046000 * Attributes: * 00047000 * BINHEX loads in the user program area. In order to call * 00048000 * nucleus routines via BALR (for speed), it disables * 00049000 * interrupts and runs with the system storage key. * 00050000 * * 00051000 *********************************************************************** 00052000 EJECT 00053000 *********************************************************************** 00054000 * * 00055000 * Module Generation: * 00056000 * To create a new BINHEX MODULE, use the commands: * 00057000 * GLOBAL MACLIB DMSSP CMSLIB * 00058000 * ASSEMBLE BINHEX * 00059000 * ASSEMBLE XMDMTAB * 00060000 * LOAD BINHEX * 00061000 * GENMOD BINHEX * 00062000 * * 00063000 * Update History: * 00064000 * June 1, 1987: Initial implementation, Peter DiCamillo * 00065000 * June 13, 1987: Corrected ? response to indicate the filetype * 00066000 * is optional. PJD * 00067000 * * 00068000 *********************************************************************** 00069000 EJECT 00070000 PRINT NOGEN 00071000 REGEQU 00072000 USING *,R15 00073000 STM R0,R15,REGSAVE Save all registers 00074000 LR R11,R15 Use R11-R13 as base registers 00075000 LA R12,2048(R11) 00076000 LA R12,2048(R12) 00077000 LA R13,2048(R12) 00078000 LA R13,2048(R13) 00079000 DROP R15 00080000 USING BINHEX,R11,R12,R13 00081000 USING NUCON,0 Address nucon 00082000 L R10,AFVS R10 = FVSECT base register 00083000 USING FVSECT,R10 00084000 DMSKEY NUCLEUS We need system key and no 00085000 SSM =X'00' interruptions 00086000 SR R15,R15 00087000 ST R15,RTNCODE Return code initialized to zero 00088000 ST R15,CPS Initailize rate to zero 00089000 MVI FLAGS,0 All flags = 0 00090000 MVI FLAGS2,0 00091000 MVI OPRCODE,C' ' First operand unknown 00092000 MVC IFM(2),=CL2'*' Default input mode is "*" 00093000 MVC OFM(2),=CL2'*' Default output mode is "*" 00094000 L R2,=A(TOASCSTD) Set default EBCDIC to ASCII table 00095000 ST R2,TOASCADR 00096000 L R2,=A(FRASCSTD) Set default ASCII to EBCDIC table 00097000 ST R2,FRASCADR 00098000 BAL R14,GETID Get local node id 00099000 CLC NODEID(8),BROWNID If Brown, use local tables 00100000 BNE XTABOK 00101000 L R2,=A(TOASCBRN) 00102000 ST R2,TOASCADR 00103000 L R2,=A(FRASCBRN) 00104000 ST R2,FRASCADR 00105000 XTABOK EQU * 00106000 L R2,=A(WRITBUFF) R2 -> buffer 00107000 L R3,=A(VALIDTAB) R3 -> TRT table 00108000 MVI 0(R3),X'FF' Initialize VALIDTAB for TRTs 00109000 MVC 1(255,R3),0(R3) 00110000 L R4,=A(BINTOASC) R4 -> ASCII character list 00111000 MVC 0(64,R2),0(R4) Copy valid ASCII characters 00112000 L R4,FRASCADR R2 -> ASCII-to-EBCDIC table 00113000 TR 0(64,R2),0(R4) Convert to valid EBCDIC characters 00114000 LA R4,64 R4 = count for BCT 00115000 SR R5,R5 R5 = 0 for IC 00116000 VINITLP EQU * Loop to fill-in VALIDTAB 00117000 IC R5,0(R2) Get new character in R5 00118000 LA R6,0(R3,R5) R6 -> position in table 00119000 MVI 0(R6),0 Store zero there 00120000 LA R2,1(R2) R2 -> next character 00121000 BCT R4,VINITLP Repeat for all 64 character 00122000 B OPERCHK Skip over save area 00123000 SPACE 00124000 REGSAVE DS 8D Register save area 00125000 RTNCODE EQU REGSAVE+60 Return code at location for R15 00126000 EJECT 00127000 * Check for valid first operand (function) 00128000 OPERCHK LA R1,8(R1) R1 -> operand 00129000 CLI 0(R1),X'FF' Operand there at all? 00130000 BE BADFMT No, give error message 00131000 LA R3,8 Get operand length in R3 00132000 LA R2,7(R1) R2 -> last byte 00133000 OPRLENLP EQU * Loop to get length 00134000 CLI 0(R2),C' ' At non-blank? 00135000 BNE HAVEOPRL Yes, length in R3 00136000 BCTR R2,0 R2 -> previous byte 00137000 BCT R3,OPRLENLP Decrement and repeat 00138000 B BADFMT All blank is error 00139000 SPACE 00140000 HAVEOPRL BCTR R3,0 Decrement length for EX 00141000 LA R2,OPRTAB R2 -> operand table 00142000 OPRTBCHK EQU * Look for match in table 00143000 CLI 0(R2),X'FF' At table end? 00144000 BE BADFMT Yes, format error 00145000 EX R3,OPRCLC Found a match? 00146000 BE USEOPR Yes, handle operand 00147000 LA R2,12(R2) R2 -> next operand 00148000 B OPRTBCHK Try again 00149000 SPACE 00150000 OPRCLC CLC 0(*-*,R2),0(R1) Compare table entry to operand 00151000 SPACE 00152000 USEOPR L R2,8(R2) R2 -> operand code 00153000 BR R2 Execute code for operand 00154000 SPACE 00155000 CHKOPR MVI OPRCODE,C'C' Set code C for CHECK 00156000 B READID 00157000 SPACE 00158000 CVTOPR MVI OPRCODE,C'V' Set code V for CONVERT 00159000 B READID 00160000 SPACE 00161000 DESCOPR MVI OPRCODE,C'D' Set code D for DESCRIBE 00162000 B READID 00163000 SPACE 00164000 QUESOPR EQU * For ?, type command format 00165000 WRTERM 'Format is: BINHEX ?|Check|Describe|COnvert fn X00166000 > <( options <)>>' 00167000 WRTERM ' Options: ' 00169000 B CMSRTN Return right away 00170000 SPACE 00171000 * After function operand, get file id 00172000 READID LA R1,8(R1) R1 -> possible FN 00173000 CLI 0(R1),X'FF' Error if missing or "*" 00174000 BE BADFMT 00175000 CLI 0(R1),C'*' 00176000 BE BADFMT 00177000 MVC IFN(8),0(R1) Copy FN 00178000 MVC IFT(8),=CL8'*' Set default filetype 00179000 LA R1,8(R1) R1 -> possible FT 00180000 CLI 0(R1),X'FF' Done if no FT, FM or options 00181000 BE OPTDONE 00182000 CLI 0(R1),C'(' If '(', start options 00183000 BE OPTSCAN 00184000 MVC IFT(8),0(R1) Copy FT 00185000 LA R1,8(R1) R1 -> past FT 00186000 CLI 0(R1),X'FF' Done if no FM or options 00187000 BE OPTDONE 00188000 CLI 0(R1),C'(' If '(', start options 00189000 BE OPTSCAN 00190000 CLI 2(R1),C' ' 3rd character of FM must be blank 00191000 BNE BADFMT 00192000 CLC 0(2,R1),=CL2'*' Skip copy if default specified 00193000 BE IFMDONE 00194000 MVC IFM(2),0(R1) Copy filemode for input 00195000 CLI IFM+1,C' ' If no mode number, use '1' 00196000 BNE IFMDONE 00197000 MVI IFM+1,C'1' 00198000 IFMDONE LA R1,8(R1) R1 -> next argument 00199000 CLI 0(R1),X'FF' Done if no options 00200000 BE OPTDONE 00201000 CLI 0(R1),C'(' If '(', start options 00202000 BE OPTSCAN 00203000 * Else command format error 00204000 BADFMT LR R2,R1 R2 = scan pointer 00205000 S R2,=F'8' Point to previous token 00206000 DMSERR NUM=1,LET=E,SUB=(CHARA,(R2)), X00207000 TEXT='Error in command after ''........''' 00208000 DMSERR NUM=2,LET=I, X00209000 TEXT='Issue BINHEX ? or HELP CMS BINHEX for more informaX00210000 tion' 00211000 MVI RTNCODE+3,24 Set return code 00212000 B CMSRTN Return to CMS 00213000 SPACE 00214000 * Process options 00215000 OPTSCAN EQU * R1 -> '(' 00216000 NEWOPT LA R1,8(R1) R1 -> possible option 00217000 CLI 0(R1),X'FF' Option there? 00218000 BE OPTDONE No, done scanning 00219000 CLI 0(R1),C')' Also done if ')' 00220000 BE OPTDONE 00221000 LA R3,8 Get option length in R3 00222000 LA R2,7(R1) R2 -> last byte 00223000 OPTLENLP EQU * Loop to get length 00224000 CLI 0(R2),C' ' At non-blank? 00225000 BNE HAVEOPTL Yes, length in R3 00226000 BCTR R2,0 R2 -> previous byte 00227000 BCT R3,OPTLENLP Decrement and repeat 00228000 B BADOPT All blank is error 00229000 SPACE 00230000 HAVEOPTL BCTR R3,0 Decrement length for EX 00231000 LA R2,OPTTAB R2 -> option table 00232000 OPTTBCHK EQU * Look for match in table 00233000 CLI 0(R2),X'FF' At table end? 00234000 BE BADOPT Yes, format error 00235000 EX R3,OPTCLC Found a match? 00236000 BE USEOPT Yes, handle option 00237000 LA R2,12(R2) R2 -> next option 00238000 B OPTTBCHK Try again 00239000 SPACE 00240000 OPTCLC CLC 0(*-*,R2),0(R1) Compare table entry to option 00241000 SPACE 00242000 USEOPT L R2,8(R2) R2 -> option code 00243000 BR R2 Execute code for option 00244000 SPACE 00245000 TOOPT EQU * TO option 00246000 LA R1,8(R1) R1 -> filemode 00247000 CLI 0(R1),X'FF' Error if mode missing 00248000 BE BADMODE 00249000 CLI 2(R1),C' ' Error if more than 2 characters 00250000 BNE BADMODE 00251000 MVC OFM(2),0(R1) Copy output filemode 00252000 B NEWOPT 00253000 SPACE 00254000 STEMOPT EQU * STEM option 00255000 LA R1,8(R1) R1 -> stem name 00256000 CLI 0(R1),X'FF' Error if stem missing 00257000 BE BADSTEM 00258000 MVC STEMNAME(8),0(R1) Save stem name 00259000 OI FLAGS2,EXECVAR Remember stem given 00260000 LA R3,8 Get stem length in R3 00261000 LA R2,7(R1) R2 -> last byte 00262000 STMLENLP EQU * Loop to get length 00263000 CLI 0(R2),C' ' At non-blank? 00264000 BNE HAVESTML Yes, length in R3 00265000 BCTR R2,0 R2 -> previous byte 00266000 BCT R3,STMLENLP Decrement and repeat 00267000 B BADSTEM Error if all blank 00268000 SPACE 00269000 HAVESTML ST R3,STEMSIZE Save length of stem name 00270000 B NEWOPT 00271000 SPACE 00272000 BADMODE LR R2,R1 R2 -> bad filemode 00273000 DMSERR NUM=48,LET=E,TEXT='Invalid mode ''........''', X00274000 SUB=(CHARA,(R2)) 00275000 MVI RTNCODE+3,24 Set return code 00276000 B CMSRTN Return to CMS 00277000 SPACE 00278000 BADSTEM DMSERR NUM=637,LET=E,TEXT='Missing value for the ''STEM'' optiX00279000 on' 00280000 MVI RTNCODE+3,24 Set return code 00281000 B CMSRTN Return to CMS 00282000 SPACE 00283000 RATEOPT EQU * RATE option 00284000 LA R1,8(R1) R1 -> rate 00285000 CLI 0(R1),X'FF' Error if rate missing 00286000 BE BADRATE 00287000 BAL R14,DECCVT Convert to decimal in R2 00288000 BNP BADRATE Error if result not positive 00289000 ST R2,CPS Store rate 00290000 B NEWOPT Ready for next option 00291000 SPACE 00292000 BADRATE LR R2,R1 R2 -> bad rate 00293000 DMSERR NUM=10,LET=E,TEXT='Invalid rate ''........''', X00294000 SUB=(CHARA,(R2)) 00295000 MVI RTNCODE+3,24 Set return code 00296000 B CMSRTN Return to CMS 00297000 SPACE 00298000 STKOPT EQU * STACK or FIFO option 00299000 OI FLAGS,STKDESC Set flag to stack description 00300000 B NEWOPT 00301000 SPACE 00302000 LIFOOPT EQU * LIFO option 00303000 OI FLAGS,STKDESC+STKLIFO Set stack and FIFO flags 00304000 B NEWOPT 00305000 SPACE 00306000 BADOPT LR R2,R1 R2 -> bad option 00307000 DMSERR NUM=3,LET=E,TEXT='Invalid option ''........''', X00308000 SUB=(CHARA,(R2)) 00309000 MVI RTNCODE+3,24 Set return code 00310000 B CMSRTN Return to CMS 00311000 SPACE 00312000 OPTDONE EQU * Done scanning plist 00313000 * Check input file, get actual filemode, and check for BIN file 00314000 LA R1,INPLIST Call STATE for input file 00315000 L R15,AESTATE 00316000 BALR R14,R15 00317000 BNZ STATERR Check for any errors 00318000 CLC IFT(8),=CL8'*' * or no filetype specified? 00319000 BNE FTOK No, keep filetype 00320000 MVC IFT(8),FVST Else copy from file we found 00321000 FTOK CLC FVSIL(4),=F'256' Return error if lrecl too big 00322000 BH LRECLERR 00323000 L R2,FVSFSTAD R2 -> ADT for input file disk 00324000 USING ADTSECT,R2 00325000 IC R1,ADTM Fill-in actual disk letter and 00326000 STC R1,IFM mode number for file which 00327000 IC R1,FVSM+1 was found 00328000 STC R1,IFM+1 00329000 DROP R2 00330000 CLI OFM,C'*' If OFM not filled-in, use input 00331000 BNE MDNUMTST file disk letter 00332000 IC R1,IFM 00333000 STC R1,OFM 00334000 MDNUMTST CLI OFM+1,C' ' If OFM not filled-in, use input 00335000 BNE BINCHK file mode number 00336000 IC R1,IFM+1 00337000 STC R1,OFM+1 00338000 BINCHK EQU * Check for MacBinary input file 00339000 CLI FVSFV,C'F' Is recfm F? 00340000 BNE NOTBIN No, not MacBinary 00341000 CLC FVSIL(4),=F'128' Is lrecl 128? 00342000 BNE NOTBIN No, not MacBinary 00343000 OI FLAGS,MACBIN Else set flag for MacBinary 00344000 NOTBIN EQU * 00345000 * Define input file RDBUF plist 00346000 LA R0,1 R0 = 1 for initializing 00347000 SR R15,R15 R15 = 0 for initializing 00348000 MVC INCMMD(8),=CL8'RDBUF' Command name 00349000 STH R15,RDUN1 Unused halfword 00350000 L R1,=A(READBUFF) Buffer address 00351000 ST R1,RDADDR 00352000 MVC RDBUFLTH(4),=F'256' Buffer size 00353000 MVI RDFV,C'V' Record format (works for F too) 00354000 MVI RDFLAG,X'20' Plist flag 00355000 STH R15,RDUN2 Unused halfword 00356000 ST R15,RDLGTH Bytes read 00357000 ST R15,RDITEM Item number 00358000 ST R0,RDITEC Item count 00359000 ST R15,RDWP Write and read pointers 00360000 ST R15,RDRP 00361000 * If CONVERT specified, check output file status 00362000 CLI OPRCODE,C'V' Convert specified? 00363000 BNE INITDONE No, ready to start processing 00364000 MVC OFN(8),IFN Output filename same as input 00365000 MVC OFT(8),=CL8'BIN' Assume BIN for filetype 00366000 TM FLAGS,MACBIN Is input MACBIN? 00367000 BZ KEEPOFT No, BIN is correct 00368000 MVC OFT(8),=CL8'HQX' Else use HQX 00369000 KEEPOFT EQU * OFM already defined 00370000 LA R1,OUTPLIST Call STATEW for output file 00371000 L R15,AESTATEW 00372000 BALR R14,R15 00373000 C R15,=F'28' Error if "File not found" 00374000 BNE EXIERR not returned 00375000 LA R1,OUTPLIST Get ADT for output disk 00376000 L R15,VCADTLKP 00377000 BALR R14,R15 00378000 BNZ ROERR (should not happen due to STATE) 00379000 LR R2,R1 Check disk is R/W 00380000 USING ADTSECT,R2 00381000 TM ADTFLG1,ADTFRW Is disk R/W? 00382000 BZ ROERR No, give error 00383000 DROP R2 00384000 * Define output file WRBUF plist 00385000 LA R0,1 R0 = 1 for initializing 00386000 SR R15,R15 R15 = 0 for initializing 00387000 MVC OUTCMMD(8),=CL8'WRBUF' Command name 00388000 STH R15,WRUN1 Unused halfword 00389000 L R1,=A(WRITBUFF) Buffer address 00390000 ST R1,WRADDR 00391000 ST R15,WRBUFLTH Buffer size (will be set) 00392000 MVI WRFV,C'V' Record format 00393000 TM FLAGS,MACBIN MacBinary input file 00394000 BO KEEPVAR Yes, keep recfm V 00395000 MVC WRBUFLTH(4),=F'128' Lrecl 128 and recfm F for 00396000 MVI WRFV,C'F' MacBinary output 00397000 KEEPVAR MVI WRFLAG,X'20' Plist flag 00398000 STH R15,WRUN2 Unused halfword 00399000 ST R15,WRUN3 Unused word 00400000 ST R15,WRITEM Item number 00401000 ST R0,WRITEC Item count 00402000 ST R15,WRWP Write and read pointers 00403000 ST R15,WRRP 00404000 INITDONE EQU * Ready to process files 00405000 XC HDREC(128),HDREC Initialize header info. 00406000 XC CHRTOTAL(4),CHRTOTAL Initialize count of characters 00407000 TM FLAGS,MACBIN Separate processing for MacBinary 00408000 BO BINPROC file format 00409000 * 00410000 * Read BinHex file to define file header info 00411000 * 00412000 LA R1,CVCNT0 Reset left over bit 00413000 ST R1,BINXTADR processing 00414000 MVI CMPCNT,0 Reset compression count 00415000 XC BINLEN(4),BINLEN Reset count for BINBUFF 00416000 XC CRCVAL(2),CRCVAL Reset CRC 00417000 LA R0,1 R0 = length 00418000 LA R1,HDFNLEN R1 -> buffer 00419000 BAL R14,GETSTR Get length of filename 00420000 BAL R14,CRCCALC Include in CRC 00421000 SR R1,R1 Get length in R1 00422000 IC R1,HDFNLEN 00423000 LTR R1,R1 Skip getting name if zero 00424000 BZ NONAME 00425000 C R1,=F'63' If >63, use 63 00426000 BNH FNLENOK 00427000 L R1,=F'63' 00428000 FNLENOK LR R0,R1 R0 = length 00429000 LA R1,HDFN R1 -> buffer 00430000 BAL R14,GETSTR Get filename 00431000 BAL R14,CRCCALC Include in CRC 00432000 NONAME LA R0,1 R0 = length 00433000 LA R1,HDVER R1 -> buffer 00434000 BAL R14,GETSTR Get version byte 00435000 BAL R14,CRCCALC Include in CRC 00436000 LA R0,10 R0 = length 00437000 LA R1,HDFTYP R1 -> buffer 00438000 BAL R14,GETSTR Get type, creator, flag bytes 00439000 BAL R14,CRCCALC Include in CRC 00440000 LA R0,8 R0 = length 00441000 LA R1,HDDATALN R1 -> buffer 00442000 BAL R14,GETSTR Get lengths of forks 00443000 BAL R14,CRCCALC Include in CRC 00444000 LA R0,2 R0 = length 00445000 L R1,=A(DATABUFF) R1 -> buffer 00446000 BAL R14,GETSTR Get header CRC 00447000 BAL R14,CRCCALC Include in CRC 00448000 CLC CRCVAL(2),=H'0' Is final CRC 0? 00449000 BE HDCHKOK Yes, continue 00450000 DMSERR LET=E,NUM=7,TEXT='''....................'': CRC error fX00451000 or BinHex header',SUB=(CHAR8A,IFN) 00452000 MVI RTNCODE+3,44 Set RC = 44 00453000 B CMSRTN Return to caller 00454000 SPACE 00455000 HDCHKOK EQU * HQX header successfully read 00456000 CLI OPRCODE,C'V' Conversion wanted? 00457000 BNE HDDESC No, check for description 00458000 LA R1,HDREC Output header record 00459000 BAL R14,WR128 00460000 B CHKDATA Ready for data fork 00461000 SPACE 00462000 HDDESC CLI OPRCODE,C'D' Description wanted? 00463000 BNE CHKDATA No, ready for data fork 00464000 TM FLAGS2,EXECVAR Header info. wanted in vars.? 00465000 BO HDVAR1 00466000 BAL R14,TYPEHDR Type header description 00467000 B CHKDATA Ready for data fork 00468000 SPACE 00469000 HDVAR1 BAL R14,VARHDR Return info. in vars. 00470000 CHKDATA EQU * Check data fork 00471000 ICM R3,B'1111',HDDATALN Get data fork length 00472000 LR R4,R3 R4 = number of 128-byte pieces 00473000 SRL R4,7 00474000 LR R5,R4 R5 = bytes for all pieces 00475000 SLL R5,7 00476000 SR R3,R5 R3 = bytes left over 00477000 LA R0,128 R0 = byte count 00478000 L R1,=A(DATABUFF) R1 -> buffer 00479000 XC CRCVAL(2),CRCVAL Reset CRC 00480000 LTR R4,R4 Any pieces to read? 00481000 BNP DCHKLEFT No, skip loop 00482000 DCHKLP EQU * Loop to read 128-byte pieces 00483000 BAL R14,GETSTR Read 128 bytes 00484000 BAL R14,CRCCALC Include in CRC 00485000 CLI OPRCODE,C'V' Conversion wanted? 00486000 BNE DCHKNXT No, continue 00487000 BAL R14,WR128 Write data block 00488000 DCHKNXT BCT R4,DCHKLP Repeat for all pieces 00489000 DCHKLEFT LTR R3,R3 Any bytes left? 00490000 BNP DCHKEND No, compare CRC 00491000 XC 0(128,R1),0(R1) Initialize buffer 00492000 LR R0,R3 Length = bytes left 00493000 BAL R14,GETSTR Read bytes 00494000 BAL R14,CRCCALC Include in CRC 00495000 CLI OPRCODE,C'V' Conversion wanted? 00496000 BNE DCHKEND No, continue 00497000 BAL R14,WR128 Write data block 00498000 DCHKEND LA R0,2 Get CRC 00499000 BAL R14,GETSTR 00500000 BAL R14,CRCCALC Include CRC 00501000 CLC CRCVAL(2),=H'0' Is result zero? 00502000 BE CHKRSC Yes, check resource fork 00503000 DMSERR LET=E,NUM=8,TEXT='''....................'': CRC error fX00504000 or BinHex data fork',SUB=(CHAR8A,IFN) 00505000 MVI RTNCODE+3,44 Set RC = 44 00506000 B CMSRTN Return to caller 00507000 SPACE 00508000 CHKRSC EQU * Check resource fork 00509000 ICM R3,B'1111',HDRSCLN Get resource fork length 00510000 LR R4,R3 R4 = number of 128-byte pieces 00511000 SRL R4,7 00512000 LR R5,R4 R5 = bytes for all pieces 00513000 SLL R5,7 00514000 SR R3,R5 R3 = bytes left over 00515000 LA R0,128 R0 = byte count 00516000 L R1,=A(DATABUFF) R1 -> buffer 00517000 XC CRCVAL(2),CRCVAL Reset CRC 00518000 LTR R4,R4 Any pieces to read? 00519000 BNP RCHKLEFT No, skip loop 00520000 RCHKLP EQU * Loop to read 128-byte pieces 00521000 BAL R14,GETSTR Read 128 bytes 00522000 BAL R14,CRCCALC Include in CRC 00523000 CLI OPRCODE,C'V' Conversion wanted? 00524000 BNE RCHKNXT No, continue 00525000 BAL R14,WR128 Write data block 00526000 RCHKNXT BCT R4,RCHKLP Repeat for all pieces 00527000 RCHKLEFT LTR R3,R3 Any bytes left? 00528000 BNP RCHKEND No, compare CRC 00529000 XC 0(128,R1),0(R1) Initialize buffer 00530000 LR R0,R3 Length = bytes left 00531000 BAL R14,GETSTR Read bytes 00532000 BAL R14,CRCCALC Include in CRC 00533000 CLI OPRCODE,C'V' Conversion wanted? 00534000 BNE RCHKEND No, continue 00535000 BAL R14,WR128 Write data block 00536000 RCHKEND LA R0,2 Get CRC 00537000 BAL R14,GETSTR 00538000 BAL R14,CRCCALC Include CRC 00539000 CLC CRCVAL(2),=H'0' Is result 0? 00540000 BNE RCHKERR No, give error 00541000 RSCDONE EQU * BinHex code continues here 00542000 CLI OPRCODE,C'D' Describe specified? 00543000 BE DESCEND Yes, finish description 00544000 CLI OPRCODE,C'C' Check specified? 00545000 BNE CMSRTN No, ready to return 00546000 CLI REGSAVE+4,X'0B' Called from command line? 00547000 BNE CMSRTN No, ready to return 00548000 L R8,=A(DATABUFF) R8 -> work buffer 00549000 LINEDIT TEXT='''....................'': No errors detected', X00550000 SUB=(CHAR8A,IFN),BUFFA=(R8),DISP=NONE,RENT=NO 00551000 BAL R14,TYPEDESC Type or stack line 00552000 B CMSRTN 00553000 SPACE 00554000 DESCEND EQU * End file description 00555000 L R8,=A(DATABUFF) R8 -> work buffer 00556000 L R0,CHRTOTAL R0 = character count 00557000 TM FLAGS2,EXECVAR Data in EXEC variables? 00558000 BZ ENDTEXT No, do text 00559000 L R1,=A(AVAR13) R1 -> CHARCNT string data 00560000 LR R2,R1 Save R1 across NUMTOSTR 00561000 LA R1,1(R8) R1 -> buffer for number 00562000 BAL R14,NUMTOSTR Convert to string 00563000 STC R0,0(R8) Store string length 00564000 LR R1,R2 Restore R1 for SETVAR 00565000 BAL R14,SETVAR Define stem.RESCSIZE 00566000 L R4,CPS Was rate specified? 00567000 LTR R4,R4 (Check if non-zero) 00568000 BZ CMSRTN No, ready to return 00569000 SR R5,R5 R5 = message length 00570000 LA R6,1(R8) R6 -> next byte 00571000 B TIMEMSG Join code for time estimate 00572000 SPACE 00573000 ENDTEXT MVC 1(17,R8),=C'Character count: ' Copy start of message 00574000 LA R5,17 R5 = message length 00575000 LA R6,1(R5,R8) R6 -> next byte 00576000 LR R1,R6 R1 -> buffer 00577000 BAL R14,NUMTOSTR Store number in string form 00578000 AR R5,R0 Update length and address 00579000 AR R6,R0 00580000 MVI 0(R6),C'.' Append period 00581000 LA R5,1(R5) Update length and address 00582000 LA R6,1(R6) 00583000 STC R5,0(R8) Store length for TYPEDESC 00584000 L R4,CPS Was rate specified? 00585000 LTR R4,R4 (Check if non-zero) 00586000 BZ RATEMSG No, ready to type message 00587000 BCTR R6,0 R6 -> ending period 00588000 MVC 0(2,R6),=C' (' Replace by blank, paren 00589000 LA R5,1(R5) Adjust length for blank, paren 00590000 LA R6,2(R6) R6 -> next byte 00591000 TIMEMSG SR R2,R2 R2, R3 = character count 00592000 L R3,CHRTOTAL 00593000 DR R2,R4 Divide to get seconds in R3 00594000 SRL R4,1 R4 = half of divisor 00595000 CR R2,R4 Remainder more than half? 00596000 BNH KEEPSEC No, keep seconds 00597000 A R3,=F'1' Else add one second 00598000 KEEPSEC SR R2,R2 R2, R3 = seconds 00599000 D R2,=F'60' R2 = secs., R3 = mins. 00600000 LR R4,R2 Save seconds in R4 00601000 SR R2,R2 R2, R3 = minutes 00602000 D R2,=F'60' R2 = minutes, R3 = hours 00603000 LTR R0,R3 Any hours? 00604000 BZ INCMIN No, ready for minutes 00605000 LR R1,R6 R1 -> buffer 00606000 BAL R14,NUMTOSTR Store string there 00607000 AR R5,R0 Adjust length and address 00608000 AR R6,R0 00609000 C R3,=F'1' Just one hour? 00610000 BE ONEHOUR Yes, special case 00611000 MVC 0(8,R6),=C' hours, ' Append text 00612000 LA R5,8(R5) Adjust length and address 00613000 LA R6,8(R6) 00614000 B INCMIN Ready for minutes 00615000 SPACE 00616000 ONEHOUR MVC 0(7,R6),=C' hour, ' Append text 00617000 LA R5,7(R5) Adjust length and address 00618000 LA R6,7(R6) 00619000 INCMIN LTR R0,R2 Any minutes? 00620000 BZ INCSEC No, ready for seconds 00621000 LR R1,R6 R1 -> buffer 00622000 BAL R14,NUMTOSTR Store string there 00623000 AR R5,R0 Adjust length and address 00624000 AR R6,R0 00625000 C R2,=F'1' Just one minute? 00626000 BE ONEMIN Yes, special case 00627000 MVC 0(10,R6),=C' minutes, ' Append text 00628000 LA R5,10(R5) Adjust length and address 00629000 LA R6,10(R6) 00630000 B INCSEC Ready for minutes 00631000 SPACE 00632000 ONEMIN MVC 0(9,R6),=C' minute, ' Append text 00633000 LA R5,9(R5) Adjust length and address 00634000 LA R6,9(R6) 00635000 INCSEC LR R0,R4 R0 = number to convert 00636000 LR R1,R6 R1 -> buffer 00637000 BAL R14,NUMTOSTR Store string there 00638000 AR R5,R0 Adjust length and address 00639000 AR R6,R0 00640000 C R4,=F'1' Just one second? 00641000 BE ONESEC Yes, special case 00642000 MVC 0(12,R6),=C' seconds at ' Append text 00643000 LA R5,12(R5) Adjust length and address 00644000 LA R6,12(R6) 00645000 B ENDTIME Ready to use text 00646000 SPACE 00647000 ONESEC MVC 0(11,R6),=C' second at ' Append text 00648000 LA R5,11(R5) Adjust length and address 00649000 LA R6,11(R6) 00650000 ENDTIME L R0,CPS R0 = number to convert 00651000 LR R1,R6 R1 -> buffer 00652000 BAL R14,NUMTOSTR Store string there 00653000 AR R5,R0 Adjust length and address 00654000 AR R6,R0 00655000 TM FLAGS2,EXECVAR Is this for EXEC data 00656000 BO TIMEVAR Yes, end differently 00657000 MVC 0(6,R6),=C' cps).' Append text 00658000 LA R5,6(R5) Update length 00659000 STC R5,0(R8) Store new length for TYPEDESC 00660000 RATEMSG BAL R14,TYPEDESC Type or stack line 00661000 B CMSRTN 00662000 SPACE 00663000 TIMEVAR MVC 0(4,R6),=C' cps' Append text 00664000 LA R5,4(R5) Update length 00665000 STC R5,0(R8) Store new length for TYPEDESC 00666000 L R1,=A(AVAR14) R1 -> TIMEEST string data 00667000 BAL R14,SETVAR Define stem.TIMEEST 00668000 B CMSRTN Ready to return 00669000 SPACE 00670000 RCHKERR DMSERR LET=E,NUM=9,TEXT='''....................'': CRC error fX00671000 or BinHex resource fork',SUB=(CHAR8A,IFN) 00672000 MVI RTNCODE+3,44 Set RC = 44 00673000 B CMSRTN Return to caller 00674000 SPACE 00675000 BINPROC EQU * Process MacBinary file 00676000 BAL R14,GETLINE Read 128-byte header record 00677000 LTR R15,R15 Check for EOF (strange) 00678000 BNZ GSEOF Use error code in GETSTR 00679000 L R2,=A(READBUFF) R2 -> I/O buffer 00680000 MVC HDREC(128),0(R2) Copy data to header area 00681000 CLI OPRCODE,C'V' Conversion wanted? 00682000 BNE BINHDESC No, check for description 00683000 * Initialize for HQX output: 00684000 L R1,=A(HQXMSG) R1 -> initial message line 00685000 L R2,=A(WRITBUFF) R2 -> output buffer 00686000 MVC 0(HQXMSGL,R2),0(R1) Copy message to buffer 00687000 LA R1,HQXMSGL Get message length 00688000 ST R1,WRLEN Store as line length 00689000 BAL R14,HQXLINE Output line to file 00690000 MVI 0(R2),C' ' Output one blank 00691000 LA R1,1 Length = 1 00692000 ST R1,WRLEN 00693000 BAL R14,HQXLINE Write blank line 00694000 MVI 0(R2),C':' Initialize buffer with colon 00695000 ST R1,WRLEN 00696000 XC EXPLEN(4),EXPLEN Zero length for EXPBUFF 00697000 MVI CMPMODE,0 Initial compression mode 00698000 * Output HQX header data: 00699000 XC CRCVAL(2),CRCVAL Reset CRC 00700000 SR R2,R2 Get length of filename 00701000 IC R2,HDFNLEN 00702000 LA R0,1(R2) R0 = length with length byte 00703000 LA R1,HDFNLEN R1 -> length 00704000 BAL R14,HQXPUT Output to HQX file 00705000 BAL R14,CRCCALC Include in CRC 00706000 LA R0,1 R0 = 1 for version byte 00707000 LA R1,HDVER R1 -> version byte 00708000 BAL R14,HQXPUT Output version byte 00709000 BAL R14,CRCCALC Include in CRC 00710000 ICM R2,B'0011',HDFLAGS Save flag bits 00711000 NC HDFLAGS(2),=X'F800' For HQX, 'and' with X'F800' 00712000 LA R0,10 R0 = 10 (4+4+2) 00713000 LA R1,HDFTYP R1 -> type 00714000 BAL R14,HQXPUT Output type, creator, flags 00715000 BAL R14,CRCCALC Include in CRC 00716000 STCM R2,B'0011',HDFLAGS Restore original flag bits 00717000 LA R0,8 R0 = 8 (4+4) 00718000 LA R1,HDDATALN R1 -> lengths 00719000 BAL R14,HQXPUT Output data and resource lengths 00720000 BAL R14,CRCCALC Include in CRC 00721000 LA R0,2 Include X'0000' in CRC 00722000 LA R1,=H'0' 00723000 BAL R14,CRCCALC 00724000 LA R0,2 R0 = length of CRC 00725000 LA R1,CRCVAL R1 -> CRC 00726000 BAL R14,HQXPUT End header with CRC 00727000 B BINDATA Ready for data fork 00728000 SPACE 00729000 BINHDESC CLI OPRCODE,C'D' Description wanted? 00730000 BNE BINDATA No, ready for data fork 00731000 TM FLAGS2,EXECVAR Header info. wanted in vars.? 00732000 BO HDVAR2 00733000 BAL R14,TYPEHDR Type header description 00734000 B BINDATA Ready for data fork 00735000 SPACE 00736000 HDVAR2 BAL R14,VARHDR Return info. in vars. 00737000 BINDATA EQU * Process BinHex data fork 00738000 ICM R3,B'1111',HDDATALN Get data fork length 00739000 LR R4,R3 R4 = number of 128-byte records 00740000 SRL R4,7 00741000 LR R5,R4 R5 = bytes for all records 00742000 SLL R5,7 00743000 SR R3,R5 R3 = bytes left over 00744000 LA R0,128 R0 = byte count 00745000 L R1,=A(READBUFF) R1 -> buffer 00746000 XC CRCVAL(2),CRCVAL Reset CRC 00747000 LTR R4,R4 Any entire records to read? 00748000 BNP BINDLEFT No, skip loop 00749000 BINDLP EQU * Loop to read 128-byte records 00750000 BAL R14,GETLINE Read 128-byte record 00751000 LTR R15,R15 Check for EOF 00752000 BNZ GSEOF Use error code in GETSTR 00753000 CLI OPRCODE,C'V' Conversion wanted? 00754000 BNE BINDNXT No, continue 00755000 BAL R14,HQXPUT Write data block 00756000 BAL R14,CRCCALC Include in CRC 00757000 BINDNXT BCT R4,BINDLP Repeat for all pieces 00758000 BINDLEFT LTR R3,R3 Any bytes left? 00759000 BNP BINDEND No, check for writing CRC 00760000 BAL R14,GETLINE Read 128-byte record 00761000 LTR R15,R15 Check for EOF 00762000 BNZ GSEOF Use error code in GETSTR 00763000 CLI OPRCODE,C'V' Conversion wanted? 00764000 BNE BINDEND No, skip writing data 00765000 LR R0,R3 Use remaining bytes length 00766000 BAL R14,HQXPUT Write data block 00767000 BAL R14,CRCCALC Include in CRC 00768000 BINDEND CLI OPRCODE,C'V' Conversion wanted? 00769000 BNE BINRSC No, ready for resource fork 00770000 LA R0,2 Include X'0000' in CRC 00771000 LA R1,=H'0' 00772000 BAL R14,CRCCALC 00773000 LA R0,2 R0 = size of CRC 00774000 LA R1,CRCVAL R1 -> CRC 00775000 BAL R14,HQXPUT Output data fork CRC 00776000 BINRSC EQU * Process BinHex resource fork 00777000 ICM R3,B'1111',HDRSCLN Get resource fork length 00778000 LR R4,R3 R4 = number of 128-byte records 00779000 SRL R4,7 00780000 LR R5,R4 R5 = bytes for all records 00781000 SLL R5,7 00782000 SR R3,R5 R3 = bytes left over 00783000 LA R0,128 R0 = byte count 00784000 L R1,=A(READBUFF) R1 -> buffer 00785000 XC CRCVAL(2),CRCVAL Reset CRC 00786000 LTR R4,R4 Any entire records to read? 00787000 BNP BINRLEFT No, skip loop 00788000 BINRLP EQU * Loop to read 128-byte records 00789000 BAL R14,GETLINE Read 128-byte record 00790000 LTR R15,R15 Check for EOF 00791000 BNZ GSEOF Use error code in GETSTR 00792000 CLI OPRCODE,C'V' Conversion wanted? 00793000 BNE BINRNXT No, continue 00794000 BAL R14,HQXPUT Write resource block 00795000 BAL R14,CRCCALC Include in CRC 00796000 BINRNXT BCT R4,BINRLP Repeat for all pieces 00797000 BINRLEFT LTR R3,R3 Any bytes left? 00798000 BNP BINREND No, check for writing CRC 00799000 BAL R14,GETLINE Read 128-byte record 00800000 LTR R15,R15 Check for EOF 00801000 BNZ GSEOF Use error code in GETSTR 00802000 CLI OPRCODE,C'V' Conversion wanted? 00803000 BNE BINREND No, skip writing data 00804000 LR R0,R3 Use remaining bytes length 00805000 BAL R14,HQXPUT Write resource block 00806000 BAL R14,CRCCALC Include in CRC 00807000 BINREND CLI OPRCODE,C'V' Conversion wanted? 00808000 BNE RSCDONE No, join common end code 00809000 LA R0,2 Include X'0000' in CRC 00810000 LA R1,=H'0' 00811000 BAL R14,CRCCALC 00812000 LA R0,2 R0 = size of CRC 00813000 LA R1,CRCVAL R1 -> CRC 00814000 BAL R14,HQXPUT Output data fork CRC 00815000 L R0,=F'-1' R0 = -1 for cleanup 00816000 BAL R14,HQXPUT HQXPUT final cleanup call 00817000 * append final colon 00818000 L R1,WRLEN Room for colon in buffer? 00819000 C R1,=F'64' Yes, if length < 64 00820000 BL BINADDC 00821000 BAL R14,HQXLINE Else write 64 bytes to file 00822000 XC WRLEN(4),WRLEN and reset length 00823000 BINADDC L R2,WRLEN R2 = no. of bytes in WRITBUFF 00824000 L R1,=A(WRITBUFF) R1 -> start of buffer 00825000 LA R3,0(R1,R2) R3 -> next location 00826000 MVI 0(R3),C':' Store ending colon 00827000 LA R2,1(R2) Store new length 00828000 ST R2,WRLEN 00829000 BAL R14,HQXLINE Output final line 00830000 B RSCDONE Join common code 00831000 EJECT 00832000 * 00833000 * HQXPUT - Apply HQX compression algorithm to binary data, and call 00834000 * HQXEXP to expand up to 48 bytes of binary to up to 64 bytes 00835000 * of printable characters. At entry R0 is the number of bytes 00836000 * to process, and R1 contains their address. HQXPUT is called 00837000 * with R0 < 0 for final cleanup. 00838000 * 00839000 HQXPUT DS 0H 00840000 LTR R0,R0 Just return if zero bytes 00841000 BZR R14 00842000 STM R0,R15,HPUTSAVE Save registers 00843000 LR R2,R0 R2 = count for BCT 00844000 * R1 -> current byte 00845000 SR R3,R3 R3 = current CMPMODE 00846000 IC R3,CMPMODE 00847000 SR R4,R4 R4 = current HCMPCHAR 00848000 IC R4,HCMPCHAR 00849000 SR R5,R5 R5 = current CMPCOUNT 00850000 IC R5,CMPCOUNT 00851000 L R9,EXPLEN R9 = output length 00852000 L R8,=A(EXPBUFF) R8 -> next output byte 00853000 LA R8,0(R8,R9) 00854000 LTR R2,R2 Ready for main loop if R2 > 0 00855000 BP HPUTLP 00856000 * Else final cleanup call 00857000 CLI CMPMODE,0 Done if mode = 0 00858000 BE HCLEND 00859000 SR R1,R1 Set byte address to 0 00860000 LA R2,1 Set BCT count to 1 00861000 SR R6,R6 Get character in R6 00862000 IC R6,HCMPCHAR 00863000 SR R7,R7 Get count in R7 00864000 IC R7,CMPCOUNT 00865000 B HOUT Enter loop at output code 00866000 SPACE 00867000 HPUTLP EQU * Loop to process each character 00868000 LTR R3,R3 Check for mode 1 00869000 BNZ HPUT1 00870000 * Else mode 0: 00871000 HPUT0 EQU * Mode 0: initial mode 00872000 IC R4,0(R1) Save current character 00873000 LA R5,1 Set count to 1 00874000 LA R3,1 Set mode to 1 00875000 B HPUTNXT Ready for next byte 00876000 SPACE 00877000 HPUT1 EQU * Mode 1: checking for comp. 00878000 CLM R4,B'0001',0(R1) New char. the same as prev.? 00879000 BNE HDIFF No, go handle 00880000 LA R5,1(R5) Increment count 00881000 C R5,=F'255' Done if < 255 00882000 BL HPUTNXT 00883000 LR R6,R4 R6 = char. to output 00884000 LR R7,R5 R7 = count 00885000 SR R3,R3 Mode = 0 (no prev. char.) 00886000 B HOUT 00887000 SPACE 00888000 HDIFF EQU * New char. not same as prev. 00889000 * Output previous character 00890000 LR R6,R4 R6 = char. to output 00891000 LR R7,R5 R7 = count to output 00892000 IC R4,0(R1) Save current character 00893000 LA R5,1 Set count to 1 00894000 HOUT EQU * Char. in R6, count in R7 00895000 LTR R7,R7 Done if count = 0 00896000 BZ HPUTNXT 00897000 STC R6,0(R8) Append byte to buffer 00898000 LA R8,1(R8) Increment pointer 00899000 LA R9,1(R9) Increment count 00900000 C R9,=F'48' Buffer full? 00901000 BL HOUT2 No, check for X'90' 00902000 ST R9,EXPLEN Store length for HQXEXP 00903000 BAL R14,HQXEXP Call expansion routine 00904000 L R8,=A(EXPBUFF) Reset pointer 00905000 SR R9,R9 Reset count 00906000 HOUT2 CLM R6,B'0001',=X'90' Is character X'90'? 00907000 BNE HOUT3 No, check for repetition 00908000 MVI 0(R8),0 Append zero byte 00909000 LA R8,1(R8) Increment pointer 00910000 LA R9,1(R9) Increment count 00911000 C R9,=F'48' Buffer full? 00912000 BL HOUT3 No, check for repetition 00913000 ST R9,EXPLEN Store length for HQXEXP 00914000 BAL R14,HQXEXP Call expansion routine 00915000 L R8,=A(EXPBUFF) Reset pointer 00916000 SR R9,R9 Reset count 00917000 HOUT3 BCTR R7,0 Decrement count 00918000 C R7,=F'2' If < 2 more, output w/o comp. 00919000 BL HOUT 00920000 * else output X'90', count 00921000 MVI 0(R8),X'90' Append X'90' 00922000 LA R8,1(R8) Increment pointer 00923000 LA R9,1(R9) Increment count 00924000 C R9,=F'48' Buffer full? 00925000 BL HOUT4 No, ready for count 00926000 ST R9,EXPLEN Store length for HQXEXP 00927000 BAL R14,HQXEXP Call expansion routine 00928000 L R8,=A(EXPBUFF) Reset pointer 00929000 SR R9,R9 Reset count 00930000 HOUT4 LA R7,1(R7) Restore original byte count 00931000 STC R7,0(R8) Append byte count 00932000 LA R8,1(R8) Increment pointer 00933000 LA R9,1(R9) Increment count 00934000 C R9,=F'48' Buffer full? 00935000 BL HPUTNXT No, all done 00936000 ST R9,EXPLEN Store length for HQXEXP 00937000 BAL R14,HQXEXP Call expansion routine 00938000 L R8,=A(EXPBUFF) Reset pointer 00939000 SR R9,R9 Reset count 00940000 HPUTNXT LA R1,1(R1) R1 -> next byte 00941000 BCT R2,HPUTLP Decrement count and repeat 00942000 L R2,HPUTSAVE Get original R0 00943000 LTR R2,R2 If <0, finish cleanup 00944000 BM HCLEND 00945000 ST R9,EXPLEN Store EXPBUFF length 00946000 STC R3,CMPMODE Store CMPMODE 00947000 STC R4,HCMPCHAR Store HCMPCHAR 00948000 STC R5,CMPCOUNT Store CMPCOUNT 00949000 HPUTRTN LM R0,R15,HPUTSAVE Restore registers 00950000 BR R14 Return to caller 00951000 SPACE 00952000 HCLEND EQU * Output bytes left in EXPBUFF 00953000 ST R9,EXPLEN Store length for HQXEXP 00954000 C R9,=F'48' Check for zeros to add 00955000 BE HNOZERO None if buffer full 00956000 MVI 0(R8),0 Add one zero 00957000 LA R8,1(R8) 00958000 C R9,=F'47' Room for another? 00959000 BE HNOZERO No, ready to output 00960000 MVI 0(R8),0 Add another null 00961000 HNOZERO BAL R14,HQXEXP Call expansion routine 00962000 B HPUTRTN Ready to return 00963000 SPACE 00964000 HPUTSAVE DS 8D Local save area 00965000 EJECT 00966000 * 00967000 * HQXEXP - Expand data in EXPBUFF to 6 bits in each byte. The length 00968000 * is used from EXPLEN, and is assumed to not exceed 48. 00969000 * Expanded data is translated and moved to WRITBUFF. HQXLINE 00970000 * is called to output WRITBUFF as necessary. 00971000 * 00972000 HQXEXP STM R0,R15,HEXPSAVE Save registers 00973000 SR R2,R2 R2, R3 = size of EXPBUFF data 00974000 L R3,EXPLEN 00975000 LTR R3,R3 If zero, just return 00976000 BZ HEXPRTN 00977000 D R2,=F'3' Divide to get 3-byte pieces 00978000 LTR R2,R2 Check for any remainder 00979000 BZ HNORM If none, keep count 00980000 LA R0,1(R3) Piece count = quotient+1 00981000 SLL R3,2 Length = quotient*4 00982000 LA R3,1(R2,R3) + remainder + 1 00983000 LR R2,R0 Copy piece count to R2 00984000 B HCNT Continue with these counts 00985000 SPACE 00986000 HNORM LR R2,R3 R2 = count of pieces for BCT 00987000 SLL R3,2 R3 = output length (count*4) 00988000 HCNT L R4,=A(EXPBUFF) R4 -> start of input 00989000 LA R5,HEXPBUFF R5 -> start of output 00990000 HEXPLP EQU * Loop to expand pieces 00991000 ICM R7,B'1110',0(R4) Get all 24 bits in R7 00992000 SR R6,R6 Get first 6 bits in R6 00993000 SLDL R6,6 00994000 STC R6,0(R5) Store first result byte 00995000 SR R6,R6 Repeat for 2nd byte 00996000 SLDL R6,6 00997000 STC R6,1(R5) 00998000 SR R6,R6 Repeat for 3rd byte 00999000 SLDL R6,6 01000000 STC R6,2(R5) 01001000 SR R6,R6 Repeat for 4th byte 01002000 SLDL R6,6 01003000 STC R6,3(R5) 01004000 LA R4,3(R4) Increment input pointer 01005000 LA R5,4(R5) Increment output pointer 01006000 BCT R2,HEXPLP Repeat for piece count 01007000 BCTR R3,0 Get length-1 for execute 01008000 L R4,=A(BINTOASC) R4 -> binary-to-ASCII table 01009000 EX R3,HEXPTR Convert binary to ASCII 01010000 L R4,FRASCADR R4 -> ASCII-to-EBCDIC table 01011000 EX R3,HEXPTR Convert ASCII to EBCDIC 01012000 LA R3,1(R3) Restore original length 01013000 LA R2,HEXPBUFF R2 -> first byte 01014000 LA R5,64 R5 = bytes left in WRITBUFF 01015000 S R5,WRLEN 01016000 CR R3,R5 Will all bytes fit? 01017000 BNH HEXWRCPY Yes, copy into buffer 01018000 L R4,=A(WRITBUFF) R4 -> next output location 01019000 A R4,WRLEN 01020000 BCTR R5,0 R5 = length for EX 01021000 EX R5,HEXPMVC Fill output buffer 01022000 LA R4,64 Store new length 01023000 ST R4,WRLEN 01024000 BAL R14,HQXLINE Output buffer to file 01025000 XC WRLEN(4),WRLEN Reset length 01026000 LA R5,1(R5) Get actual count moved 01027000 SR R3,R5 R3 = bytes still to move 01028000 LA R2,0(R2,R5) R2 -> next byte to move 01029000 HEXWRCPY L R4,=A(WRITBUFF) R4 -> next output location 01030000 A R4,WRLEN 01031000 BCTR R3,0 R3 = length for EX 01032000 EX R3,HEXPMVC Move bytes to output buffer 01033000 L R4,WRLEN Update buffer size 01034000 LA R4,1(R3,R4) 01035000 ST R4,WRLEN 01036000 C R4,=F'64' Is buffer full now? 01037000 BNE HEXPRTN No, ready to return 01038000 BAL R14,HQXLINE Output full buffer 01039000 XC WRLEN(4),WRLEN Reset buffer length 01040000 HEXPRTN LM R0,R15,HEXPSAVE Restore registers 01041000 BR R14 Return to caller 01042000 SPACE 01043000 HEXPSAVE DS 8D Local save area 01044000 HEXPBUFF DS 8D Local buffer for expansion 01045000 HEXPTR TR HEXPBUFF(*-*),0(R4) 01046000 HEXPMVC MVC 0(*-*,R4),0(R2) 01047000 EJECT 01048000 * 01049000 * HQXLINE - Write contents of WRITBUFF to output file. The current 01050000 * length of the data in WRITBUFF is given in WRITLEN. 01051000 * Returns to caller if no error; otherwise types an error 01052000 * message and returns directly to CMS. 01053000 * 01054000 HQXLINE DS 0H 01055000 STM R0,R15,HQXLSAVE Save registers 01056000 L R2,WRITEM Increment line number 01057000 LA R2,1(R2) 01058000 ST R2,WRITEM 01059000 OI FLAGS,WROPEN Remember file is open 01060000 MVC WRBUFLTH(4),WRLEN Set line length from buffer size 01061000 LA R1,OUTPLIST R1 -> PLIST 01062000 L R15,AWRBUF R15 -> WRBUF entry 01063000 BALR R14,R15 Call WRBUF 01064000 BZ HQXLRET If ok, ready to return 01065000 LR R2,R15 Copy error code to R2 01066000 DMSERR LET=S,NUM=105, X01067000 TEXT='Error ''..'' writing file ''....................''X01068000 on disk',SUB=(DEC,(R2),CHAR8A,OFN),RENT=NO 01069000 LA R2,100(R2) Set RC = 1nn 01070000 ST R2,RTNCODE Set code to return 01071000 B CMSRTN Direct return to CMS 01072000 SPACE 01073000 HQXLRET LM R0,R15,HQXLSAVE Restore registers 01074000 BR R14 Return to caller 01075000 SPACE 01076000 HQXLSAVE DS 8D Local save area 01077000 EJECT 01078000 * 01079000 * GETSTR - Fill buffer with bytes from input file. At entry, 01080000 * R0 contains the buffer size and R1 contains the buffer 01081000 * address. If any errors occur, GETSTR generates an 01082000 * error message and returns to CMS. 01083000 * 01084000 GETSTR DS 0H 01085000 STM R0,R15,GSSAVE Save registers 01086000 LR R4,R0 R4 = buffer size 01087000 LR R5,R1 R5 -> buffer 01088000 GSAGAIN LTR R4,R4 Buffer size = 0? 01089000 BZ GSRTN If so, just return 01090000 CLI CMPCNT,0 Compressed data to return? 01091000 BNE GSUSECMP Yes, go use it 01092000 L R6,BINLEN R6 = count of bytes left 01093000 L R7,=A(BINBUFF) R7 -> next byte 01094000 A R7,BINOFF 01095000 LTR R6,R6 Any bytes left? 01096000 BP GSUSEBIN Yes, go use them 01097000 MVC GSPREV(1),BINLAST Save last byte from current line 01098000 BAL R14,GTBINLIN Read more binary data 01099000 LTR R15,R15 Any error? 01100000 BZ GSAGAIN No, use data 01101000 B GSEOF Else return EOF 01102000 SPACE 01103000 GSUSEBIN EQU * Process data in BINBUFF 01104000 LA R1,0(R6,R7) R1 -> past last byte 01105000 LR R3,R6 R3 = length-1 for TRT 01106000 BCTR R3,0 01107000 L R8,=A(CMPTAB) R8 -> TRT table 01108000 EX R3,CMPTRT Scan for X'90' in BINBUFF 01109000 SR R1,R7 R1 = length before X'90' 01110000 BZ GSCMPINI If none, set up for compression 01111000 NI FLAGS,255-X90DATA X90 data byte no longer current 01112000 CR R1,R4 Longer than needed? 01113000 BNH GSMVDATA No, keep length 01114000 LR R1,R4 Else reduce to length needed 01115000 GSMVDATA BCTR R1,0 Decrement length for EX 01116000 EX R1,DATAMVC Move data to caller's buffer 01117000 LA R1,1(R1) Restore actual length 01118000 SR R4,R1 Decrement buffer size 01119000 LA R5,0(R1,R5) Increment buffer address 01120000 L R2,BINLEN Decrement binary length 01121000 SR R2,R1 01122000 ST R2,BINLEN 01123000 L R2,BINOFF Increment binary offset 01124000 AR R2,R1 01125000 ST R2,BINOFF 01126000 B GSAGAIN Check for more to do 01127000 SPACE 01128000 GSCMPINI EQU * R7 -> X'90' 01129000 * Get compression character 01130000 TM FLAGS,X90DATA Have character from last X'90'? 01131000 BO USEX90 Yes, use it 01132000 L R1,BINOFF Is X'90' at start of line 01133000 LTR R1,R1 If so, use byte from previous line 01134000 BZ USEPREV 01135000 LR R1,R7 Else use previous byte on line 01136000 BCTR R1,0 R1 -> byte to use 01137000 B STCMPCHR 01138000 SPACE 01139000 USEX90 LA R1,X90CHAR R1 -> byte from last X90 01140000 B STCMPCHR 01141000 SPACE 01142000 USEPREV LA R1,GSPREV R1 -> byte to use 01143000 STCMPCHR MVC CMPCHAR(1),0(R1) Store byte to replicate 01144000 OI FLAGS,X90DATA Set flag for X90 data 01145000 MVC X90CHAR(1),0(R1) Save X90 data byte 01146000 C R6,=F'1' Is count available after X'90'? 01147000 BNH GSRDCNT No, go read it 01148000 MVC CMPCNT(1),1(R7) Store compression count 01149000 L R2,BINOFF Increment binary offset 01150000 LA R2,2(R2) 01151000 ST R2,BINOFF 01152000 L R2,BINLEN Decrement binary length 01153000 BCTR R2,0 01154000 BCTR R2,0 01155000 ST R2,BINLEN 01156000 B CHKCMP Ready to check what we have 01157000 SPACE 01158000 GSRDCNT BAL R14,GTBINLIN Read more binary data 01159000 LTR R15,R15 Any error? 01160000 BNZ GSEOF Yes, return EOF 01161000 L R6,BINLEN Update R6, R7 for new read 01162000 L R7,=A(BINBUFF) 01163000 A R7,BINOFF 01164000 MVC CMPCNT(1),0(R7) Store compression count 01165000 L R2,BINOFF Increment binary offset 01166000 LA R2,1(R2) 01167000 ST R2,BINOFF 01168000 L R2,BINLEN Decrement binary length 01169000 BCTR R2,0 01170000 ST R2,BINLEN 01171000 CHKCMP CLI CMPCNT,0 New count = 0? 01172000 BNE GSDECCMP No, adjust count to be length 01173000 MVI X90CHAR,X'90' Data byte is now X'90' 01174000 MVI 0(R5),X'90' Return X'90' 01175000 BCTR R4,0 Decrement buffer size 01176000 LA R5,1(R5) Increment buffer pointer 01177000 B GSAGAIN See if more to do 01178000 SPACE 01179000 GSDECCMP SR R1,R1 Get count in R1 01180000 IC R1,CMPCNT 01181000 BCTR R1,0 Decrement to get replication count 01182000 STC R1,CMPCNT 01183000 LTR R1,R1 If zero, start again 01184000 BNP GSAGAIN 01185000 GSUSECMP SR R1,R1 R1 = compression count 01186000 IC R1,CMPCNT 01187000 LR R2,R1 Save in R2 01188000 CR R1,R4 Count bigger than buffer size? 01189000 BNH CMPCPY No, keep count 01190000 LR R1,R4 Else reduce to buffer size 01191000 CMPCPY SR R2,R1 R2 = remaining count 01192000 STC R2,CMPCNT Store remaining count 01193000 LR R8,R1 Save count in R8 01194000 LR R0,R5 R0 -> destination 01195000 * R1 = destination length 01196000 SR R2,R2 R2 -> source (none) 01197000 SR R3,R3 R3 = source length (zero) 01198000 ICM R3,B'1000',CMPCHAR Pad char. = compression char. 01199000 MVCL R0,R2 Store duplicated characters 01200000 SR R4,R8 Decrement buffer size 01201000 LA R5,0(R5,R8) Increment buffer pointer 01202000 B GSAGAIN Check for more to do 01203000 SPACE 01204000 GSRTN LM R0,R15,GSSAVE Restore registers 01205000 BR R14 Return to caller 01206000 SPACE 01207000 GSEOF DMSERR NUM=6,LET=E, X01208000 TEXT='Unexpected end-of-file reading ''.................X01209000 ...''',SUB=(CHAR8A,IFN) 01210000 MVI RTNCODE+3,36 CMS RC = 36 01211000 B CMSRTN 01212000 SPACE 01213000 GSSAVE DS 8D Local save area 01214000 CMPTRT TRT 0(*-*,R7),0(R8) TRT for X'90' 01215000 DATAMVC MVC 0(*-*,R5),0(R7) Move binary data to buffer 01216000 GSPREV DS 1X Last byte from previous line 01217000 X90CHAR DS 1X Data byte for last X'90' 01218000 EJECT 01219000 * 01220000 * GTBINLIN - Convert data in READBUFF to binary data in BINBUFF 01221000 * (HQX files only). The length is returned in BINLEN. 01222000 * Returns R15=0 (ok) or R15=12 (eof). 01223000 * 01224000 GTBINLIN DS 0H 01225000 STM R0,R15,GBSAVE Save registers 01226000 GBAGAIN BAL R14,GETLINE Get more data from file 01227000 ST R15,GBSAVE+60 Store return code 01228000 LTR R15,R15 Return if non-zero 01229000 BNZ GBRET 01230000 XC BINOFF(4),BINOFF Reset offset for reading result 01231000 L R1,=A(READBUFF) R1 -> first byte 01232000 A R1,RDOFF 01233000 L R2,RDLGTH R2 = length 01234000 L R3,=A(BINBUFF) R3 -> output buffer 01235000 SR R4,R4 R4 = output length 01236000 LA R5,CVCNT0 R5 = addr. for checking zero bits 01237000 GBINILP EQU * Loop until no bits left over or EOF 01238000 LTR R2,R2 Any bytes left? 01239000 BZ GBEND No, ready to return 01240000 C R5,BINXTADR No bits left over? 01241000 BE GBGROUP Yes, do groups of bytes 01242000 BAL R14,CVTBYTE Convert next byte 01243000 STC R0,0(R3) Store output byte 01244000 LA R3,1(R3) Increment address 01245000 LA R4,1(R4) Increment length 01246000 LA R1,1(R1) Increment pointer 01247000 BCTR R2,0 Decrement length 01248000 B GBINILP Repeat 01249000 SPACE 01250000 * Process groups of 8 input byte to get 6 binary bytes 01251000 GBGROUP LR R5,R2 Get count of groups 01252000 SRL R5,3 = byte count/8 01253000 LTR R5,R5 Any groups? 01254000 BZ GBFIN No, loop for any bytes left 01255000 SR R8,R8 R8 = 0 for IC 01256000 LA R0,1 R0 = 1 for increments 01257000 GBGRLP EQU * Loop to process groups 01258000 LA R9,8 R9 = byte count for loop 01259000 GBG1LP EQU * Loop for 1 group 01260000 IC R8,0(R1) Get new byte 01261000 SLDL R6,6 Make room for new bits 01262000 OR R7,R8 OR-in bits 01263000 AR R1,R0 R1 -> next byte 01264000 BCT R9,GBG1LP Repeat for 8 bytes 01265000 S R2,=F'8' Decrement bytes left 01266000 STCM R6,B'0011',0(R3) Store result bytes 01267000 STCM R7,B'1111',2(R3) 01268000 LA R3,6(R3) Increment output address 01269000 LA R4,6(R4) Increment output length 01270000 BCT R5,GBGRLP Loop for all groups 01271000 * Loop to process any remaining bytes 01272000 GBFIN LTR R2,R2 Any bytes left? 01273000 BZ GBEND No, ready to return 01274000 GBENDLP EQU * Loop to process remaining bytes 01275000 BAL R14,CVTBYTE Convert next byte 01276000 LTR R0,R0 Result byte returned? 01277000 BM GBENDNXT No, skip saving byte 01278000 STC R0,0(R3) Store output byte 01279000 LA R3,1(R3) Increment address 01280000 LA R4,1(R4) Increment length 01281000 GBENDNXT LA R1,1(R1) Increment pointer 01282000 BCT R2,GBENDLP 01283000 SPACE 01284000 * Return to caller 01285000 GBEND LTR R4,R4 Non-zero length to return? 01286000 BZ GBAGAIN No, read next line 01287000 ST R4,BINLEN Store output length 01288000 L R3,=A(BINBUFF) R4 -> last byte 01289000 LA R3,0(R3,R4) 01290000 BCTR R3,0 01291000 MVC BINLAST(1),0(R3) Save in case part of compression 01292000 GBRET LM R0,R15,GBSAVE Restore registers, RC in R15 01293000 BR R14 01294000 SPACE 01295000 GBSAVE DS 8D Local save area 01296000 EJECT 01297000 * 01298000 * CVTBYTE - Read next byte using address in R1 and any left over bits 01299000 * in BINEXTRA. Return a new byte in R0, and set BINEXTRA 01300000 * and BINXTADR as appropriate. Return R0=-1 if more bits 01301000 * are needed to make a byte. 01302000 * 01303000 CVTBYTE DS 0H 01304000 STM R0,R15,CVSAVE Save registers and RC 01305000 L R2,BINXTADR Get addr. for processing 01306000 BR R2 Branch for left over bits 01307000 SPACE 01308000 CVCNT0 EQU * No bits left over 01309000 IC R3,0(R1) New bits in R3 01310000 LA R1,CVCNT6 Set 6 bits left over 01311000 ST R1,BINXTADR 01312000 L R0,=F'-1' Return -1 in R0 01313000 STC R3,BINEXTRA Store left over bits 01314000 B CVRTN 01315000 SPACE 01316000 CVCNT6 EQU * 6 bits left from last time 01317000 SR R2,R2 Left over bits in R2 01318000 IC R2,BINEXTRA 01319000 IC R3,0(R1) New bits in R3 01320000 SLL R3,26 Make new bits most significant 01321000 SLDL R2,2 Get new byte in R2 01322000 SRL R3,28 Get left over bits in R3 01323000 LA R1,CVCNT4 Set 4 bits left over 01324000 ST R1,BINXTADR 01325000 LR R0,R2 Return byte in R0 01326000 STC R3,BINEXTRA Store left over bits 01327000 B CVRTN Ready to return 01328000 SPACE 01329000 CVCNT4 EQU * 4 bits left from last time 01330000 SR R2,R2 Left over bits in R2 01331000 IC R2,BINEXTRA 01332000 IC R3,0(R1) New bits in R3 01333000 SLL R3,26 Make new bits most significant 01334000 SLDL R2,4 Get new byte in R2 01335000 SRL R3,30 Get left over bits in R3 01336000 LA R1,CVCNT2 Set 2 bits left over 01337000 ST R1,BINXTADR 01338000 LR R0,R2 Return byte in R0 01339000 STC R3,BINEXTRA Store left over bits 01340000 B CVRTN Ready to return 01341000 SPACE 01342000 CVCNT2 EQU * 2 bits left from last time 01343000 SR R2,R2 Left over bits in R2 01344000 IC R2,BINEXTRA 01345000 IC R3,0(R1) New bits in R3 01346000 SLL R3,26 Make new bits most significant 01347000 SLDL R2,6 Get new byte in R2 01348000 LA R1,CVCNT0 Set 0 bits left over 01349000 ST R1,BINXTADR 01350000 LR R0,R2 Return byte in R0 01351000 * B CVRTN Ready to return 01352000 SPACE 01353000 CVRTN LM R1,R15,CVSAVE+4 Restore all but result in R0 01354000 BR R14 Return to caller 01355000 SPACE 01356000 CVSAVE DS 8D Local save area 01357000 EJECT 01358000 * 01359000 * GETLINE - Read the next line of the input file into READBUFF. 01360000 * The length is returned in RDLGTH and the starting 01361000 * offset is returned in RDOFF. For HQX files, data is 01362000 * returned between a starting colon in column one of a 01363000 * line, and an ending colon. Also, data is translated 01364000 * to six-bit binary. 01365000 * Return R15=0 (ok) or R15=12 (eof). 01366000 * 01367000 GETLINE DS 0H 01368000 STM R0,R15,GLSAVE Save registers 01369000 GLAGAIN TM FLAGS,HQXEOF EOF set from last time? 01370000 BO GLEOFRET Yes, return eof 01371000 L R1,RDITEM Increment line number 01372000 LA R1,1(R1) 01373000 ST R1,RDITEM 01374000 XC RDOFF(4),RDOFF Reset read offset 01375000 OI FLAGS,RDOPEN Remember input file is open 01376000 LA R1,INPLIST R1 -> PLIST 01377000 L R15,ARDBUF R15 -> RDBUF entry 01378000 BALR R14,R15 Call RDBUF 01379000 ST R15,GLSAVE+60 Return RC in R15 01380000 BZ GLRDOK RC 0 is normal 01381000 C R15,=F'12' RC 12 is eof 01382000 BE GLRET 01383000 * Else unexpected error 01384000 LR R2,R15 Copy error code to R2 01385000 DMSERR LET=S,NUM=104, X01386000 TEXT='Error ''..'' reading file ''....................''X01387000 from disk',SUB=(DEC,(R2),CHAR8A,IFN),RENT=NO 01388000 LA R2,100(R2) Set RC = 1nn 01389000 ST R2,RTNCODE 01390000 B CMSRTN Direct return to CMS 01391000 SPACE 01392000 GLRDOK CLC RDLGTH(4),=F'0' Any bytes read? 01393000 BE GLAGAIN No (very strange); try again 01394000 L R1,CHRTOTAL Increment character count 01395000 A R1,RDLGTH 01396000 ST R1,CHRTOTAL 01397000 TM FLAGS,MACBIN If reading MacBinary, all done 01398000 BO GLRET 01399000 * For HQX file, adjust length to delete trailing blanks 01400000 L R1,RDLGTH R1 = count for BCT 01401000 L R2,=A(READBUFF) R2 -> last byte 01402000 LA R2,0(R1,R2) R2 -> last byte 01403000 BCTR R2,0 01404000 GLTRLOOP EQU * Loop to truncate blanks 01405000 CLI 0(R2),C' ' Found non-blank? 01406000 BNE GLTREND Yes, done 01407000 BCTR R2,0 R2 -> previous byte 01408000 BCT R1,GLTRLOOP Repeat for line length 01409000 B GLAGAIN If all blank, read next line 01410000 SPACE 01411000 GLTREND ST R1,RDLGTH Store adjusted line length 01412000 * For HQX file, handle initial colon 01413000 TM FLAGS,HQXCOLON Colon in previous line? 01414000 BO GLHQXCNT Yes, continue 01415000 L R2,=A(READBUFF) Does this line start with colon? 01416000 CLI 0(R2),C':' 01417000 BNE GLAGAIN No, try again 01418000 OI FLAGS,HQXCOLON Remember have found colon 01419000 BCTR R1,0 Decrement line length 01420000 LTR R1,R1 Zero now? 01421000 BZ GLAGAIN Yes, get next line 01422000 ST R1,RDLGTH Store new length 01423000 LA R2,1 Initial offset = 1 01424000 ST R2,RDOFF 01425000 * For HQX file, check for ending colon or invalid character 01426000 GLHQXCNT L R3,=A(READBUFF) R3 -> first byte 01427000 A R3,RDOFF 01428000 L R4,RDLGTH R4 = length 01429000 BCTR R4,0 Decrement length for EX 01430000 SR R1,R1 Initialize R1 before TRT 01431000 L R5,=A(VALIDTAB) R5 -> TRT table 01432000 EX R4,HQXTRT Scan for invalid character 01433000 BZ GLHQXTR Ready to translate if none 01434000 OI FLAGS,HQXEOF Remember EOF for HQX file 01435000 MVC EOFCHAR(1),0(R1) Save character we stopped at 01436000 LA R2,1(R1) Save character position in line 01437000 L R4,=A(READBUFF) 01438000 SR R2,R4 01439000 ST R2,EOFPOS 01440000 SR R1,R3 R1 = new length 01441000 ST R1,RDLGTH Store new length 01442000 BNP GLEOFRET Return EOF if not positive 01443000 * For HQX file, translate EBCDIC to 6-bit binary 01444000 GLHQXTR L R1,RDLGTH R1 = length 01445000 BCTR R1,0 Decrement for EX 01446000 L R2,=A(READBUFF) R2 -> first byte 01447000 A R2,RDOFF 01448000 L R3,TOASCADR R3 -> EBCDIC-to-ASCII table 01449000 EX R1,GLTR Translate data to ASCII 01450000 L R3,=A(ASCTOBIN) R3 -> ASCII-to-binary table 01451000 EX R1,GLTR Translate ASCII to binary 01452000 * Return to caller 01453000 GLRET LM R0,R15,GLSAVE Restore registers, RC in R15 01454000 BR R14 01455000 SPACE 01456000 GLEOFRET CLI EOFCHAR,C':' Stopped at a colon? 01457000 BNE GLBADCHR No, give error message 01458000 LA R15,12 Else return normal eof 01459000 LM R0,R14,GLSAVE 01460000 BR R14 01461000 SPACE 01462000 GLBADCHR DMSERR LET=E,NUM=5,TEXT='Invalid character ''..'' in ''.......X01463000 .............'' at line .......... position ...', X01464000 RENT=NO,SUB=(CHARA,(EOFCHAR,1),CHAR8A,IFN,DECA,RDITEM,DEX01465000 CA,EOFPOS) 01466000 MVI RTNCODE+3,36 Set RC = 36 01467000 B CMSRTN Direct return to CMS 01468000 SPACE 01469000 GLSAVE DS 8D Local save area 01470000 HQXTRT TRT 0(*-*,R3),0(R5) TRT to check valid characters 01471000 GLTR TR 0(*-*,R2),0(R3) Translate to ASCII or binary 01472000 EJECT 01473000 * 01474000 * WR128 - Write 128 bytes of data to a MacBinary output file. 01475000 * At entry, R1 -> 128 bytes to be written. 01476000 * 01477000 WR128 DS 0H 01478000 STM R0,R15,WRSAVE Save registers 01479000 L R2,WRITEM Increment line number 01480000 LA R2,1(R2) 01481000 ST R2,WRITEM 01482000 OI FLAGS,WROPEN Remember output file is open 01483000 ST R1,WRADDR Store buffer address 01484000 LA R1,OUTPLIST R1 -> PLIST 01485000 L R15,AWRBUF R15 -> WRBUF entry 01486000 BALR R14,R15 Call WRBUF 01487000 BZ WRRET If ok, ready to return 01488000 LR R2,R15 Copy error code to R2 01489000 DMSERR LET=S,NUM=105, X01490000 TEXT='Error ''..'' writing file ''....................''X01491000 on disk',SUB=(DEC,(R2),CHAR8A,OFN),RENT=NO 01492000 LA R2,100(R2) Set RC = 1nn 01493000 ST R2,RTNCODE 01494000 B CMSRTN Direct return to CMS 01495000 SPACE 01496000 WRRET LM R0,R15,WRSAVE Restore registers 01497000 BR R14 Return to caller 01498000 SPACE 01499000 WRSAVE DS 8D Local save area 01500000 EJECT 01501000 * 01502000 * CRCCALC - Update CRCVAL for a string. At entry, R0 = string length 01503000 * and R1 -> string. 01504000 * 01505000 CRCCALC DS 0H 01506000 STM R0,R15,CRCSAVE Save registers 01507000 LTR R7,R0 R7 = BCT count 01508000 BZ CRCRTN If zero, just return 01509000 LR R6,R1 R6 -> first byte 01510000 SR R3,R3 R3 = current CRC 01511000 ICM R3,B'1100',CRCVAL (in msb) 01512000 L R4,=V(XMDMTAB) R4 -> CRC table 01513000 SR R5,R5 R5 = 0 for table entries 01514000 CRCLOOP EQU * Loop for each character 01515000 SR R2,R2 Shift CRC and get old 01516000 SLDL R2,8 msb in R2 01517000 ICM R3,B'0100',0(R6) Append new byte to CRC 01518000 SLL R2,1 R2 = table offset 01519000 LA R2,0(R2,R4) R2 -> table entry 01520000 ICM R5,B'1100',0(R2) R5 = table entry 01521000 XR R3,R5 update CRC 01522000 LA R6,1(R6) R6 -> next byte 01523000 BCT R7,CRCLOOP Repeat to end of string 01524000 STCM R3,B'1100',CRCVAL Store final CRC 01525000 CRCRTN LM R0,R15,CRCSAVE Restore registers 01526000 BR R14 Return to caller 01527000 SPACE 01528000 CRCSAVE DS 8D Local save area 01529000 EJECT 01530000 * 01531000 * Error message code 01532000 * 01533000 SPACE 01534000 STATERR ST R15,RTNCODE Save return code from STATE 01535000 LA R2,8(R1) R2 -> filename in PLIST 01536000 C R15,=F'28' Return if STATE typed message 01537000 BL CMSRTN 01538000 BE STNOFIL RC = 28 is file not found 01539000 * Else disk not accessed (RC = 36) 01540000 LA R2,16(R2) R2 -> filemode in plist 01541000 DMSERR NUM=69,LET=E,TEXT='Disk ''..'' not accessed', X01542000 SUB=(CHARA,((R2),1)) 01543000 B CMSRTN 01544000 SPACE 01545000 STNOFIL DMSERR NUM=2,LET=E, X01546000 TEXT='File ''....................'' not found', X01547000 SUB=(CHAR8A,(R2)) 01548000 B CMSRTN 01549000 SPACE 01550000 LRECLERR MVI RTNCODE+3,32 Set RC = 32 01551000 DMSERR NUM=44,LET=E,TEXT='Record length exceeds allowable maxiX01552000 mum' 01553000 B CMSRTN 01554000 SPACE 01555000 EXIERR LTR R15,R15 If non-zero RC, handle STATE error 01556000 BNZ STATERR 01557000 LA R2,8(R1) R2 -> filemame in plist 01558000 DMSERR NUM=24,LET=E, X01559000 TEXT='File ''....................'' already exists', X01560000 SUB=(CHAR8A,(R2)) 01561000 MVI RTNCODE+3,28 01562000 B CMSRTN 01563000 SPACE 01564000 ROERR EQU * 01565000 USING ADTSECT,R2 01566000 LA R2,ADTM Point to mode letter 01567000 DROP R2 01568000 DMSERR NUM=37,LET=E,TEXT='Disk ''..'' is read-only', X01569000 SUB=(CHARA,((R2),1)) 01570000 MVI RTNCODE+3,36 01571000 B CMSRTN 01572000 SPACE 01573000 CMSRTN EQU * Return to CMS 01574000 TM FLAGS,RDOPEN Is input file open? 01575000 BZ RTN0 No, skip finis 01576000 L R15,AFINIS 01577000 LA R1,INPLIST 01578000 BALR R14,R15 Close input file 01579000 RTN0 TM FLAGS,WROPEN Is output file open? 01580000 BZ RTN1 No, skip finis 01581000 L R15,AFINIS 01582000 LA R1,OUTPLIST 01583000 BALR R14,R15 Close output file 01584000 RTN1 DMSKEY RESET Restore user key 01585000 SSM =X'FF' Allow interrupts 01586000 L R15,RTNCODE R15 = return code 01587000 LM R0,R14,REGSAVE Restore other registers 01588000 BR R14 Return to caller 01589000 EJECT 01590000 * 01591000 * GETID - Invoke IDENTIFY to get local node id. Set the 01592000 * node id to blanks if any error. 01593000 * 01594000 SPACE 01595000 GETID DS 0H 01596000 STM R14,R1,GETSAVE Save registers 01597000 MVC NODEID(8),=CL8' ' Initialize node id to blanks 01598000 LA R1,IDPLIST Execute IDENTIFY 01599000 SVC 202 01600000 DC AL4(1) 01601000 LTR R15,R15 Just return if any errors 01602000 BNZ GETIDRTN 01603000 RDTERM RDRESP Get response 01604000 C R0,=F'19' At least 19 bytes? 01605000 BL GETIDRTN No, just return 01606000 MVC NODEID(8),RDRESP+12 Copy node id from IDENTIFY 01607000 GETIDRTN LM R14,R1,GETSAVE Restore registers 01608000 BR R14 Return 01609000 SPACE 01610000 GETSAVE DS 2D Save area: R14, R15, R0, R1 01611000 IDPLIST DS 0D 01612000 DC CL8'IDENTIFY' IDENTIFY command 01613000 DC CL8'(' 01614000 DC CL8'LIFO' 01615000 DC 8X'FF' 01616000 RDRESP DS CL130 RDTERM buffer 01617000 EJECT 01618000 * 01619000 * DECCVT -- Convert decimal number in plist to binary 01620000 * 01621000 * Entry: R1 -> 8-byte number, R14 = return address 01622000 * Exit: R2 = -1 if conversion error, or contains binary number; 01623000 * condition code set from R2 01624000 * 01625000 DECCVT DS 0H 01626000 STM R3,R1,DECSAVE Save registers 01627000 SR R2,R2 Result = 0 01628000 LA R3,8 Examine 8 bytes 01629000 SR R4,R4 R4 = 0 for IC 01630000 * R1 -> first byte of token 01631000 DECLOOP EQU * Scan number and accumulate result 01632000 CLI 0(R1),C' ' Exit when blank encountered 01633000 BE DECEND 01634000 CLI 0(R1),C'0' Check for a valid digit 01635000 BL DECERR 01636000 CLI 0(R1),C'9' 01637000 BH DECERR 01638000 IC R4,0(R1) Get binary digit in R4 01639000 SH R4,=H'240' 01640000 MH R2,=H'10' Result = 10*result + digit 01641000 AR R2,R4 01642000 LA R1,1(R1) R1 -> next digit 01643000 BCT R3,DECLOOP Repeat 01644000 B DECEND Skip error result 01645000 DECERR LH R2,=H'-1' Error: return -1 01646000 DECEND LM R3,R1,DECSAVE Restore all registers except R2 01647000 LTR R2,R2 Set condition code for caller 01648000 BR R14 Return to caller 01649000 SPACE 01650000 DECSAVE DS 8D Save area R3...R15, R0, R1 01651000 EJECT 01652000 * 01653000 * NUMTOSTR - Store character form of a number in a buffer. 01654000 * At entry, R0 contains the number and R1 points to 01655000 * the buffer. Returns the length of the string 01656000 * stored in R0. 01657000 * 01658000 NUMTOSTR DS 0H 01659000 STM R0,R15,NUMSAVE Save registers 01660000 CVD R0,NUMBUF Convert number to decimal 01661000 TM FLAGS2,EXECVAR+NOCOMMA Check if commas not wanted 01662000 BNZ ALTEDIT 01663000 MVC EDITBUFF(15),EDITPAT Copy pattern for EDMK 01664000 LA R1,EDITBUFF+14 R1 -> last byte 01665000 EDMK EDITBUFF(15),NUMBUF+2 Convert to characters 01666000 LA R2,EDITBUFF+15 R2 -> past last byte 01667000 B NUMEND 01668000 SPACE 01669000 ALTEDIT MVC EDITBUFF(12),EDITPAT2 Copy pattern for EDMK 01670000 LA R1,EDITBUFF+11 R1 -> last byte 01671000 EDMK EDITBUFF(12),NUMBUF+2 Convert to characters 01672000 LA R2,EDITBUFF+12 R2 -> past last byte 01673000 NUMEND SR R2,R1 Get length in R2 01674000 ST R2,NUMSAVE Store to return in R0 01675000 BCTR R2,0 Decrement for EX 01676000 L R3,NUMSAVE+4 R3 -> buffer 01677000 EX R2,NUMMVC Copy number to buffer 01678000 LM R0,R15,NUMSAVE Return to caller 01679000 BR R14 01680000 SPACE 01681000 NUMSAVE DS 8D Local save area 01682000 NUMBUF DS 1D Buffer for CVD 01683000 NUMMVC MVC 0(*-*,R3),0(R1) Copy number to buffer 01684000 EDITPAT DC X'4020206B2020206B2020206B202120' EDIT pattern 01685000 EDITPAT2 DC X'402020202020202020202120' alternate pattern 01686000 EDITBUFF DS 15C Buffer for EDIT result 01687000 EJECT 01688000 * 01689000 * SEC2DATE - Store the character form of a Macintosh date in a 01690000 * buffer. At entry, R0 contains the number of seconds 01691000 * since midnight, Jan. 1, 1904. R1 points to the buffer 01692000 * which will contains the date. The length of the date 01693000 * is returned in R0. 01694000 * 01695000 SEC2DATE DS 0H 01696000 STM R0,R15,SECSAVE Save registers 01697000 OI FLAGS2,NOCOMMA Suppress commas for NUMTOSTR 01698000 * Get elapsed days, hours, minutes, seconds 01699000 LR R1,R0 R0, R1 = total seconds 01700000 SR R0,R0 01701000 D R0,=F'86400' Divide to get days 01702000 ST R1,SECDAYS Store elapsed days 01703000 LR R1,R0 R0, R1 = remaining seconds 01704000 SR R0,R0 01705000 D R0,=F'3600' Divide to get hours 01706000 ST R1,SECHRS Store elapsed hours 01707000 LR R1,R0 R0, R1 = remaining seconds 01708000 SR R0,R0 01709000 D R0,=F'60' Divide to get mins, seconds 01710000 ST R1,SECMIN Store elpased minutes 01711000 ST R0,SECSEC Store elpased seconds 01712000 * Calculate day of the week 01713000 SR R0,R0 Divide days by 7 01714000 L R1,SECDAYS 01715000 D R0,=F'7' 01716000 ST R0,SECWKDAY Store remainder 01717000 * Calculate month, day and year from elapsed days 01718000 L R3,SECDAYS R3 = elapsed days 01719000 A R3,=F'1401' Add constant to get days from 01720000 * March 1, 1900 01721000 * Get 4*Jdate + 3 01722000 SLL R3,2 01723000 LA R3,3(R3) 01724000 SR R2,R2 Divide by 1461 01725000 D R2,=F'1461' 01726000 * R2 = day, R3 = year 01727000 SRL R2,2 Day = day/4 + 1 01728000 LA R2,1(R2) 01729000 MH R2,=H'5' Get (5*day-3)/153 01730000 S R2,=F'3' 01731000 SR R4,R4 01732000 LR R5,R2 01733000 D R4,=F'153' 01734000 * R4 = day, R5 = month 01735000 LR R2,R5 R2 = month 01736000 SR R0,R0 Day = day/5 + 1 01737000 LR R1,R4 01738000 D R0,=F'5' 01739000 LA R1,1(R1) R1 = day, R2 = month, R3 = year 01740000 LA R2,3(R2) Month = Month + 3 01741000 C R2,=F'12' If > 12, subtract 12 01742000 BNH KEEPMON 01743000 S R2,=F'12' 01744000 LA R3,1(R3) And add 1 to year 01745000 KEEPMON EQU * 01746000 ST R1,SECDAY Store day of month 01747000 ST R2,SECMONTH Store month 01748000 LA R3,1900(R3) Add base year to year 01749000 ST R3,SECYEAR 01750000 * Format results in character string form 01751000 SR R2,R2 R2 = string length 01752000 L R3,SECSAVE+4 R3 -> next available byte 01753000 L R1,SECWKDAY R1 = weekday (0 - 6) 01754000 MH R1,=H'3' Convert to table offset 01755000 LA R1,DAYLIST(R1) R1 -> weekday 01756000 MVC 0(3,R3),0(R1) Copy weekday 01757000 MVC 3(2,R3),=C', ' Append separator 01758000 L R1,SECMONTH R1 = month (1 - 12) 01759000 BCTR R1,0 Convert to table offset 01760000 MH R1,=H'3' 01761000 LA R1,MONLIST(R1) R1 -> month 01762000 MVC 5(3,R3),0(R1) Copy month 01763000 MVI 8(R3),C' ' Append separator 01764000 LA R2,9(R2) Increment length 01765000 LA R3,9(R3) Increment pointer 01766000 L R0,SECDAY R0 = day of the month 01767000 LR R1,R3 R1 -> buffer 01768000 BAL R14,NUMTOSTR Store string in buffer 01769000 AR R2,R0 Increment length 01770000 AR R3,R0 Increment pointer 01771000 MVC 0(2,R3),=C', ' Append separator 01772000 LA R2,2(R2) Increment length 01773000 LA R3,2(R3) Increment pointer 01774000 L R0,SECYEAR R0 = year 01775000 LR R1,R3 R1 -> buffer 01776000 BAL R14,NUMTOSTR Store string in buffer 01777000 AR R2,R0 Increment length 01778000 AR R3,R0 Increment pointer 01779000 MVC 0(2,R3),=C' ' Append separator 01780000 LA R2,2(R2) Increment length 01781000 LA R3,2(R3) Increment pointer 01782000 L R0,SECHRS R0 = hours (0 - 23) 01783000 C R0,=F'12' Morning if < 12 01784000 BL SECAM 01785000 * Else afternoon 01786000 MVC AMPM(2),=C'PM' Store "PM" 01787000 C R0,=F'12' If hours = 12, keep 01788000 BE PMKEEP 01789000 S R0,=F'12' Else subtract 12 01790000 PMKEEP B USEHRS Ready to format hours 01791000 SPACE 01792000 SECAM MVC AMPM(2),=C'AM' Store "AM" 01793000 LTR R0,R0 Use hours if > 0 01794000 BNZ USEHRS 01795000 LA R0,12 Else set hours to 12 01796000 USEHRS LR R1,R3 R1 -> buffer 01797000 BAL R14,NUMTOSTR Store string in buffer 01798000 AR R2,R0 Increment length 01799000 AR R3,R0 Increment pointer 01800000 L R0,SECMIN R0 = minutes 01801000 AH R0,=H'100' Add 100 to use 3 columns 01802000 LR R1,R3 R1 -> buffer 01803000 BAL R14,NUMTOSTR Store string in buffer 01804000 MVI 0(R3),C':' Replace "1" by ":" 01805000 AR R2,R0 Increment length 01806000 AR R3,R0 Increment pointer 01807000 L R0,SECSEC R0 = seconds 01808000 AH R0,=H'100' Add 100 to use 3 columns 01809000 LR R1,R3 R1 -> buffer 01810000 BAL R14,NUMTOSTR Store string in buffer 01811000 MVI 0(R3),C':' Replace "1" by ":" 01812000 AR R2,R0 Increment length 01813000 AR R3,R0 Increment pointer 01814000 MVI 0(R3),C' ' Append separator 01815000 MVC 1(2,R3),AMPM Append AM or PM 01816000 LA R2,3(R2) R2 = final length 01817000 ST R2,SECSAVE Store to return in R0 01818000 NI FLAGS2,255-NOCOMMA Reset comma suppression 01819000 LM R0,R15,SECSAVE Restore registers 01820000 BR R14 Return to caller 01821000 SPACE 01822000 SECSAVE DS 8D Local save area 01823000 SECDAYS DS 1F Elapsed days 01824000 SECHRS DS 1F Elapsed hours 01825000 SECMIN DS 1F Elapsed minutes 01826000 SECSEC DS 1F Elapsed seconds 01827000 SECWKDAY DS 1F Weekday (0 = Fri, 1 = Sat ...) 01828000 SECDAY DS 1F Day of the month 01829000 SECMONTH DS 1F Month 01830000 SECYEAR DS 1F Year 01831000 DAYLIST DC C'FriSatSunMonTueWedThu' 01832000 MONLIST DC C'JanFebMarAprMayJunJulAugSepOctNovDec' 01833000 AMPM DS 2C 01834000 EJECT 01835000 * 01836000 * TYPEHDR - Type description of header information 01837000 * 01838000 TYPEHDR DS 0H 01839000 STM R0,R15,TYPHDSAV Save registers 01840000 L R8,=A(DATABUFF) R8 -> message buffer 01841000 LINEDIT TEXT='File: ''....................''',RENT=NO, X01842000 SUB=(CHAR8A,IFN),DOT=NO,BUFFA=(R8),DISP=NONE 01843000 SR R2,R2 R2 = message length 01844000 IC R2,0(R8) 01845000 LA R3,1(R2,R8) R3 -> next byte 01846000 MVC 0(10,R3),=C' Format: ' Append format info. 01847000 TM FLAGS,MACBIN Check for MacBinary 01848000 BO FMTBIN 01849000 MVC 10(6,R3),=C'BinHex' Else BinHex format 01850000 LA R2,16(R2) Get new length 01851000 B TYPEFMT Ready to type line 01852000 SPACE 01853000 FMTBIN MVC 10(9,R3),=C'MacBinary' MacBinary format 01854000 LA R2,19(R2) Get new length 01855000 TYPEFMT STC R2,0(R8) Store new length 01856000 BAL R14,TYPEDESC Type or stack line 01857000 MVC 1(11,R8),=C'Filename: ''' Generate filename msg. 01858000 MVC 12(63,R8),HDFN append filename 01859000 L R2,FRASCADR translate to EBCDIC 01860000 TR 12(63,R8),0(R2) 01861000 SR R1,R1 Get length of filename 01862000 IC R1,HDFNLEN 01863000 LA R1,12(R1) Add length of message 01864000 STC R1,0(R8) Store length for TYPEDESC 01865000 LA R1,0(R1,R8) R1 -> past filename 01866000 MVI 0(R1),C'''' Append apostrophe 01867000 BAL R14,TYPEDESC Type or stack line 01868000 MVC 1(7,R8),=C'Type: ''' Generate type, 01869000 MVC 8(4,R8),HDFTYP creator message 01870000 TR 8(4,R8),0(R2) Translate to EBCDIC 01871000 MVC 12(13,R8),=C''' Creator: ''' 01872000 MVC 25(4,R8),HDFCREAT 01873000 TR 25(4,R8),0(R2) Translate to EBCDIC 01874000 MVC 29(10,R8),=C''' Flags: ' 01875000 ICM R3,B'1100',HDFLAGS Get flags in msb of R3 01876000 LA R4,FLAGTEXT R4 -> list of names 01877000 LA R5,16 R5 = bit count 01878000 LA R6,39 R6 = buffer offset 01879000 FLGLOOP EQU * Loop to set flag names 01880000 SR R2,R2 Get next bit in R2 01881000 SLDL R2,1 01882000 LTR R2,R2 Is bit set? 01883000 BZ FLGNEXT No, skip name 01884000 C R6,=F'39' First name? 01885000 BE SKIPPLUS Yes, skip "+" 01886000 IC R7,=C'+' Else append "+" 01887000 STC R7,0(R6,R8) 01888000 LA R6,1(R6) 01889000 SKIPPLUS LA R7,0(R6,R8) R7 -> where to put text 01890000 MVC 0(4,R7),0(R4) Copy flag name 01891000 LA R6,4(R6) 01892000 FLGNEXT LA R4,4(R4) R4 -> next name 01893000 BCT R5,FLGLOOP 01894000 C R6,=F'39' Any flags? 01895000 BNE HAVEFLGS Yes, continue 01896000 LA R7,0(R6,R8) Else append "none" 01897000 MVC 0(4,R7),=C'none' 01898000 LA R6,4(R6) 01899000 HAVEFLGS BCTR R6,0 R6 = line length 01900000 STC R6,0(R8) Store for TYPEDESC 01901000 BAL R14,TYPEDESC Type or stack line 01902000 ICM R3,B'1111',HDDATALN Get data fork length 01903000 ICM R4,B'1111',HDRSCLN Get resource fork length 01904000 MVC 1(16,R8),=C'Data fork size: ' Copy start of size 01905000 LA R5,16 R5 = message length 01906000 LA R6,1(R5,R8) R6 -> next byte 01907000 LR R0,R3 R0 = data size 01908000 LR R1,R6 R1 -> buffer 01909000 BAL R14,NUMTOSTR Store number in string form 01910000 AR R5,R0 Update length and address 01911000 AR R6,R0 01912000 MVC 0(22,R6),=C'; Resource fork size: ' Copy rest 01913000 LA R5,22(R5) Update length and address 01914000 LA R6,22(R6) 01915000 LR R0,R4 R0 = resource size 01916000 LR R1,R6 R1 -> buffer 01917000 BAL R14,NUMTOSTR Store number in string form 01918000 AR R5,R0 Update length 01919000 STC R5,0(R8) Store length for TYPEDESC 01920000 BAL R14,TYPEDESC Type or stack line 01921000 TM FLAGS,MACBIN MacBinary file? 01922000 BZ TYPHEND No, all info. typed 01923000 MVC 1(15,R8),=C' Created: ' Start of creation date 01924000 LA R5,15 R5 = message length 01925000 LA R1,1(R5,R8) R1 -> next byte 01926000 ICM R0,B'1111',HDCRDATE R0 = creation date 01927000 BAL R14,SEC2DATE Store date in character form 01928000 AR R5,R0 Update length 01929000 STC R5,0(R8) Store length for TYPEDESC 01930000 BAL R14,TYPEDESC Type or stack line 01931000 MVC 1(15,R8),=C'Last Modified: ' Start of last mod date 01932000 LA R5,15 R5 = message length 01933000 LA R1,1(R5,R8) R1 -> next byte 01934000 ICM R0,B'1111',HDMDDATE R0 = creation date 01935000 BAL R14,SEC2DATE Store date in character form 01936000 AR R5,R0 Update length 01937000 STC R5,0(R8) Store length for TYPEDESC 01938000 BAL R14,TYPEDESC Type or stack line 01939000 TYPHEND LA R1,=CL8'CONWAIT' Call CONWAIT to wait for 01940000 SVC 202 output to finish 01941000 DC AL4(1) (following code can take a while) 01942000 LM R0,R15,TYPHDSAV Restore registers 01943000 BR R14 Return to caller 01944000 SPACE 01945000 TYPHDSAV DS 8D Local save area 01946000 EJECT 01947000 * 01948000 * TYPEDESC - Type a description line or stack the line (depending 01949000 * on the options the user has specified). The first byte 01950000 * of DATABUFF contains the line length, and is followed 01951000 * by the text. 01952000 * 01953000 TYPEDESC DS 0H 01954000 STM R0,R15,TYPSAVE Save registers 01955000 L R2,=A(DATABUFF) R2 -> string length byte 01956000 SR R1,R1 Get length in R1 01957000 IC R1,0(R2) 01958000 TM FLAGS,STKDESC Stacking requested? 01959000 BO DOSTACK Yes, go do it 01960000 STH R1,TYPLEN Store length for typing 01961000 LA R1,TYPLIST R1 -> TYPLIN plist 01962000 SVC 202 Type the line 01963000 DC AL4(1) Ignore errors 01964000 B TYPRTN Return 01965000 SPACE 01966000 DOSTACK MVI STKORDR,C'F' Set FIFO default order 01967000 TM FLAGS,STKLIFO LIFO wanted? 01968000 BZ KEEPFIFO No, keep FIFO 01969000 MVI STKORDR,C'L' Else change FIFO to LIFO 01970000 KEEPFIFO STC R1,STKLEN Store length for stacking 01971000 LA R1,STKLIST R1 -> ATTN plist 01972000 SVC 202 Stack the line 01973000 DC AL4(1) Ignore errors 01974000 TYPRTN LM R0,R15,TYPSAVE Restore registers 01975000 BR R14 Return to caller 01976000 SPACE 01977000 TYPSAVE DS 8D Local save area 01978000 EJECT 01979000 * 01980000 * VARHDR - Return header information in REXX variables. VARHDR 01981000 * is called instead of TYPEHDR when the STEM option has 01982000 * been specified. 01983000 * 01984000 VARHDR DS 0H 01985000 STM R0,R15,VARSAVE Save registers 01986000 L R8,=A(DATABUFF) R8 -> buffer for values 01987000 L R1,=A(VARTAB) R1 -> FN string data 01988000 MVI 0(R8),8 Store filename length 01989000 MVC 1(8,R8),IFN Copy filename 01990000 BAL R14,SETVAR Define stem.FN 01991000 LA R1,4(R1) R1 -> FT string data 01992000 MVI 0(R8),8 Store filetype length 01993000 MVC 1(8,R8),IFT Copy filetype 01994000 BAL R14,SETVAR Define stem.FT 01995000 LA R1,4(R1) R1 -> FM string data 01996000 MVI 0(R8),2 Store filemode length 01997000 MVC 1(2,R8),IFM Copy filemode 01998000 BAL R14,SETVAR Define stem.FM 01999000 LA R1,4(R1) R1 -> FORMAT string data 02000000 MVI 0(R8),6 Set to BinHex 02001000 MVC 1(6,R8),=C'BinHex' 02002000 TM FLAGS,MACBIN MacBinary? 02003000 BZ USEFMT No, keep format 02004000 MVI 0(R8),9 Set to MacBinary 02005000 MVC 1(9,R8),=C'MacBinary' 02006000 USEFMT BAL R14,SETVAR Define stem.FORMAT 02007000 LA R1,4(R1) R1 -> NAME string data 02008000 MVC 0(1,R8),HDFNLEN Copy length of name 02009000 MVC 1(63,R8),HDFN Copy maximum text 02010000 L R2,FRASCADR Translate to EBCDIC 02011000 TR 1(63,R8),0(R2) 02012000 BAL R14,SETVAR Define stem.NAME 02013000 LA R1,4(R1) R1 -> TYPE string data 02014000 MVI 0(R8),4 Length = 4 02015000 MVC 1(4,R8),HDFTYP Copy type text 02016000 TR 1(4,R8),0(R2) Translate to EBCDIC 02017000 BAL R14,SETVAR Define stem.TYPE 02018000 LA R1,4(R1) R1 -> CREATOR string data 02019000 MVI 0(R8),4 Length = 4 02020000 MVC 1(4,R8),HDFCREAT Copy type text 02021000 TR 1(4,R8),0(R2) Translate to EBCDIC 02022000 BAL R14,SETVAR Define stem.CREATOR 02023000 LA R1,4(R1) R1 -> FLAGS string data 02024000 ICM R3,B'1100',HDFLAGS Get flags in msb of R3 02025000 LA R4,FLAGTEXT R4 -> list of names 02026000 LA R5,16 R5 = bit count 02027000 LA R6,1 R6 = buffer offset 02028000 FLGLP2 EQU * Loop to set flag names 02029000 SR R2,R2 Get next bit in R2 02030000 SLDL R2,1 02031000 LTR R2,R2 Is bit set? 02032000 BZ FLGNXT2 No, skip name 02033000 C R6,=F'1' First name? 02034000 BE SKIPPL2 Yes, skip "+" 02035000 IC R7,=C'+' Else append "+" 02036000 STC R7,0(R6,R8) 02037000 LA R6,1(R6) 02038000 SKIPPL2 LA R7,0(R6,R8) R7 -> where to put text 02039000 MVC 0(4,R7),0(R4) Copy flag name 02040000 LA R6,4(R6) 02041000 FLGNXT2 LA R4,4(R4) R4 -> next name 02042000 BCT R5,FLGLP2 02043000 C R6,=F'1' Any flags? 02044000 BNE HAVEFLG2 Yes, continue 02045000 LA R7,0(R6,R8) Else append "none" 02046000 MVC 0(4,R7),=C'none' 02047000 LA R6,4(R6) 02048000 HAVEFLG2 BCTR R6,0 R6 = line length 02049000 STC R6,0(R8) Store for SETVAR 02050000 BAL R14,SETVAR Define stem.FLAGS 02051000 LA R1,4(R1) R1 -> DATASIZE string data 02052000 LR R2,R1 Save R1 across NUMTOSTR 02053000 ICM R0,B'1111',HDDATALN R0 = size of data fork 02054000 LA R1,1(R8) R1 -> buffer for number 02055000 BAL R14,NUMTOSTR Convert to string 02056000 STC R0,0(R8) Store string length 02057000 LR R1,R2 Restore R1 for SETVAR 02058000 BAL R14,SETVAR Define stem.DATASIZE 02059000 LA R1,4(R1) R1 -> RESCSIZE string data 02060000 LR R2,R1 Save R1 across NUMTOSTR 02061000 ICM R0,B'1111',HDRSCLN R0 = size of resource fork 02062000 LA R1,1(R8) R1 -> buffer for number 02063000 BAL R14,NUMTOSTR Convert to string 02064000 STC R0,0(R8) Store string length 02065000 LR R1,R2 Restore R1 for SETVAR 02066000 BAL R14,SETVAR Define stem.RESCSIZE 02067000 TM FLAGS,MACBIN MacBinary file? 02068000 BZ VARRTN No, all info. defined 02069000 LA R1,4(R1) R1 -> CRDATE string data 02070000 LR R2,R1 Save R1 across SEC2DATE 02071000 ICM R0,B'1111',HDCRDATE R0 = creation date 02072000 LA R1,1(R8) R1 -> buffer for number 02073000 BAL R14,SEC2DATE Convert to string 02074000 STC R0,0(R8) Store string length 02075000 LR R1,R2 Restore R1 for SETVAR 02076000 BAL R14,SETVAR Define stem.CRDATE 02077000 LA R1,4(R1) R1 -> MDDATE string data 02078000 LR R2,R1 Save R1 across SEC2DATE 02079000 ICM R0,B'1111',HDMDDATE R0 = last modified date 02080000 LA R1,1(R8) R1 -> buffer for number 02081000 BAL R14,SEC2DATE Convert to string 02082000 STC R0,0(R8) Store string length 02083000 LR R1,R2 Restore R1 for SETVAR 02084000 BAL R14,SETVAR Define stem.MDDATE 02085000 VARRTN LM R0,R15,VARSAVE Restore registers 02086000 BR R14 Return to caller 02087000 SPACE 02088000 VARSAVE DS 8D Local save area 02089000 EJECT 02090000 * 02091000 * SETVAR - Define REXX variable to a given value. The variable 02092000 * to be defined will be stemname.suffix, where "stemname" 02093000 * was specified in the "STEM" option, and R1 contains the 02094000 * address of a pointer to the length and text of "suffix". 02095000 * The length and text of the variable's value is found in 02096000 * DATABUFF. 02097000 * 02098000 SETVAR DS 0H 02099000 STM R0,R15,SETSAVE Save registers 02100000 MVC NAMEBUFF(8),STEMNAME Copy stem name 02101000 L R3,STEMSIZE R3 = length of name 02102000 LA R2,NAMEBUFF(R3) R2 -> next available byte 02103000 MVI 0(R2),C'.' Append period 02104000 LA R2,1(R2) Increment pointer 02105000 LA R3,1(R3) Increment size 02106000 L R1,0(R1) R1 -> length, text for suffix 02107000 SR R5,R5 R5 = length 02108000 IC R5,0(R1) 02109000 LA R4,1(R1) R4 -> text 02110000 BCTR R5,0 Decrement length for EX 02111000 EX R5,NAMEMVC 02112000 LA R3,1(R3,R5) R3 = length of variable name 02113000 LA R2,NAMEBUFF R2 -> value of name 02114000 L R1,=A(DATABUFF) R1 -> length, text of value 02115000 SR R5,R5 R5 = length of value 02116000 IC R5,0(R1) 02117000 LA R4,1(R1) R4 -> value for variable 02118000 LA R6,MYSHBLK Address shared variable block 02119000 USING SHVBLOCK,R6 02120000 XC SHVBLOCK(SHVBLEN),SHVBLOCK Initialize to zeros 02121000 MVI SHVCODE,C'S' Store code to set a variable 02122000 STM R2,R5,SHVNAMA Store name and value info. 02123000 XC EXTPLIST(16),EXTPLIST Initialize extended plist 02124000 DROP R6 Done with shared variable block 02125000 LA R1,=CL8'EXECCOMM' R1 -> function name 02126000 ST R1,EXTPLIST Store in extended plist 02127000 ICM R1,B'1000',=X'02' Indicate subcommand call 02128000 ST R6,EXTPLIST+12 Store A(shared variable block) 02129000 LA R0,EXTPLIST R0 -> extended plist 02130000 SVC 202 Invoke EXECCOMM to set variable 02131000 DC AL4(1) Ignore errors 02132000 LTR R15,R15 Check return code 02133000 BZ SETRTN Ok if zero 02134000 C R15,=F'-3' Check for environment error 02135000 BE BADENV 02136000 LR R2,R15 Save RC 02137000 DMSERR NUM=632,LET=E, X02138000 TEXT='Error setting EXEC variable: RC=..... from ''EXECCX02139000 OMM'' function',SUB=(DEC,(R2)) 02140000 MVI RTNCODE+3,200 Set RC = 200 02141000 B CMSRTN Return to CMS 02142000 SPACE 02143000 BADENV DMSERR NUM=631,LET=E, X02144000 TEXT='''STEM'' option is only available from an EXEC2 orX02145000 REXX exec' 02146000 MVI RTNCODE+3,4 Set RC = 4 02147000 B CMSRTN Return to CMS 02148000 SPACE 02149000 SETRTN LM R0,R15,SETSAVE Restore register 02150000 BR R14 Return to caller 02151000 SPACE 02152000 SETSAVE DS 8D Local save area 02153000 NAMEBUFF DS 3D Variable name constructed here 02154000 MYSHBLK DS 4D Shared variable block 02155000 EXTPLIST DS 4F Extended plist for EXECCOMM 02156000 NAMEMVC MVC 0(*-*,R2),0(R4) Append suffix after stem 02157000 EJECT 02158000 * 02159000 * BINHEX Data Area: 02160000 * 02161000 SPACE 02162000 NODEID DS 1D Local node id 02163000 BROWNID DC CL8'BROWNVM' Brown node id 02164000 INPLIST DS 0D Input file all-purpose plist 02165000 INCMMD DS CL8 command name (ignored for BALR) 02166000 IFN DS CL8 filename 02167000 IFT DS CL8 filetype 02168000 IFM DS CL2 filemode 02169000 RDUN1 DS H unused 02170000 RDADDR DS A statefst addr.; rdbuf buffer 02171000 RDBUFLTH DS F size of rdbuf buffer 02172000 RDFV DS C recfm (F or V) 02173000 RDFLAG DS X plist flag 02174000 RDUN2 DS H unused 02175000 RDLGTH DS A no. of bytes read (filled-in) 02176000 RDITEM DS A extended item number 02177000 RDITEC DS A extended number of items 02178000 RDWP DS A write pointer 02179000 RDRP DS A read pointer 02180000 SPACE 02181000 OUTPLIST DS 0D Output file all-purpose plist 02182000 OUTCMMD DS CL8 command name (ignored for BALR) 02183000 OFN DS CL8 filename 02184000 OFT DS CL8 filetype 02185000 OFM DS CL2 filemode 02186000 WRUN1 DS H unused 02187000 WRADDR DS A statefst addr.; wrbuf buffer 02188000 WRBUFLTH DS F size of wrbuf buffer 02189000 WRFV DS C recfm (F or V) 02190000 WRFLAG DS X plist flag 02191000 WRUN2 DS H unused 02192000 WRUN3 DS A unused 02193000 WRITEM DS A extended item number 02194000 WRITEC DS A extended number of items 02195000 WRWP DS A write pointer 02196000 WRRP DS A read pointer 02197000 SPACE 02198000 DS 0D TYPLIN Plist to type description 02199000 TYPLIST DC CL8'TYPLIN' command name for SVC 202 02200000 DC AL1(1) obsolete terminal number 02201000 DC AL3(DATABUFF+1) string address 02202000 DC C'B' color (Black) 02203000 DC AL1(0) flag byte 02204000 TYPLEN DC AL2(*-*) string length 02205000 SPACE 02206000 DS 0D ATTN Plist to stack description 02207000 STKLIST DC CL8'ATTN' command name for SVC 202 02208000 STKORDR DC CL4'FIFO' LIFO or FIFO 02209000 STKLEN DC AL1(*-*) string length 02210000 DC AL3(DATABUFF+1) string length 02211000 SPACE 02212000 STEMNAME DS 1D Stem variable names 02213000 HDREC DS 16D File header info. (128 bytes) 02214000 ORG HDREC Define header fields 02215000 HDVER DS 1X version byte 02216000 HDFNLEN DS 1X length of filename 02217000 HDFN DS 63C filename 02218000 * start of Finder Info record 02219000 HDFTYP DS 4C file type 02220000 HDFCREAT DS 4C file creator 02221000 HDFLAGS DS 1X finder flags 02222000 HDFLAG2 DS 1X second flag byte 02223000 HDVPOS DS 2X vertical position 02224000 HDHPOS DS 2X horizontal position 02225000 HDID DS 2X window or folder ID 02226000 * end of Finder Info record 02227000 HDPFLAG DS 1X "protected" flag 02228000 HDZERO2 DS 1X zero 02229000 HDDATALN DS 4X data fork length 02230000 HDRSCLN DS 4X resource fork length 02231000 HDCRDATE DS 4X creation date 02232000 HDMDDATE DS 4X last modified date 02233000 HDZERO3 DS 29X zero fill 02234000 ORG 02235000 BINLEN DS 1F Length of data in BINBUFF 02236000 BINXTADR DS 1A Addr. for processing left over bits 02237000 BINOFF DS 1F Offset into BINBUFF for GETSTR 02238000 RDOFF DS 1F Offset into READBUFF for GTBINLIN 02239000 EOFPOS DS 1F Position of EOFCHAR in current line 02240000 CHRTOTAL DS 1F Total char. read by GETLINE 02241000 CPS DS 1F Xfer rate chars./sec. or zero 02242000 EXPLEN DS 1F No. of bytes in EXPBUFF 02243000 WRLEN DS 1F HQX output line length 02244000 STEMSIZE DS 1F Length of STEMNAME 02245000 FRASCADR DS A A(ASCII to EBCDIC table) 02246000 TOASCADR DS A A(EBCDIC to ASCII table) 02247000 OPRTAB DS 0F Operand processing table 02248000 DC CL8'?',AL4(QUESOPR) 02249000 DC CL8'CHECK',AL4(CHKOPR) 02250000 DC CL8'CONVERT',AL4(CVTOPR) 02251000 DC CL8'DESCRIBE',AL4(DESCOPR) 02252000 DC 8X'FF',AL4(-1) 02253000 OPTTAB DS 0F Option processing table 02254000 DC CL8'FIFO',AL4(STKOPT) 02255000 DC CL8'LIFO',AL4(LIFOOPT) 02256000 DC CL8'RATE',AL4(RATEOPT) 02257000 DC CL8'STACK',AL4(STKOPT) 02258000 DC CL8'STEM',AL4(STEMOPT) 02259000 DC CL8'TO',AL4(TOOPT) 02260000 DC 8X'FF',AL4(-1) 02261000 CRCVAL DS 1H Calculated CRC 02262000 CMPLBYTE DS 1X Last byte for compression 02263000 CMPCNT DS 1X Compression count 02264000 CMPCHAR DS 1C Character for compression 02265000 BINLAST DS 1X Last character in BINBUFF 02266000 BINEXTRA DS 1X Left over binary data 02267000 OPRCODE DS 1C Code for first operand 02268000 EOFCHAR DS 1C Invalid char. GETLINE stopped at 02269000 CMPMODE DS 1X Current state for HQX compression 02270000 HCMPCHAR DS 1C Last character for HQX compression 02271000 CMPCOUNT DS 1X Character count for HQX comp. 02272000 FLAGS DS 1X Flag byte 02273000 MACBIN EQU X'01' Input file is MacBinary 02274000 RDOPEN EQU X'02' Input file is open 02275000 WROPEN EQU X'04' Output file is open 02276000 HQXCOLON EQU X'08' Found first colon for HQX file 02277000 HQXEOF EQU X'10' Found eof colon for HQX file 02278000 X90DATA EQU X'20' Use data byte from last X'90' 02279000 STKDESC EQU X'40' Stack description output 02280000 STKLIFO EQU X'80' Stack output LIFO 02281000 FLAGS2 DS 1X Second flag byte 02282000 EXECVAR EQU X'01' Return header info in vars. 02283000 NOCOMMA EQU X'02' Suppress commas for NUMTOSTR 02284000 FLAGTEXT DC C'LockInvsBndlSystBozoBusyChngInit' 02285000 DC C'CachShrdSwitNoSwRsv3Rsv2OwnADesk' 02286000 LTORG 02287000 DROP R11,R12,R13 02288000 EJECT 02289000 TOASCBRN DS 0D BROWN'S CP EBCDIC TO ASCII TRANSLATE TABLE 02290000 DC X'000102037F097F7F7F7F7F0B0C0D0E0F' *....".""""".....* 02291000 DC X'101112137F0A087F18197F7F1C1D1E1F' *....".."..""....* 02292000 DC X'7F7F1C7F7F0A171B7F7F7F7F7F050607' *"".""..."""""...* 02293000 DC X'7F7F167F7F1E7F047F7F7F1314157F1A' *"".""."."""...".* 02294000 DC X'207F7F7F7F7F7F7F7F7F5B2E3C282B5E' *."""""""""$....;* 02295000 DC X'267F7F7F7F7F7F7F7F7F21242A293B7E' *.""""""""".....=* 02296000 DC X'2D2F7F7F7F7F7F7F7F7F7C2C255F3E3F' *..""""""""@..^..* 02297000 DC X'7F7F7F7F7F7F7F7F607F3A2340273D22' *""""""""-".. ...* 02298000 DC X'7F6162636465666768697F7B7F7F7F7F' *"/........"#""""* 02299000 DC X'7F6A6B6C6D6E6F7071727F7D7F7F7F7F' *".,%_>?..."'""""* 02300000 DC X'7F7F737475767778797A7F7F7F5B7F7F' *"".......:"""$""* 02301000 DC X'7F7F7F7F7F7F7F7F7F7F7F7F7F5D7F7F' *""""""""""""")""* 02302000 DC X'7F4142434445464748497F7F7F7F7F7F' *".........""""""* 02303000 DC X'7F4A4B4C4D4E4F5051527F7F7F7F7F7F' *"..<(+|&..""""""* 02304000 DC X'5C7F535455565758595A7F7F7F7F7F7F' **".......!""""""* 02305000 DC X'303132333435363738397F7F7F7F7F7F' *..........""""""* 02306000 SPACE 02307000 FRASCBRN DS 0D BROWN'S CP ASCII TO EBCDIC TRANSLATE TABLE 02308000 DC X'00010203372D2E2F1605250B0C0D0E0F' 02309000 DC X'FF11123B3C3D322618193F271C1D1E1F' 02310000 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 02311000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 02312000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 02313000 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD4F6D' 02314000 DC X'78818283848586878889919293949596' 02315000 DC X'979899A2A3A4A5A6A7A8A98B6A9B5F07' 02316000 DC X'00010203372D2E2F1605250B0C0D0E0F' 02317000 DC X'FF11123B3C3D322618193F271C1D1E1F' 02318000 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 02319000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 02320000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 02321000 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD4F6D' 02322000 DC X'78818283848586878889919293949596' 02323000 DC X'979899A2A3A4A5A6A7A8A98B6A9B5F07' 02324000 EJECT 02325000 TOASCSTD DS 0D STANDARD CP EBCDIC TO ASCII TABLE 02326000 DC X'000102037F097F7F7F7F7F0B0C0D0E0F' *....".""""".....* 02327000 DC X'101112137F0A080018197F7F1C1D1E1F' *....".....""....* 02328000 DC X'7F7F7F7F7F0A171B7F7F7F7F7F050607' *"""""..."""""...* 02329000 DC X'7F7F167F7F7F7F047F7F7F7F14157F1A' *""."""".""""..".* 02330000 DC X'207F7F7F7F7F7F7F7F7F7F2E3C282B7C' *.""""""""""....@* 02331000 DC X'267F7F7F7F7F7F7F7F7F21242A293B5E' *.""""""""".....;* 02332000 DC X'2D2F7F7F7F7F7F7F7F7F7C2C255F3E3F' *..""""""""@..^..* 02333000 DC X'7F7F7F7F7F7F7F7F7F603A2340273D22' *"""""""""-.....* 02334000 DC X'7F6162636465666768697F7F7F7F7F7F' *"/........""""""* 02335000 DC X'7F6A6B6C6D6E6F7071727F7F7F7F7F7F' *".,%_>?...""""""* 02336000 DC X'7F7E737475767778797A7F7F7F5B7F7F' *"=.......:"""$""* 02337000 DC X'7F7F7F7F7F7F7F7F7F7F7F7F7F5D7F7F' *""""""""""""")""* 02338000 DC X'7B4142434445464748497F7F7F7F7F7F' *#.........""""""* 02339000 DC X'7D4A4B4C4D4E4F5051527F7F7F7F7F7F' *'�.<(+|&..""""""* 02340000 DC X'5C7F535455565758595A7F7F7F7F7F7F' **".......!""""""* 02341000 DC X'303132333435363738397F7F7F7F7F7F' *..........""""""* 02342000 SPACE 02343000 FRASCSTD DS 0D STANDARD CP ASCII TO EBCDIC TABLE 02344000 DC X'00010203372D2E2F1605250B0C0D0E0F' 02345000 DC X'101112133C3D322618193F271C1D1E1F' 02346000 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 02347000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 02348000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 02349000 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 02350000 DC X'79818283848586878889919293949596' 02351000 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 02352000 DC X'00010203372D2E2F1605250B0C0D0E0F' 02353000 DC X'101112133C3D322618193F271C1D1E1F' 02354000 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 02355000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 02356000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 02357000 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 02358000 DC X'79818283848586878889919293949596' 02359000 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 02360000 EJECT 02361000 VALIDTAB DS 256X TRT table for valid characters 02362000 * (Filled-in at initialization) 02363000 CMPTAB DC 256X'00' TRT table for X'90' 02364000 ORG CMPTAB+X'90' 02365000 DC X'FF' 02366000 ORG 02367000 SPACE 02368000 ASCTOBIN DS 0D 02369000 DC 128X'FF' 02370000 ORG ASCTOBIN+X'21' 02371000 DC X'00010203040506070809' ! " # $ % & ' ( ) * 02372000 DC X'0A0B0C' + , - 02373000 ORG ASCTOBIN+X'30' 02374000 DC X'0D0E0F10111213' 0 1 2 3 4 5 6 02375000 ORG ASCTOBIN+X'38' 02376000 DC X'1415' 8 9 02377000 ORG ASCTOBIN+X'40' 02378000 DC X'161718191A1B1C1D1E1F' @ A B C D E F G H I 02379000 DC X'2021222324' J K L M N 02380000 ORG ASCTOBIN+X'50' 02381000 DC X'25262728292A2B' P Q R S T U V 02382000 ORG ASCTOBIN+X'58' 02383000 DC X'2C2D2E2F' X Y Z [ 02384000 ORG ASCTOBIN+X'60' 02385000 DC X'30313233343536' ` a b c d e f 02386000 ORG ASCTOBIN+X'68' 02387000 DC X'3738393A3B3C' h i j k l m 02388000 ORG ASCTOBIN+X'70' 02389000 DC X'3D3E3F' p q r 02390000 ORG 02391000 * ! " # $ % & ' ( ) * + , - 0 1 2 3 4 5 6 8 9 @ 02392000 BINTOASC DC X'2122232425262728292A2B2C2D30313233343536383940' 02393000 * A B C D E F G H I J K L M N P Q R S T U V X Y 02394000 DC X'4142434445464748494A4B4C4D4E505152535455565859' 02395000 * Z [ ` a b c d e f h i j k l m p q r 02396000 DC X'5A5B6061626364656668696A6B6C6D707172' 02397000 HQXMSG DC C'(This file must be converted with BinHex 4.0)' 02398000 HQXMSGL EQU *-HQXMSG 02399000 SPACE 02400000 VARTAB DS 0A Address table for REXX var. names 02401000 DC A(VAR1) 02402000 DC A(VAR2) 02403000 DC A(VAR3) 02404000 DC A(VAR4) 02405000 DC A(VAR5) 02406000 DC A(VAR6) 02407000 DC A(VAR7) 02408000 DC A(VAR8) 02409000 DC A(VAR9) 02410000 DC A(VAR10) 02411000 DC A(VAR11) 02412000 DC A(VAR12) 02413000 AVAR13 DC A(VAR13) 02414000 AVAR14 DC A(VAR14) 02415000 VAR1 DC AL1(VAR1L),C'FN' CMS filename 02416000 VAR1L EQU *-VAR1-1 02417000 VAR2 DC AL1(VAR2L),C'FT' CMS filetype 02418000 VAR2L EQU *-VAR2-1 02419000 VAR3 DC AL1(VAR3L),C'FM' CMS filemode 02420000 VAR3L EQU *-VAR3-1 02421000 VAR4 DC AL1(VAR4L),C'FORMAT' MacBinary or BinHex 02422000 VAR4L EQU *-VAR4-1 02423000 VAR5 DC AL1(VAR5L),C'NAME' Mac filename 02424000 VAR5L EQU *-VAR5-1 02425000 VAR6 DC AL1(VAR6L),C'TYPE' Mac type 02426000 VAR6L EQU *-VAR6-1 02427000 VAR7 DC AL1(VAR7L),C'CREATOR' Mac creator 02428000 VAR7L EQU *-VAR7-1 02429000 VAR8 DC AL1(VAR8L),C'FLAGS' Mac flags 02430000 VAR8L EQU *-VAR8-1 02431000 VAR9 DC AL1(VAR9L),C'DATASIZE' Mac data fork size 02432000 VAR9L EQU *-VAR9-1 02433000 VAR10 DC AL1(VAR10L),C'RESCSIZE' Mac resource fork size 02434000 VAR10L EQU *-VAR10-1 02435000 VAR11 DC AL1(VAR11L),C'CRDATE' Mac creation date 02436000 VAR11L EQU *-VAR11-1 02437000 VAR12 DC AL1(VAR12L),C'MDDATE' Mac last modified date 02438000 VAR12L EQU *-VAR12-1 02439000 VAR13 DC AL1(VAR13L),C'CHARCNT' Total character count 02440000 VAR13L EQU *-VAR13-1 02441000 VAR14 DC AL1(VAR14L),C'TIMEEST' Dowload time estimate 02442000 VAR14L EQU *-VAR14-1 02443000 SPACE 02444000 EXPBUFF DS 6D 48-byte HQX expansion buffer 02445000 WRITBUFF DS 8D 64-byte disk output buffer 02446000 DATABUFF DS 16D 128-byte work buffer 02447000 BINBUFF DS 25D Binary from READBUFF 02448000 READBUFF DS 32D 256-byte disk input buffer 02449000 ADT 02450000 FSTB 02451000 FVS 02452000 NUCON 02453000 SHVBLOCK 02454000 END 02455000