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.BROWN.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 <ft <fm>> <( 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 <ft <fm>X00166000
               > <( options <)>>'                                       00167000
         WRTERM '  Options: <To fm> <Rate cps> <Stack> <Lifo> <Fifo> <SX00168000
               TEm stemname>'                                           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
