Columbia Kermit/kermit.zip/honeywellcp6a/hc6ker.pl6

Text File | 2020-01-01 | 173KB | 5,338 lines

/*

Program:  Lee Hallin (Honeywell Bull, Los Angeles Development Center) with
          testing and suggestions from J. T. Anderson (Honeywell Bull, Los
          Angeles Developement Center), and Mike Iglesias and others
          (University California at Irvine).

          Many thanks to John Stewart of Carleton University, Tom
          Erskine of CRC, Mike Iglesias of UC Irvine and Mike Schmidt
          of Honeywell Bull, Canada, for their help and supplied code
          for version 1.00.
Language: PL-6
Version:  1.00
Date:     January, 1988

Please send any questions, bugs and/or suggestions to any of the following:

U.S. Mail:
  Honeywell Bull
  5250 West Century Blvd
  Los Angeles, CA  90045
  Attn: Lee Hallin

CP-6 Mail on the LADC support machine (aka L66A):
  Lee Hallin

ARPANET Address:
  [e-mail]


13.1  Introduction

This version of Kermit is written in PL-6; a PL/1-like implementation language
available on the Honeywell CP-6 operating system.  This Kermit contains all of
the "basic" Kermit features and several optional/advanced features.  Some of
the optional features are suggested in the Kermit User's Guide and/or Kermit
Protocol Manual, while others where implemented to provide added flexibility
on CP-6.  The following table briefly summarizes the capabilities of this
version of Kermit.

Features this Kermit has or can do:
  Transfers text files
  Transfers binary files
  Sends file groups (wildcarding)
  File overwrite protection
  Timeouts
  8th-bit prefixing
  Repeat count prefixing
  Transaction logging
  Debugging facility
  Acts as a server
  Talks to a server (limited)
  Automatically reads default commands from a file
  Read commands from a file
  Help for each of the commands
  Graceful handling of interrupted group transfers

Features not included in this version:
  Advanced server commands
  Extended block checks (2 and 3 byte checks)
  Handling file attributes

*/
%EJECT;
/*
          The following changes were made to this version of KERMIT
          to support file transfers through a comgroup rather than
          the regular terminal mode.

          1. This version is minimum CP-6 C01, so the dcbs used with
             M$EOM (TIMEOUT), M$TRMCTL (ORIG_TRMCTL, STRMCTL) and
             M$TRMATTR (GTRMATTR) were changed from M$UC to F$PACKET_IN.

          2. Commands were added to the parse code to add two new options:
             CG= comgroup_name, and STATION= station_name. Both these
             options must be specified for the comgroup stuff to work.
             This implies changes to three files: HC6KERMIT_PAR, the
             partrge source file, HC6KERMIT_C61, the include file for both
             partrge and PL6, and this source file.

          3. A bunch of code was added to support comgroup output, and,
             although this required usually minimal changes to the code,
             the way timeouts were handled had to modified slightly, since
             comgroup reads only start to count the timeout after the first
             character has been received. In this case, timeouts had to
             be set both via M$EOM and also by EOFTIME.

          4. Code has to be added to give some feedback during comgroup
             based transfers, but this hasn't been done yet.

          5. In order to support some communication with other programs,
             some code was added to set the stepcc. This code is really
             only useful if the KERMIT invocation only transfers one file.
             The stepcc only reflects the last 'send' command (and the
             last file sent if there was more than one). It sets the stepcc
             as follows:

                  0: The last file sent made it fine (if there was any
                     request).
                  2: The last file started but didn't complete.
                  3: The last file couldn't be found.

             The stepcc can't be guaranteed to be accurate if a wild-
             carded send command was used.



Bug fixes:

             Fixed bug in Receive_Pack where inter-packet characters
             were being considered as a nak; which caused Kermit to
             go into convulsions, trying to get things straightened
             out.

             Fixed bug in server mode: Packet numbers weren't being
             reset after a Break or Abort in Receive mode.

             The generic commands Finish and Bye were responding with
             the current seq number, instead of 0.

             The Bye command tries to do a bye on the local end, when
             it's specified that it just does that to the remote end.

             Neither the Finish nor the Bye command go through the
             parameter exchange, although there is no guarantee that
             they aren't the first command ever issued. Oops, I've taken
             this back out temporarily because it's not working too well.

             The Bye command (when received by the server) doesn't close
             the dcbs and exit gracefully, it simply does a !BYE.
             Of course, if you're debugging OVER a debug file, it doesn't
             get closed properly, so no debugging info...
             Fixed by closing F$DEBUG and M$LO before executing !BYE.
*/
%EJECT;

KERMIT: PROC MAIN;

%EQU OS_VERSION = 'D00';                 /* This is B03, C00, C01, D00 or E00 */
%INCLUDE B_ERRORS_C;
%INCLUDE B$JIT;
%INCLUDE CP_6;
  %B$ALT;
  %B$TCB;
  %F$DCB;
%INCLUDE CP_6_SUBS;
/* CLUDE KERMIT_C61; */
%INCLUDE KV_GLBCNS_E;
  %KV_PRTTYP_E;                               /* PARITY values                */
%INCLUDE XS_MACRO_C;
  %XSA_PARAM (FPTN=XSA_PARAM);
  %XSA_ENTRIES;
%INCLUDE XU_FORMAT_C;
%INCLUDE XU_MACRO_C;
%INCLUDE XU_PERR_C;
%IF OS_VERSION~='B03';
%INCLUDE XU_SUBS_C;                           /* For NEVER_ECHO#              */
%ENDIF;
%INCLUDE XUH_MACRO_C;
  %XUH_PARAM;
%IF OS_VERSION='B03';
%INCLUDE XU_WILDCARD_C;                       /* In B03 this is in .X         */
%ELSE;
%INCLUDE XUW_MACRO_C;                         /* In C00 this is in .:LIBRARY  */
%ENDIF;
%EJECT;
%LIST;
%INCLUDE HC6KERMIT_C61;
%PLIST;
%EJECT;
/**/
/* EQUs used to access the PCB */
/**/

%EQU BLK1_NSUBLKS = %CHARTEXT('BLK1$->P_OUT.NSUBLKS');
%EQU BLK1_SUBLK$  = %CHARTEXT('BLK1$->P_OUT.SUBLK$');

%EQU BLK2_NSUBLKS = %CHARTEXT('BLK2$->P_OUT.NSUBLKS');
%EQU BLK2_SUBLK$  = %CHARTEXT('BLK2$->P_OUT.SUBLK$');
%EQU BLK2_CODE    = %CHARTEXT('BLK2$->P_SYM.CODE');
%EQU BLK2_COUNT   = %CHARTEXT('BLK2$->P_SYM.COUNT');
%EQU BLK2_TEXT    = %CHARTEXT('SUBSTR(BLK2$->P_SYM.TEXT,0,BLK2$->P_SYM.COUNT)');

%EQU BLK3_NSUBLKS = %CHARTEXT('BLK3$->P_OUT.NSUBLKS');
%EQU BLK3_SUBLK$  = %CHARTEXT('BLK3$->P_OUT.SUBLK$');
%EQU BLK3_CODE    = %CHARTEXT('BLK3$->P_SYM.CODE');
%EQU BLK3_CPOS    = %CHARTEXT('BLK3$->P_SYM.CPOS');
%EQU BLK3_COUNT   = %CHARTEXT('BLK3$->P_SYM.COUNT');
%EQU BLK3_TEXT    = %CHARTEXT('SUBSTR(BLK3$->P_SYM.TEXT,0,BLK3$->P_SYM.COUNT)');

%EQU BLK4_NSUBLKS = %CHARTEXT('BLK4$->P_OUT.NSUBLKS');
%EQU BLK4_SUBLK$  = %CHARTEXT('BLK4$->P_OUT.SUBLK$');
%EQU BLK4_CODE    = %CHARTEXT('BLK4$->P_SYM.CODE');
%EQU BLK4_COUNT   = %CHARTEXT('BLK4$->P_SYM.COUNT');
%EQU BLK4_TEXT    = %CHARTEXT('SUBSTR(BLK4$->P_SYM.TEXT,0,BLK4$->P_SYM.COUNT)');

%EQU BLK5_NSUBLKS = %CHARTEXT('BLK5$->P_OUT.NSUBLKS');
%EQU BLK5_SUBLK$  = %CHARTEXT('BLK5$->P_OUT.SUBLK$');
%EQU BLK5_CODE    = %CHARTEXT('BLK5$->P_SYM.CODE');
%EQU BLK5_COUNT   = %CHARTEXT('BLK5$->P_SYM.COUNT');
%EQU BLK5_TEXT    = %CHARTEXT('SUBSTR(BLK5$->P_SYM.TEXT,0,BLK5$->P_SYM.COUNT)');

%EQU MONERR       = %CHARTEXT('B$TCB$->B$TCB.ALT$->B$ALT.ERR');
%EQU ERRDCB       = %CHARTEXT('B$TCB$->B$TCB.ALT$->B$ALT.DCB#');
%EJECT;
/**/
/* KERMIT type and state EQUs */
/**/

%EQU A_ABORT                 = 'A';
%EQU B_BREAK                 = 'B';
%EQU C_COMPLETE              = 'C';
%EQU D_DATA                  = 'D';
%EQU E_ERROR                 = 'E';
%EQU F_FILE                  = 'F';
%EQU G_GENERIC               = 'G';
%EQU I_INIT                  = 'I';
%EQU K_KERMIT                = 'K';
%EQU N_NAK                   = 'N';
%EQU R_RINIT                 = 'R';
%EQU S_SINIT                 = 'S';
%EQU T_RESERVED              = 'T';
%EQU Y_ACK                   = 'Y';
%EQU Z_EOF                   = 'Z';

/**/
/* KERMIT subcommand EQUs */
/**/

%EQU C_CWD                   = 'C';
%EQU D_DIRECTORY             = 'D';
%EQU E_ERASE                 = 'E';
%EQU F_FINISH                = 'F';
%EQU H_HELP                  = 'H';
%EQU I_LOGIN                 = 'I';
%EQU J_JOURNAL               = 'J';
%EQU K_COPY                  = 'K';
%EQU L_BYE                   = 'L';
%EQU M_SHORT_MESSAGE         = 'M';
%EQU P_PROG_INVOCATION       = 'P';
%EQU Q_SERVER_STAT_QUERY     = 'Q';
%EQU R_RENAME                = 'R';
%EQU T_TYPE                  = 'T';
%EQU V_VARIABLE_SET_QUERY    = 'V';
%EQU W_WHOS_LOGGED_IN        = 'W';

%EQU TAB                     = BINASC(9);
%EQU LF                      = BINASC(10);
%EQU CR                      = BINASC(13);
%EQU SUB                     = BINASC(26);
%EQU DEL                     = BINASC(127);

/**/
/* EQUs for LOG file keys (fractional portion of EDIT key) */
/**/

%EQU LOG_HEADER#             = 000;
%EQU LOG_STRT_SEND#          = 101;
%EQU LOG_END_SEND#           = 102;
%EQU LOG_STRT_RECEIVE#       = 103;
%EQU LOG_END_RECEIVE#        = 104;
%EQU LOG_MAX_PACKET_SIZES#   = 200;
%EQU LOG_NUM_DATA_PACKETS#   = 300;
%EQU LOG_NUM_BYTES_SENT#     = 400;
%EQU LOG_NUM_BYTES_RCVD#     = 500;
%EQU LOG_ELAPSED_TIME#       = 600;
%EQU LOG_ERRMSG#             = 700;

/**/
/* Miscellaneous EQUs */
/**/
%EQU MAX_EXTENSIONS#         = 30;

%EQU NOTHING#                = 0;
%EQU BUILD_SEQUENCE#         = 1;
%EQU PUT_CHAR_IN_PACKET#     = 2;
%EQU STUFF_CHAR_IN_PACKET#   = 3;
%EJECT;
/**/
/* Miscellaneous FPTs */
/**/

%FPT_INT     (FPTN                     = BREAK_CNTRL,
              UENTRY=KERMIT$BREAK );

%FPT_EXIT    (FPTN                     = SET_STEPCC,
              STEPCC=OK );

%VLP_ERRCODE (FPTN                     = ERRCODE );

%FPT_WRITE   (FPTN                     = FPT_WRITE,
              DCB=M$LO );

%IF OS_VERSION='B03';
%FPT_YC      (FPTN                     = FPT_YC,
              CMD=CMD_BUF );
%ELSE;
%FPT_YC      (FPTN                     = FPT_YC,
              CMD=CMD_BUF,
              LINK=YES );
%ENDIF;

%FPT_FID     (FPTN                     = FID_IO,
              ACCT=IO_ACCT,
              ASN=MERGE_IN.V.ASN#,
              NAME=TARGET,
              PASS=IO_PASS,
              RES=MERGE_IN.V.RES#,
              SN=IO_SN,
              TEXTFID=SRCE_FID );
%VLP_ACCT    (FPTN                     = IO_ACCT );
%VLP_NAME    (FPTN                     = IO_NAME );
%VLP_PASS    (FPTN                     = IO_PASS );
%VLP_SN      (FPTN                     = IO_SN );

%FPT_FID     (FPTN                     = FID_CG,
              ACCT=CG_ACCT,
              ASN=CG_ASN,
              NAME=CG_NAME,
              PASS=CG_PASS,
              TEXTFID=CG_FID);

%VLP_ACCT    (FPTN                     = CG_ACCT );
%VLP_NAME    (FPTN                     = CG_NAME );
%VLP_PASS    (FPTN                     = CG_PASS );
%VLP_SN      (FPTN                     = CG_SN );

%FPT_OPEN    (FPTN                     = OPEN_CG_OUT,
              DCB=F$PACKET_OUT,
              FUN=UPDATE,
              SHARE=ALL,
              ORG=TERMINAL,
              NAME=CG_NAME,
              ACCT=CG_ACCT,
              PASS=CG_PASS,
              ASN=COMGROUP,
              SETSTA=CG_STATION);

%FPT_OPEN    (FPTN                     = OPEN_CG_IN,
              DCB=F$PACKET_IN,
              FUN=UPDATE,
              SHARE=ALL,
              ORG=TERMINAL,
              NAME=CG_NAME,
              ACCT=CG_ACCT,
              PASS=CG_PASS,
              ASN=COMGROUP,
              SETSTA=CG_STATION);

%VLP_SETSTA  (FPTN                     = CG_STATION);
/*            ILOCK=YES,   */
/*            OLOCK=YES    */

%VLP_STATION (FPTN                     = MY_STATION);

%FPT_OPEN    (FPTN                     = MERGE_IN,
              ACCT=IO_ACCT,
              DCB=F$IN,
              FUN=IN,
              NAME=IO_NAME,
              PASS=IO_PASS,
              SETDCB=YES,
              SN=IO_SN );

%FPT_OPEN    (FPTN                     = OPEN_IO,
              DCB=F$IN );

%FPT_OPEN    (FPTN                     = TEST_OPEN_IO,
              DCB=F$IN );

%FPT_CLOSE   (FPTN                     = FPT_CLOSE,
              DISP=SAVE,
              RELG=YES );

%FPT_TIME    (FPTN                     = GET_UTS,
              DEST=UTS,
              SOURCE=CLOCK,
              TSTAMP=UTS );

%FPT_TIME    (FPTN                     = GET_TIME,
              DEST=LOCAL,
              SOURCE=CLOCK,
              TIME=HHMMSSSS );

%FPT_TIME    (FPTN                     = CONVERT_UTS,
              DATE=MMMDDYY,
              DAY=DAY,
              DEST=EXT,
              SOURCE=UTS,
              TIME=HHMMSSSS,
              TSTAMP=UTS );

%FPT_WAIT    (FPTN                     = FPT_WAIT );

%FPT_READ    (FPTN                     = READ_IN,
           /* BUF=IO_BUF, */
              DCB=F$IN );

%FPT_READ    (FPTN                     = READ_PACKET,
           /* BUF=PACKET, */
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              TRANS=YES );

%FPT_WRITE   (FPTN                     = WRITE_PACKET,
           /* BUF=PACKET, */
              DCB=F$PACKET_OUT,
              STATION = MY_STATION,
              TRANS=YES,
              VFC=NO );

%FPT_EOM     (FPTN                     = TIMEOUT,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              EOMTABLE=VLP_EOMTABLE,
              TIMEOUT=123,
              UTYPE=SEC );
%VLP_EOMTABLE(FPTN                     = VLP_EOMTABLE,
  VALUES="008,044,000,047,000,000,000,000,000,000,000,000,000,000,000,000");
       /*                                                                 */
       /*                                                                 */
       /*      LF     DC2                                                 */
       /*                                                                 */
       /* EOT  FF     DC4                                                 */
       /*      CR     NAK                                                 */
       /*             SYN                                                 */
       /*             ETB                                                 */

%FPT_TRMCTL  (FPTN                     = ORIG_TRMCTL,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              STCLASS="STATIC SYMDEF",
              TRMCTL=VLP_GTRMCTL );
%VLP_TRMCTL  (FPTN                     = VLP_GTRMCTL );

%FPT_TRMCTL  (FPTN                     = STRMCTL,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              TRMCTL=VLP_STRMCTL );
%VLP_TRMCTL  (FPTN                     = VLP_STRMCTL,
              ACTONTRN=YES );

%FPT_TRMATTR (FPTN                     = FPT_GTRMATTR,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              TRMATTR=VLP_GTRMATTR);
%VLP_TRMATTR (FPTN                     = VLP_GTRMATTR );

%FPT_WRITE   (FPTN                     = WRITE_DEBUG,
              DCB=F$DEBUG,
              KEY=DEBUG_KEY );

%FPT_WRITE   (FPTN                     = WRITE_LOG,
              DCB=F$LOG,
              KEY=LOG_KEY );

%FPT_WRITE   (FPTN                     = WRITE_OUT,
           /* BUF=IO_BUF, */
              DCB=F$OUT );

%FPT_GDS     (FPTN                     = GDS );
%VLP_VECTOR  (FPTN                     = IO_ );
%VLP_VECTOR  (FPTN                     = PACKET_ );
%VLP_VECTOR  (FPTN                     = DATA_ );

%FPT_ERRMSG  (FPTN                     = FPT_ERRMSG,
              BUF=ERR_BUF,
              INCLCODE=NO,
              CODE=ERRCODE,
              RESULTS=VLR_ERRMSG );
%VLR_ERRMSG  (FPTN                     = VLR_ERRMSG );

%FPT_UNFID   (FPTN                     = FPT_UNFID );

%FPT_OPEN    (FPTN                     = DEFAULT_OPEN );

%FPT_OPEN    (FPTN                     = FPT_OPEN,
              ACCT=A_ACCT,
              NAME=A_NAME,
              PASS=A_PASS,
              SN=A_SN,
              WSN=A_WSN );
%VLP_ACCT    (FPTN                     = A_ACCT );
%VLP_NAME    (FPTN                     = A_NAME );
%VLP_PASS    (FPTN                     = A_PASS );
%VLP_SN      (FPTN                     = A_SN );
%VLP_WSN     (FPTN                     = A_WSN );

%FPT_FID     (FPTN                     = FPT_FID,
              ACCT=A_ACCT,
              ASN=FPT_OPEN.V.ASN#,
              NAME=A_NAME,
              PASS=A_PASS,
              RES=FPT_OPEN.V.RES#,
              SN=A_SN,
              TEXTFID=FID_STRING,
              RESULTS=VLR_FID,
              WSN=A_WSN );
%VLR_FID     (FPTN                     = VLR_FID );

%FPT_READ    (FPTN                     = READ_DEFAULTS,
              BUF=ME_BUF,
              DCB=F$DEFAULTS );

%FPT_PFIL    (FPTN                     = PFIL_EOF,
              BOF=NO );

%FPT_PRECORD (FPTN                     = BACKUP1,
              KEYR=YES,
              N=-1 );

%IF OS_VERSION='B03';
%FPT_TRMATTR (FPTN                     = FPT_TRMATTR,
              DCB=M$UC,
              TRMATTR=VLP_TRMATTR );

%VLP_TRMATTR (FPTN                     = VLP_TRMATTR );
%ENDIF;

%FPT_TRMPRG  (FPTN                     = PURGE_TYPEAHEAD,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              PURGEINPUT=YES );

%FPT_GLINEATTR(FPTN                    = FPT_GLINEATTR,
              DCB=F$PACKET_IN,
              STATION = MY_STATION,
              LINEATTR=VLP_LINEATTR );
%VLP_LINEATTR(FPTN                     = VLP_LINEATTR );
%EJECT;
/**/
/* XUR$GETCMD, X$PARSE,XUF$FORMAT & XUW$WLDCMP stuff */
/**/

%XUR_INIT    (NAME                     = XUR_INIT,
              PCB=P_PCB,
              STCLASS=STATIC );

%F_FDS       (NAME                     = F_FDS,
              BUF=LO_BUF,
              DCB=M$LO,
              STCLASS=STATIC );

%P$PCB       (NAME                     = P_PCB,
              STCLASS=STATIC );

%PARSE$OUT   (NAME                     = P_OUT,
              STCLASS=BASED );

%PARSE$SYM   (NAME                     = P_SYM,
              STCLASS=BASED );

%IF OS_VERSION='B03';
%FPT_WILDCARD(FPTN                     = WILD_COMPARE );
%ELSE;
%XUW_WILDCARD(FPTN                     = WILD_COMPARE );
%ENDIF;

%IF OS_VERSION='B03';
%FPT_WILDCARD(FPTN                     = COMPARE_EXT );
%ELSE;
%XUW_WILDCARD(FPTN                     = COMPARE_EXT );
%ENDIF;
%EJECT;
/**/
/* BASED items, listed alphabetically */
/**/
DCL IO_BUF                   CHAR(IO_BUF_SIZE)  BASED(IO_.PTR$);
DCL IO_BYTE(0:0)             CHAR(1)            BASED(IO_.PTR$);
DCL STRNG                    CHAR(LEN) BASED(P_PCB.TEXT$);

%EJECT;
/**/
/* BIT items, listed alphabetically */
/**/

DCL AT_EOF                   BIT(1);
DCL BINARY_QUOTING           BIT(1);
DCL BIN_MASK                 BIT(9);
DCL CCBUF_CMD                BIT(1);
DCL CG_MODE                  BIT(1);
DCL CG_SPECIFIED             BIT(1);
DCL CHARMASK                 BIT(9);
DCL DEBUG_OPTS(0:35)         BIT(1);
DCL DONE                     BIT(1);
DCL DONE_PARSING             BIT(1);
DCL DONE_SENDING             BIT(1);
DCL GOT_TRMCTL               BIT(1) STATIC INIT(%NO#);
DCL GREETING                 BIT(1);
DCL IM_A_SERVER              BIT(1);
DCL NO_DEFAULTS              BIT(1);
DCL OK_TO_SEND               BIT(1);
DCL PROMPTING                BIT(1);
DCL REPEATING                BIT(1);
DCL SILENT_MODE              BIT(1);
DCL STATION_SPECIFIED        BIT(1);
DCL TRANSFER_INTERRUPTED     BIT(1);
DCL WORDMASK                 BIT(36)   ALIGNED;
%EJECT;
/**/
/* CHARacter items, listed alphabetically */
/**/

DCL CG_FID                   CHAR(80)  STATIC INIT(' ');
DCL CHR                      CHAR(1)   CALIGNED;
DCL  CHR_BIT REDEF CHR       BIT(9)    CALIGNED;
DCL CHR7                     CHAR(1)   CALIGNED;
DCL  CHR7_BIT REDEF CHR7     BIT(9)    CALIGNED;
DCL CMD_BUF                  CHAR(256) STATIC;
DCL 1 LINK_CMD REDEF CMD_BUF,
      2 LEN                  UBIN(9)   CALIGNED,
      2 BUF                  CHAR(255) CALIGNED;
DCL CP6_FID                  CHAR(80);
DCL CUR_CHR                  CHAR(1);
DCL DAY                      CHAR(3)   STATIC;
DCL  DAYU(0:2) REDEF DAY     UBIN(9)   CALIGNED;
DCL DEBUG_LABEL(0:12)        CHAR(4)   STATIC INIT(
  '    ','All ','Cmnd','Erro','Info','Mcro',
         'Off ','On  ','Read','Rcvd','Sent',
         'Timo','Writ');
DCL EOR_BYTE(0:1)            CHAR(1);
DCL EOR_CHARS                CHAR(10)  STATIC INIT('#M#J');
DCL ERR_BUF                  CHAR(120) STATIC INIT('OOPS');
DCL FID_STRING               CHAR(80)  STATIC INIT(' ');
DCL GREETING_MSG             CHAR(0)   STATIC INIT(
    'CP-6 KERMIT 1.00 Here (01/25/88)\');
DCL HEX(0:15)                CHAR(1)   STATIC INIT(
    '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
DCL HHMMSSSS                 CHAR(11)  STATIC;
DCL INT5                     CHAR(5);
DCL LO_BUF                   CHAR(132) STATIC INIT(' ');
DCL LOG_FID                  CHAR(80)  STATIC INIT(
    '*KERMIT_LOG' );
DCL ME_BUF                   CHAR(132) STATIC INIT(' ');
DCL MMMDDYY                  CHAR(10)  STATIC INIT('MMM DD ''YY');
DCL  MMMDDYYU(0:9) REDEF MMMDDYY UBIN(9) CALIGNED;
DCL MODE                     CHAR(7)   STATIC INIT('TEXT');
DCL NO_MEM_FOR_IO_BUF        CHAR(0)   STATIC INIT(
    'CP-6 KERMIT can''t get big enough buffer for READ' );
DCL PACKET_FID               CHAR(80);
DCL PARITY_TBL(0:%KV_PRTTYP_ZERO) CHAR(4) STATIC INIT(
    'NONE','ODD ','EVEN','ONE ','ZERO' );
DCL PREV_CHR                 CHAR(1);
DCL  PREV_CHR_BIT REDEF PREV_CHR BIT(9) CALIGNED;
DCL PREV_CHR7                CHAR(1)   CALIGNED;
DCL  PREV_CHR7_BIT REDEF PREV_CHR7 BIT(9) CALIGNED;
DCL SET_FILE_REPLACEMENT     CHAR(1)   STATIC INIT('_');
DCL SET_FILE_SUBDIRECTORY_CHAR  CHAR(1) STATIC INIT(':');
DCL SPEED(0:15)              CHAR(5)   STATIC INIT(
/*     0       1       2       3       4       5       6       7    */
    '50   ','75   ','110  ','134  ','150  ','200  ','300  ','600  ',
/*     8       9       10      11      12      13      14      15   */
    '1050 ','1200 ','1800 ','2000 ','2400 ','4800 ','9600 ','19200');
DCL SRCE_FID                 CHAR(80)  STATIC INIT(' ');
DCL STATE                    CHAR(1);
DCL STR1                     CHAR(80);
DCL STR2                     CHAR(80);
DCL TYPE                     CHAR(1);
DCL UNIMPLEMENTED_CMD        CHAR(0)   STATIC INIT(
    '.. Unimplemented command.\');
DCL WHAT                     CHAR(80)  STATIC;
%EJECT;
/**/
/* DCBs */
/**/

DCL F$DEFAULTS               DCB;
DCL F$IN                     DCB;
DCL M$LO                     DCB;
DCL M$SI                     DCB;
DCL M$SI2                    DCB;

%M$DCB       (DCBN                     = F$DEBUG,
              ACS=DIRECT,
              ASN=FILE,
              FUN=CREATE,
              NAME='*DEBUG',
              ORG=KEYED );

%M$DCB       (DCBN                     = F$LOG,
              ASN=FILE,
              CTG=YES,
              FUN=CREATE,
              NAME='*KERMIT_LOG',
              ORG=KEYED );

%M$DCB       (DCBN                     = F$OUT,
              ASN=FILE,
              CTG=YES,
              FUN=CREATE,
              NAME='*OUT',
              ORG=CONSEC );

%M$DCB       (DCBN                     = F$PACKET_IN,
              ASN=DEVICE,
              FUN=IN,
              ORG=TERMINAL,
              RES='UC' );

%M$DCB       (DCBN                     = F$PACKET_OUT,
              ASN=DEVICE,
              FUN=CREATE,
              ORG=TERMINAL,
              RES='UC' );
%EJECT;
/**/
/* ENTRYs, listed alphabetically */
/**/

DCL KERMIT$BREAK             ENTRY     ASYNC;
DCL XUR$ALLMSG               ENTRY(1)  ALTRET;
%IF OS_VERSION='B03';
DCL XUR$CLOSE_DCBS           ENTRY;
%ELSE;
DCL XUR$CLOSE_DCBS           ENTRY(2);
%ENDIF;
DCL XUR$ECHO                 ENTRY(1)  ALTRET;
DCL XUR$ECHOIF               ENTRY(1)  ALTRET;
DCL XUR$ERRMSG               ENTRY(7)  ALTRET;
DCL XUR$ERRPTR               ENTRY(2)  ALTRET;
DCL XUR$GETCMD               ENTRY(6)  ALTRET;
DCL XUR$HELP                 ENTRY(1)  ALTRET;
DCL XUR$INIT                 ENTRY(3)  ALTRET;
DCL XUR$MOREMSG              ENTRY(1)  ALTRET;
%IF OS_VERSION='B03';
DCL XUR$SETDCBS              ENTRY(2)  ALTRET;
%ELSE;
DCL XUR$SETDCBS              ENTRY(4)  ALTRET;
%ENDIF;
DCL X$WILDCMP                ENTRY(1)  ALTRET;
DCL X$WRITE                  ENTRY(22);
%EJECT;
/**/
/* PTRs, listed alphabetcally */
/**/

DCL B$JIT$                   PTR       SYMREF;
DCL B$TCB$                   PTR       SYMREF;
DCL BLK1$                    PTR;
DCL  PERRCODE REDEF BLK1$    BIT(36);
DCL BLK2$                    PTR;
DCL BLK3$                    PTR;
DCL BLK4$                    PTR;
DCL BLK5$                    PTR;
DCL F$DEFAULTS$              PTR;
DCL F$DEBUG$                 PTR;
DCL F$IN$                    PTR;
DCL F$LOG$                   PTR;
DCL F$OUT$                   PTR;
DCL F$PACKET_IN$             PTR;
DCL F$PACKET_OUT$            PTR;
DCL M$LO$                    PTR;
DCL M$SI$                    PTR;
%EJECT;
/**/
/* SBIN/UBIN items, listed alphabetically */
/**/

DCL ABORT_REASON             UBIN;
DCL ARS                      SBIN;
DCL BBUF(0:1023)             UBIN;
DCL BINARY_RECL              SBIN      STATIC INIT(128);
DCL BLOCK_CHECK              SBIN      STATIC INIT(%ONE_CHAR_CHECKSUM##);
DCL BRK_CNT                  SBIN      STATIC SYMDEF INIT(0);
DCL CG_ASN                   UBIN(9) STATIC INIT(%FILE#);
DCL CHECKSUM                 UBIN;
DCL CMD#                     SBIN;
DCL CMD_LEN                  SBIN;
DCL CMD_NUM                  SBIN;
DCL CP6_FID_LEN              UBIN      STATIC;
DCL CUR_MODE                 UBIN;
DCL CUR_TAB_EXPANSION        UBIN;
DCL DATA(0:0)                UBIN(9)   CALIGNED BASED(DATA_.PTR$);
DCL DATA_BIT(0:0)            BIT(9)    CALIGNED BASED(DATA_.PTR$);
DCL DATA_BUF                 CHAR(DATA_MAX_SIZE) CALIGNED BASED(DATA_.PTR$);
DCL DATA_MAX_SIZE            UBIN;
DCL DEFAULT_DCB#             SBIN      STATIC INIT(DCBNUM(M$LO));
DCL DELAY                    SBIN      STATIC SYMDEF INIT(10);
DCL END_UTS                  UBIN;
DCL EOR_BYTE_LEN             UBIN;
DCL EOR_CHARS_LEN            UBIN      STATIC INIT(LENGTHC('#M#J'));
DCL ERRDCB#                  SBIN;
DCL F$DEBUG#                 SBIN      STATIC INIT(DCBNUM(F$DEBUG));
DCL F$DEFAULTS#              SBIN      STATIC INIT(DCBNUM(F$DEFAULTS));
DCL F$LOG#                   SBIN      STATIC INIT(DCBNUM(F$LOG));
DCL F$OUT#                   SBIN      STATIC INIT(DCBNUM(F$OUT));
DCL FILE_BYTE_CNT            SBIN      STATIC INIT(0);
DCL FILE_CNT                 SBIN;
DCL HOW_DEBUG                SBIN      STATIC INIT(%OLDFILE#);
DCL HOW_LOG                  SBIN      STATIC INIT(%OLDFILE#);
DCL HOW_RECEIVE              SBIN      STATIC INIT(%ERROR#);
DCL I                        SBIN;
DCL IO_BUF_SIZE              SBIN;
DCL IO_CNT                   SBIN;
DCL IO_INDX                  SBIN;
DCL IO_LEN                   SBIN;
DCL J                        SBIN;
DCL K                        SBIN;
DCL KBUF(0:1023)             UBIN;
DCL L                        SBIN;
DCL LEN                      UBIN;
DCL KERMIT_NODES             SBIN      SYMREF;
DCL M$LO#                    SBIN      STATIC INIT(DCBNUM(M$LO));
DCL NEXT_CALL                SBIN;
DCL NUM_BYTES_RCVD           SBIN      STATIC INIT(0);
DCL NUM_BYTES_SENT           SBIN      STATIC INIT(0);
DCL NUM_CMDS                 SBIN;
DCL NUM_DATA_PACKETS         SBIN      STATIC INIT(0);
DCL NUM_EXTENSIONS           SBIN;
DCL NUM_TABS                 SBIN      STATIC INIT(40);
DCL NUM_TRIES                SBIN;
DCL OFFSET                   SBIN;
DCL OUT_INDX                 SBIN;
DCL PACKET_MAX_SIZE          UBIN;
DCL PACKLEN                  UBIN;
DCL PACKNUM                  UBIN;
DCL RCVD_CHECKSUM            UBIN;
DCL RCVD_PACKNUM             UBIN;
DCL REC_CNT                  UBIN;
DCL REPEAT_CNT               UBIN;
DCL REPEAT_LEN               UBIN;
DCL SEQUENCE_LEN             UBIN;
DCL SET_FILE_CP6_FIDS        UBIN      STATIC INIT(%SET_FILE_CP6_FIDS_NO##);
DCL SET_FILE_EDIT            UBIN      STATIC INIT(%SET_FILE_EDIT_NO##);
DCL SET_FILE_INCOMPLETE      UBIN   STATIC INIT(%SET_FILE_INCOMPLETE_DISCARD##);
DCL SET_FILE_MODE            UBIN      STATIC INIT(%SET_FILE_MODE_AUTO##);
DCL SET_FILE_NAMES           UBIN      STATIC INIT(%SET_FILE_NAMES_ASIS##);
DCL SET_FILE_PC_EXTENSIONS   UBIN    STATIC INIT(%SET_FILE_PC_EXTENSIONS_YES##);
DCL SET_FILE_SUBDIRECTORY    UBIN    STATIC INIT(%SET_FILE_SUBDIRECTORY_OFF##);
DCL SET_FILE_SUBDIRECTORY_INDEX UBIN;
DCL SET_FILE_WARNING         UBIN      STATIC INIT(%SET_FILE_WARNING_ON##);
DCL SET_TAB_EXPANSION        UBIN      STATIC INIT(%SET_TAB_EXPANSION_ON##);
DCL SI_DCB#                  UBIN      STATIC INIT(DCBNUM(M$SI));
DCL SIZE                     UBIN;
DCL SKIP_BLANKS(0:511)       UBIN(9)   CALIGNED CONSTANT SYMDEF INIT
    ( 1 * %ASCBIN(' '), 0, 1 * 0 );
DCL START_UTS                UBIN;
DCL TABS(0:39)               UBIN(9)   STATIC INIT(
    009,017,025,033,041,049,057,065,073,081,
    089,097,105,113,121,129,137,145,153,161,
    169,177,185,193,201,209,217,225,233,241,
    249,257,265,273,281,289,297,305,313,321);
DCL TARGET_WILD_POS          SBIN;
DCL TMP1                     UBIN;
DCL  TMP1_BIT REDEF TMP1     BIT(36);
DCL TX                       UBIN;
DCL UBIN9                    UBIN(9)   CALIGNED;
DCL UTS                      UBIN      STATIC;
DCL X                        UBIN;
%EJECT;
/**/
/* Structures */
/**/

DCL 1 TARGET  STATIC,
      2 L#                   UBIN(9)   CALIGNED,
      2 NAME#                CHAR(31)  CALIGNED;

DCL 1 CUR_FILE,
      2 L#                   UBIN(9)   CALIGNED,
      2 NAME#                CHAR(31)  CALIGNED;

DCL 1 MY_DEFAULT  STATIC  SYMDEF,
      2 PACKET_LENGTH        UBIN(9)   CALIGNED INIT(94),            /* MAXL */
      2 TIMEOUT              UBIN(9)   CALIGNED INIT( 8),            /* TIME */
      2 PADDING              UBIN(9)   CALIGNED INIT( 0),            /* NPAD */
      2 PADCHAR              CHAR(1)   CALIGNED INIT(BINASC(0)),     /* PADC */
      2 END_OF_LINE          CHAR(1)   CALIGNED INIT(BINASC(13)),    /* EOL  */
      2 QUOTE                CHAR(1)   CALIGNED INIT('#'),           /* QCTL */
      2 QBIN                 CHAR(1)   CALIGNED INIT('Y'),           /* QBIN */
      2 BLOCK_CHECK          UBIN(9)   CALIGNED INIT(%ASCBIN('1')),  /* CHKT */
      2 REPT                 CHAR(1)   CALIGNED INIT('~'),           /* REPT */
      2 CAPAS                UBIN(9)   CALIGNED INIT(0),             /* MASK */

      2 PAUSE                UBIN(9)   CALIGNED,
      2 START_OF_PACKET      CHAR(1)   CALIGNED INIT(BINASC( 1));

DCL 1 MY,
      2 PACKET_LENGTH        UBIN(9)   CALIGNED,                     /* MAXL */
      2 TIMEOUT              UBIN(9)   CALIGNED,                     /* TIME */
      2 PADDING              UBIN(9)   CALIGNED,                     /* NPAD */
      2 PADCHAR              CHAR(1)   CALIGNED,                     /* PADC */
      2 END_OF_LINE          CHAR(1)   CALIGNED,                     /* EOL  */
      2 QUOTE                CHAR(1)   CALIGNED,                     /* QCTL */
      2 QBIN                 CHAR(1)   CALIGNED,                     /* QBIN */
      2 BLOCK_CHECK          UBIN(9)   CALIGNED,                     /* CHKT */
      2 REPT                 CHAR(1)   CALIGNED,                     /* REPT */
      2 CAPAS                UBIN(9)   CALIGNED,                     /* MASK */

      2 PAUSE                UBIN(9)   CALIGNED,
      2 START_OF_PACKET      CHAR(1)   CALIGNED;

DCL 1 THEIR  STATIC  SYMDEF,
      2 PACKET_LENGTH        UBIN(9)   CALIGNED INIT(94),            /* MAXL */
      2 TIMEOUT              UBIN(9)   CALIGNED INIT( 8),            /* TIME */
      2 PADDING              UBIN(9)   CALIGNED INIT( 0),            /* NPAD */
      2 PADCHAR              CHAR(1)   CALIGNED INIT(BINASC(00)),    /* PADC */
      2 END_OF_LINE          CHAR(1)   CALIGNED INIT(BINASC(13)),    /* EOL  */
      2 QUOTE                CHAR(1)   CALIGNED INIT('#'),           /* QCTL */
      2 QBIN                 CHAR(1)   CALIGNED INIT('N'),           /* QBIN */
      2 BLOCK_CHECK          UBIN(9)   CALIGNED INIT(%ASCBIN('1')),  /* CHKT */
      2 REPT                 CHAR(1)   CALIGNED INIT(' '),           /* REPT */
      2 CAPAS                UBIN(9)   CALIGNED INIT(0),             /* MASK */

      2 PAUSE                UBIN(9)   CALIGNED,
      2 START_OF_PACKET      CHAR(1)   CALIGNED INIT(BINASC( 1));

DCL 1 PACKET  BASED(PACKET_.PTR$),
      2 MARK                 CHAR(1)   CALIGNED,
      2 LEN                  UBIN(9)   CALIGNED,
      2 SEQ                  UBIN(9)   CALIGNED,
      2 TYPE                 UBIN(9)   CALIGNED,
      2 DATA(0:0)            UBIN(9)   CALIGNED,
      2  DATA_BIT(0:0) REDEF DATA BIT(9),
      2  DATA_BUF REDEF DATA CHAR(1);
DCL PACKET_BUF               CHAR(PACKET_MAX_SIZE) CALIGNED BASED(PACKET_.PTR$);
DCL PACKET_BIT(0:0)          BIT(9)     CALIGNED  BASED(PACKET_.PTR$);
DCL PACKET_WORD(0:0)         BIT(36)              BASED(PACKET_.PTR$);

DCL 1 PROTOCOL  STATIC  SYMDEF,
      2 MAX_INITIAL_RETRIES  UBIN             INIT(10),
      2 MAX_PACKET_RETRIES   UBIN             INIT(10),
      2 SYNCHR               CHAR(1)          INIT(%BITASC('001'O));

DCL 1 DEFAULT  STATIC SYMDEF,
      2 LEN                  UBIN      CALIGNED INIT(LENGTHC(':KERMIT_INI')),
      2 NAME                 CHAR(76)  CALIGNED INIT(':KERMIT_INI');

DCL 1 DEBUG_FILE  STATIC,
      2 LEN                  UBIN               INIT(LENGTHC('*DEBUG')),
      2 NAME#                CHAR(76)           INIT('*DEBUG');

DCL 1 LOG_FILE  STATIC,
      2 LEN                  UBIN               INIT(LENGTHC('*KERMIT_LOG')),
      2 NAME#                CHAR(76)           INIT('*KERMIT_LOG');

DCL 1 DEST,
      2 L#                   UBIN,
      2 NAME#                CHAR(76);

DCL 1 OUT_KEY,
      2 LEN                  UBIN(9)   CALIGNED,
      2 EDIT                 UBIN(27)  CALIGNED;

DCL 1 DEBUG_KEY  STATIC,
      2 LEN                  UBIN(9)   CALIGNED,
      2 EDIT                 UBIN(27)  CALIGNED,
      2 *                    CHAR(252) CALIGNED;

DCL 1 LOG_KEY  STATIC,
      2 LEN                  UBIN(9)   CALIGNED,
      2 EDIT                 UBIN(27)  CALIGNED,
      2 *                    CHAR(252) CALIGNED;

DCL 1 EXTEN(0:%(MAX_EXTENSIONS#-1)),
      2 LEN                  UBIN(9)   CALIGNED,
      2 TEXT                 CHAR(11)  CALIGNED;

DCL 1 PROMPT,
    2 VFC#                   BIT(1)    UNAL,
      2 L#                   UBIN(8)   UNAL,
      2 NAME#                CHAR(31)  CALIGNED;
DCL 1 SET_FILE_PREFIX  STATIC,
      2 LEN                  UBIN(9)   CALIGNED INIT(0),
      2 TEXT                 CHAR(19)  CALIGNED;
%EJECT;

DCL 1 BAD_FID_CHARS  STATIC,
      2 *(0:127)             UBIN(9)   UNAL   INIT(
/* DECIMAL   OCTAL   */
/*   0-  7 .000-.007 */  001,001,002,003,004,005,006,007,
/*   8- 15 .010-.017 */  008,009,010,011,012,013,014,015,
/*  16- 23 .020-.027 */  016,017,018,019,020,021,022,023,
/*  24- 31 .030-.037 */  024,025,026,027,028,029,030,031,
/*  32- 39 .040-.047 */  032,033,034,035,000,037,038,039,
/*  40- 47 .050-.057 */  040,041,000,043,044,000,046,047,
/*  48- 55 .060-.067 */  000,000,000,000,000,000,000,000,
/*  56- 63 .070-.077 */  000,000,000,059,060,061,062,000,
/*  64- 71 .100-.107 */  064,000,000,000,000,000,000,000,
/*  72- 79 .110-.117 */  000,000,000,000,000,000,000,000,
/*  80- 87 .120-.127 */  000,000,000,000,000,000,000,000,
/*  88- 95 .130-.137 */  000,000,000,091,092,093,094,000,
/*  96-103 .140-.147 */  096,000,000,000,000,000,000,000,
/* 104-111 .150-.157 */  000,000,000,000,000,000,000,000,
/* 112-119 .160-.167 */  000,000,000,000,000,000,000,000,
/* 120-127 .170-.177 */  000,000,000,123,124,125,126,127);
%EJECT;
/**/
/* VECTORs, listed alphabetically */
/**/

DCL VEC1_                    BIT(72)          DALIGNED;
DCL VEC2_                    BIT(72)          DALIGNED;
DCL VEC3_                    BIT(72)          DALIGNED;
DCL VEC4_                    BIT(72)          DALIGNED;
DCL VEC5_                    BIT(72)          DALIGNED;
DCL VEC6_                    BIT(72)          DALIGNED;
%EJECT;
/**/
/* X$WRITE formats */
/**/

DCL FMT                      CHAR(0)   STATIC INIT('%>A');
DCL FMT1                     CHAR(0)   STATIC INIT(
    'Send cntrl char prefix: %>A%42-Receive cntrl char prefix: %>A');
DCL FMT2                     CHAR(0)   STATIC INIT(
    'Receive start-of-packet char: %>A%42-Send start-of-packet char: %>A');
DCL FMT3                     CHAR(0)   STATIC INIT(
    'Receive timeout (seconds): %D%42-Send timeout (seconds): %D');
DCL FMT4                     CHAR(0)   STATIC INIT(
    'Receive packet size: %D%42-Send packet size: %D');
DCL FMT5                     CHAR(0)   STATIC INIT(
    '# of send pad characters: %D%42-# of Receive pad characters: %D');
DCL FMT6                     CHAR(0)   STATIC INIT(
    'End-of-line character: %>A%42-Block check used: 1-CHARACTER-CHECKSUM');
DCL FMT7                     CHAR(0)   STATIC INIT(
    'Accepting CP-6 fids: %>A%42-%>A');
DCL FMT8                     CHAR(0)   STATIC INIT(
    'Illegal fid chars replaced with: %>A%42-%>A');
DCL FMT9                     CHAR(0)   STATIC INIT(
    '%>A%42-Delay %D seconds before first packet');
DCL FMT10                    CHAR(0)   STATIC INIT(
    'Initial packet retry count: %D%42-Packet retry count: %D');
DCL FMT11                    CHAR(0)   STATIC INIT(
    'Tab expansion: %>A%42-Log file:%>A %>A');
DCL FMT12                    CHAR(0)   STATIC INIT(
    '.. Key of next record in %>A will be %D.000.');
DCL FMT13                    CHAR(0)   STATIC INIT(
    '.. %>A currently has %D records.');
DCL FMT14                    CHAR(0)   STATIC INIT(
    '.. Creating %>A');
DCL FMT15                    CHAR(0)   STATIC INIT(
    '.. Can''t DEBUG .. %>A is NOT EDIT keyed.');
DCL FMT16                    CHAR(0)   STATIC INIT(
    '.. No room to add new integral EDIT key in %>A.');
DCL FMT17                    CHAR(0)   STATIC INIT(
    '%A %A, 19%A at %A logged on as %>A,%>A');
DCL FMT18                    CHAR(0)   STATIC INIT(
    '   %>A %>A as %>A (%D records) in %>A mode');
DCL FMT19                    CHAR(0)   STATIC INIT(
    '   %>A %>A (%D records) in %>A mode');
DCL FMT20                    CHAR(0)   STATIC INIT(
    '   %>A %>A%Q (%D records) in %>A mode');
DCL FMT21                    CHAR(0)   STATIC INIT(
    '   %>A %>A as %>A%Q (%D records) in %>A mode');
DCL FMT22                    CHAR(0)   STATIC INIT(
    '   Maximum packet sizes: Sent: %D  Received: %D');
DCL FMT23                    CHAR(0)   STATIC INIT(
    '   %D Data packets used to send the files %D bytes');
DCL FMT24                    CHAR(0)   STATIC INIT(
    '   %D Data packets used to receive the files %D bytes');
DCL FMT25                    CHAR(0)   STATIC INIT(
    '   %D bytes sent accross the communications line');
DCL FMT26                    CHAR(0)   STATIC INIT(
    '   %D bytes received accross the communications line');
DCL FMT27                    CHAR(0)   STATIC INIT(
    '   %>A at %>A baud, Parity=%>A');
DCL FMT28                    CHAR(0)   STATIC INIT(
    '   Error packet: %>A');
DCL FMT29                    CHAR(0)   STATIC INIT(
    '   %>A %>A in %>A mode');
DCL FMT30                    CHAR(0)   STATIC INIT(
    '   %>A %>A as %>A in %>A mode');
DCL FMT31                    CHAR(0)   STATIC INIT(
  '.. %D is an invalid TAB value; value must be 1-255; default tabs restored.');
DCL FMT32                    CHAR(0)   STATIC INIT(
    '.. Tabs must be specified in ascending order; the value %D wasn''t');
DCL FMT33                    CHAR(0)   STATIC INIT(
    'Mode determined by file extension: %>A%42-Mode: %>A' );
DCL FMT34                    CHAR(0)   STATIC INIT(
    'File warning: %>A%42-Debug file:%>A %>A' );
DCL FMT35                    CHAR(0)   STATIC INIT(
    '.. Sorry, too many characters specified; maximum allowed is 2.');
DCL FMT36                    CHAR(0)   STATIC INIT(
    '.. %D is an invalid value; value must be 0-255.');
DCL FMT37                    CHAR(0)   STATIC INIT(
    'Subdirectories enabled: %>A%42-Subdirectory character: %>A');
DCL FMT38                    CHAR(0)   STATIC INIT(
    'CP-6 file prefix is: %>A');
%EJECT;
/**/
/* X$WRITE vectors */
/**/

DCL FMT_                     BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT));
DCL FMT1_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT1));
DCL FMT2_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT2));
DCL FMT3_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT3));
DCL FMT4_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT4));
DCL FMT5_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT5));
DCL FMT6_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT6));
DCL FMT7_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT7));
DCL FMT8_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT8));
DCL FMT9_                    BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT9));
DCL FMT10_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT10));
DCL FMT11_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT11));
DCL FMT12_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT12));
DCL FMT13_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT13));
DCL FMT14_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT14));
DCL FMT15_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT15));
DCL FMT16_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT16));
DCL FMT17_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT17));
DCL FMT18_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT18));
DCL FMT19_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT19));
DCL FMT20_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT20));
DCL FMT21_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT21));
DCL FMT22_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT22));
DCL FMT23_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT23));
DCL FMT24_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT24));
DCL FMT25_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT25));
DCL FMT26_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT26));
DCL FMT27_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT27));
DCL FMT28_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT28));
DCL FMT29_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT29));
DCL FMT30_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT30));
DCL FMT31_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT31));
DCL FMT32_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT32));
DCL FMT33_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT33));
DCL FMT34_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT34));
DCL FMT35_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT35));
DCL FMT36_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT36));
DCL FMT37_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT37));
DCL FMT38_                   BIT(72)   STATIC DALIGNED INIT(VECTOR(FMT38));
%EJECT;
/****
*
*   The main program is fairly trivial.  First INITIALIZE gets called to
*   initialize various items, most of which are in auto.  Next, we call
*   PARSE_CCBUF.  It kind of does what it says; it parses the options, if any,
*   specified on the invocation line.  If the NO DEFAULTS option was NOT
*   specified on the invocation line then any commands in the default file
*   (:KERMIT_INI) are read and executed.  After the defaults are executed any
*   options on the invocation line are executed.  If there were any options on
*   the invocation line besides DONT GREET, DONT PROMPT, NO DEFAULTS and/or
*   SILENT MODE then KERMIT will exit after the last such command is executed.
*   Otherwise, KERMIT will prompt the user for additional commands (or read
*   from the file specified through DCB1 on the invocation line).
*
****/

START_KERMIT:

    CALL INITIALIZE          ALTRET( PUT_ERR );

    CALL PARSE_CCBUF         ALTRET( PUT_ERR );

    DO WHILE( NOT DONE );
       CALL DO_1_LINE_OF_OPTIONS              ALTRET( DONE_YET );
DONE_YET:
       END;

EOJ:
    CALL CLOSE_A_FILE( F$DEBUG# );
    CALL CLOSE_A_FILE( M$LO#,%SAVE# );
%IF OS_VERSION='B03';
    CALL XUR$CLOSE_DCBS;                      /* Close all files              */
%ELSE;
    CALL XUR$CLOSE_DCBS( ,ERRCODE);           /* Close all files              */
%ENDIF;
    GOTO QUIT;

PUT_ERR:
    ERRDCB#= %ERRDCB;
    IF NOT DONE THEN                          /* If we had unexpected error   */
       CALL XUR$ERRMSG( %MONERR,ERRDCB# );    /* print an appropriate error.  */
SET_THE_STEPCC:
    SET_STEPCC.V.STEPCC#= 4;
QUIT:
    IF VLP_GTRMCTL.SINPUTSZ# ~= 255 THEN      /* Did we change anything?      */
       CALL M$STRMCTL( ORIG_TRMCTL );         /* Yep, change things back      */
    CALL M$EXIT( SET_STEPCC );                /* Set STEPCC upon exit         */

%EJECT;
/****
*
*   B L O C K _ M O V E
*
*   Move LEN bytes from SOURCE to DESTINATION.  This routine can only be used
*   in cases where the destination is not a packet buffer that could have
*   repeating done in it.
*
****/

BLOCK_MOVE: PROC( DESTINATION,SOURCE,LEN );
DCL DESTINATION              CHAR(LEN);
DCL SOURCE                   CHAR(LEN);
DCL LEN                      UBIN;

    DESTINATION= SOURCE;
RE_TURN:
    RETURN;

END BLOCK_MOVE;
%EJECT;
/****
*
*   B U F E M P
*
*   This routine basically just repeatedly gets a byte(s) from the incoming
*   data packet and then deposits it in the CP-6 file being created.  If the
*   transfer in progress is a TEXT transfer, TABs will be expanded if
*   SET TAB EXPANSION = ON.
*
****/

BUFEMP: PROC( DATA_BUF,LEN )  ALTRET;
DCL DATA_BUF                 CHAR(LEN);
DCL LEN                      SBIN;

DCL I                        SBIN;

DCL TMP_CHR                  CHAR(1);

    I= 0;
    DO WHILE( (I < LEN  OR  REPEAT_CNT > 0)  AND  NOT AT_EOF );
       CALL GET_PACKET_CHAR( DATA_BUF,I );/*Get Ith char; I+1th char if quoted*/
       IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN DO;
          CALL STUFF( IO_BUF,IO_LEN )  ALTRET( ALT_RETURN );
          IF IO_LEN >= BINARY_RECL THEN
             CALL WRITE_RECORD( IO_BUF,IO_LEN )  ALTRET( ALT_RETURN );
          END;
       ELSE
          IF (CHR = EOR_BYTE(1)  AND  PREV_CHR = EOR_BYTE(0)) OR
             (CHR = EOR_BYTE(0) AND EOR_BYTE_LEN = 1)  THEN DO;
             CALL WRITE_RECORD( IO_BUF,IO_LEN )  ALTRET( ALT_RETURN );
             END;
          ELSE DO;
             IF (PREV_CHR = EOR_BYTE(0))  AND  (EOR_BYTE_LEN > 1)  THEN DO;
                TMP_CHR= CHR;
                CHR= PREV_CHR;
                CALL STUFF( IO_BUF,IO_LEN )  ALTRET( ALT_RETURN );
                CHR= TMP_CHR;
                END;
             IF CHR ~= EOR_BYTE(0) THEN DO;
                IF CHR = %TAB  AND  CUR_MODE=%SET_FILE_MODE_TEXT##  AND
                   SET_TAB_EXPANSION = %SET_TAB_EXPANSION_ON## THEN DO;
                      DO X=TX TO NUM_TABS-1;
                         IF IO_LEN+1 < TABS(X) THEN
                            GOTO SPACE_INSERT;
                         END;
                   IO_LEN= IO_LEN + LENGTHC(' ');
                   DO WHILE( '0'B );
SPACE_INSERT:
                      IO_LEN= TABS(X) - 1;
                      TX= X + 1;
                      END;
                   IF IO_LEN >= IO_BUF_SIZE THEN
                      CALL EXPAND( IO_,IO_BUF_SIZE,IO_BUF_SIZE )
                                              ALTRET( ALT_RETURN );
                   END;
                ELSE
                   IF CHR=%SUB AND CUR_MODE=%SET_FILE_MODE_TEXT## THEN DO;
                      AT_EOF= %YES#;
                      GOTO RE_TURN;
                      END;
                   ELSE DO;
                      CALL STUFF( IO_BUF,IO_LEN )  ALTRET( ALT_RETURN );
                      END;
                END;
             END;
       PREV_CHR= CHR;
       END;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END BUFEMP;
%EJECT;
/****
*
*   B U F I L L
*
*   Get a buffer full of data from the file that's being sent.
*
****/

BUFILL: PROC  ALTRET;

    IF AT_EOF THEN DO;                        /* Are we at EOF?               */
       STATE= %Z_EOF;                         /* Yep, change states           */
       GOTO ALT_RETURN;
       END;

    SIZE= 0;

    /****
    *
    *   Continue where we left off last time we were here.  NEXT_CALL contains
    *   a code that will take care of this.
    *
    ****/
    DO CASE( NEXT_CALL );

       CASE( %NOTHING# );

       CASE( %BUILD_SEQUENCE# );
          CALL BUILD_REPEAT_SEQUENCE;

       CASE( %PUT_CHAR_IN_PACKET# );
          CALL BUILD_REPEAT_SEQUENCE;
          CALL PUT_CHAR_IN_PACKET( CUR_CHR );

       CASE( %STUFF_CHAR_IN_PACKET# );
          CALL STUFF_CHAR_IN_PACKET( CUR_CHR );

       END;

    NEXT_CALL= %NOTHING#;

    CALL GET_CHAR_FROM_FILE  ALTRET( WAS_EOF_HIT );
    DO WHILE( '1'B );

       CALL PUT_CHAR_IN_PACKET( IO_BYTE(IO_INDX) )  ALTRET( NO_ROOM );
       CALL GET_CHAR_FROM_FILE  ALTRET( WAS_EOF_HIT );

       END;

    DO WHILE( '0'B );
WAS_EOF_HIT:
       IF STATE = %A_ABORT THEN
ALT_RETURN:
          ALTRETURN;
       END;

NO_ROOM: ;
RE_TURN:
    RETURN;

END BUFILL;
%EJECT;
/****
*
*   B U I L D _ R E P E A T _ S E Q U E N C E
*
*   It is time to put PREV_CHR in the out going packet.  If repeating is
*   allowed, we may have to build a repeat sequence for that character.
*
****/

BUILD_REPEAT_SEQUENCE: PROC  ALTRET;

    CALL CALC_SEQUENCE_LEN( PREV_CHR );

    IF SIZE+MINIMUM(REPEAT_CNT*SEQUENCE_LEN,REPEAT_LEN+SEQUENCE_LEN) > THEIR.PACKET_LENGTH-3 THEN
       GOTO ALT_RETURN;                       /* Won't fit in this packet     */

    IF REPEAT_CNT*SEQUENCE_LEN >= REPEAT_LEN+SEQUENCE_LEN THEN DO;
       SUBSTR(DATA_BUF,SIZE,1)= THEIR.REPT;/* Stuff their repeat character */
       DATA(SIZE+1)= REPEAT_CNT;
       CALL TOCHAR( DATA(SIZE+1),DATA(SIZE+1) );  /* and REPEAT_CNT        */
       SIZE= SIZE + LENGTHC(THEIR.REPT) + LENGTHC(DATA(SIZE+1));
       CALL STUFF_CHAR_IN_PACKET( PREV_CHR );
       END;
    ELSE DO;
       DO SEQUENCE_LEN=1 TO REPEAT_CNT;
          CALL STUFF_CHAR_IN_PACKET( PREV_CHR );
          END;
       END;

    REPEAT_CNT= 0;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END BUILD_REPEAT_SEQUENCE;
%EJECT;
/****
*
*   C A L C _ C H E C K S U M
*
*   Calculate the checksum for the current packet and return it in CHECKSUM
*
****/

CALC_CHECKSUM: PROC( CHECKSUM );
DCL CHECKSUM                 UBIN;
DCL  CHECKSUM_BITS REDEF CHECKSUM BIT(36);

DCL TMP                      UBIN;
DCL  TMP_BITS REDEF TMP      BIT(36);

    CHECKSUM= PACKET.LEN;                     /* CHECKSUM= PACKET.LEN + 3     */
    CHECKSUM= CHECKSUM + PACKET.SEQ;          /* CHECKSUM += PACKET.SEQ       */
    CHECKSUM= CHECKSUM + PACKET.TYPE;         /* CHECKSUM + PACKET.TYPE       */

    IF CHARMASK = '377'O THEN
       DO I=0 TO PACKET.LEN-1-3-ASCBIN(' ');  /* CHECKSUM all the data bytes  */
          CHECKSUM= CHECKSUM + PACKET.DATA(I);
          END;
    ELSE
       DO I=0 TO PACKET.LEN-1-3-ASCBIN(' ');  /* CHECKSUM all the data bytes  */
          CHECKSUM= CHECKSUM + MOD(PACKET.DATA(I),128);
          END;
    CHECKSUM_BITS= CHECKSUM_BITS & '000000000377'O;
    CHECKSUM= CHECKSUM + (CHECKSUM/64);
    CHECKSUM_BITS= CHECKSUM_BITS & '000000000077'O;
RE_TURN:
    RETURN;

END CALC_CHECKSUM;
%EJECT;
/****
*
*   C A L C _ S E Q U E N C E _ L E N
*
*   Determine how many bytes CHR will occupy in the out going packet after any
*   necessary encoding is done.
*
****/

CALC_SEQUENCE_LEN: PROC( CHR );
DCL CHR                      CHAR(1);
DCL  CHR_BIT REDEF CHR       BIT(9);

DCL CHR7                     CHAR(1);
DCL  CHR7_BIT REDEF CHR7     BIT(9);

    SEQUENCE_LEN= LENGTHC(CHR);
    CHR7_BIT= CHR_BIT & '177'O;
    IF BINARY_QUOTING  AND  CHR ~= CHR7  THEN
       SEQUENCE_LEN= SEQUENCE_LEN + LENGTHC(MY.QBIN);
    IF CHR7 < ' '                           OR
       CHR7 = MY.QUOTE                      OR
       CHR7 = %DEL                          OR
      (REPEATING  AND  CHR7=MY.REPT)        OR
      (BINARY_QUOTING  AND  CHR7=MY.QBIN)  THEN
       SEQUENCE_LEN= SEQUENCE_LEN + LENGTHC(MY.QUOTE);

RE_TURN:
    RETURN;

END CALC_SEQUENCE_LEN;
%EJECT;
/****
*
*   C H A R C T L
*
*   Convert VALUE into a printable string.  If VALUE is already printable
*   (ASCII 32-126) then just move it to STR.  If VALUE < a blank (ASCII 32)
*   then STR will equal '^x' where x equals VALUE + 64 (eg. if VALUE = 1, then
*   STR would be '^A').  If VALUE > '~' (ASCII 126) then STR will be set to
*   the hex representation of VALUE (eg. X'7F').
*
****/

CHARCTL: PROC( STR,VALUE );
DCL STR                      CHAR(6);
DCL VALUE                    UBIN;

    IF VALUE>0 AND VALUE<%ASCBIN(' ') THEN
       CALL CONCAT( STR,'^',BINASC(VALUE+%ASCBIN('A')-1) );
    ELSE
       IF VALUE>%ASCBIN(' ') AND VALUE<=%ASCBIN('~') THEN
          STR= BINASC(VALUE);
       ELSE DO;
          STR= 'X''000''';
          SUBSTR(STR,2,1)= HEX(VALUE/256);
          X= MOD(VALUE,256);
          SUBSTR(STR,3,1)= HEX(X/16);
          X= MOD(X,16);
          SUBSTR(STR,4,1)= HEX(X);
          END;
RE_TURN:
    RETURN;

END CHARCTL;
%EJECT;
/****
*
*   C H E C K _ E X T E N S I O N S
*
*   Check to see if the file name in SRCE matches any of the extensions in the
*   EXTEN table.  If it matches at least one in EXTEN then a normal RETURN is
*   executed else an ALTRETURN.
*
****/

CHECK_EXTENSIONS: PROC( SRCE )  ALTRET;
DCL 1 SRCE,
      2 LEN                  UBIN(9)   CALIGNED,
      2 TEXT                 CHAR(11)  CALIGNED;

DCL I                        UBIN;

%IF OS_VERSION='B03';
    COMPARE_EXT.INPUT$= ADDR(SRCE);
%ELSE;
    COMPARE_EXT.INPUT_= VECTOR(SUBSTR(SRCE.TEXT,0,SRCE.LEN));
%ENDIF;
    IF NUM_EXTENSIONS>0 THEN
       DO I=0 TO NUM_EXTENSIONS-1;
%IF OS_VERSION='B03';
          COMPARE_EXT.PATTERN$= ADDR(EXTEN(I));
%ELSE;
          COMPARE_EXT.PATTERN_= VECTOR(SUBSTR(EXTEN.TEXT(I),0,EXTEN.LEN(I)));
%ENDIF;
          CALL X$WILDCMP( COMPARE_EXT )  ALTRET( TRY_NEXT_EXT );
RE_TURN:
          RETURN;
TRY_NEXT_EXT:
          END;

ALT_RETURN:
    ALTRETURN;

END CHECK_EXTENSIONS;
%EJECT;
/****
*
*   C L O S E _ A _ F I L E
*
*   CLOSE the DCB number DCB# with a disposition of DISP.  If DISP is not
*   passed, assume SAVE.
*
****/

CLOSE_A_FILE: PROC( DCB#,DISP );
DCL DCB#                     SBIN;
DCL DISP                     SBIN;

    FPT_CLOSE.V.DCB#= DCB#;                   /* Use their DCB#               */
    IF ADDR(DISP) ~= ADDR(NIL)  AND           /* If they specified a DISP     */
       DISP = %RELEASE#  THEN                 /* and it was RELEASE           */
       FPT_CLOSE.V.DISP#= %RELEASE#;          /* then RELEASE the file        */
    ELSE
       FPT_CLOSE.V.DISP#= %SAVE#;             /* else, SAVE it.               */
    IF DCB# = DCBNUM(F$IN)  OR  DCB# = DCBNUM(F$OUT) THEN
       CALL XSA$CLOSE( FPT_CLOSE,XSA_PARAM );
    ELSE
       CALL M$CLOSE( FPT_CLOSE );
RE_TURN:
    RETURN;

END CLOSE_A_FILE;
%EJECT;
/****
*
*   C T L
*
*   Make the SRCE byte printable and put the result in DEST.  This basically
*   means do an exclusive OR on SRCE with 64.
*
****/

CTL: PROC( DEST,SRCE );
DCL DEST                     BIT(9)    CALIGNED;
DCL SRCE                     BIT(9)    CALIGNED;

    IF SRCE & '100'O THEN
       DEST= SRCE & '677'O;
    ELSE
       DEST= SRCE \ '100'O;
RE_TURN:
    RETURN;

END CTL;
%EJECT;
/****
*
*   D E T E R M I N E _ R C V D _ M O D E
*
*   Attempt to determine the MODE (BINARY or TEXT) of the file being received
*   by checking the list of BINARY EXTENSIONS (if SET PC EXTENSIONS = ON).  If
*   the file name has a suffix in the EXTEN table then the transfer will be in
*   BINARY mode; else it will be in text mode.
*
****/

DETERMINE_RCVD_MODE: PROC;

    IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN DO;
       CUR_MODE= %SET_FILE_MODE_BINARY##;     /* Assume BINARY mode for now   */
       CALL CHECK_EXTENSIONS( TARGET )  WHENALTRETURN DO;
          CUR_MODE= %SET_FILE_MODE_TEXT##;
          END;
       END;
    ELSE
       CUR_MODE= SET_FILE_MODE;

    IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN DO;
       MODE= 'BINARY';
       OPEN_IO.V.TYPE#= 'BI';
       END;
    ELSE DO;
       MODE= 'TEXT';
       OPEN_IO.V.TYPE#= '  ';
       END;

RE_TURN:
    RETURN;

END DETERMINE_RCVD_MODE;
%EJECT;
/****
*
*   D E T E R M I N E _ S E N D _ M O D E
*
*   Determine the mode (BINARY or TEXT) of the file being sent.  It will be
*   BINARY if the TYpe of the CP-6 file is BI or if the suffix of the file
*   name matches one or more of those suffixes in the EXTEN table and SET PC
*   EXTENSIONS = ON is true.
*
****/

DETERMINE_SEND_MODE: PROC;

    IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN
       IF F$IN$->F$DCB.TYPE# = 'BI' THEN
          CUR_MODE= %SET_FILE_MODE_BINARY##;
       ELSE
          IF F$IN$->F$DCB.NAME#.L < LENGTHC('-xxx') THEN
             CUR_MODE= %SET_FILE_MODE_TEXT##;
          ELSE DO;
             CUR_MODE= %SET_FILE_MODE_BINARY##;
             CALL CHECK_EXTENSIONS( F$IN$->F$DCB.NAME# )  WHENALTRETURN DO;
                CUR_MODE= %SET_FILE_MODE_TEXT##;
                END;
             END;
    ELSE
       CUR_MODE= SET_FILE_MODE;
    IF CUR_MODE = %SET_FILE_MODE_BINARY## THEN
       MODE= 'BINARY';
    ELSE
       MODE= 'TEXT';

RE_TURN:
    RETURN;

END DETERMINE_SEND_MODE;
%EJECT;
/****
*
*   D O _ 1 _ L I N E _ O F _ O P T I O N S
*
*   The desire is to parse a line of commands and pick off one token at a
*   time.  This can be done in one of two ways.  1) the line of options is
*   passed in BUF and is BUF_LEN bytes long or 2) BUF = ADDR(NIL) (ie. no
*   argument was passed) in which case the first time GET_A_CMD is called, it
*   will read a record of command(s) from the current command stream, usually
*   M$SI which is normally set to ME.
*
****/

DO_1_LINE_OF_OPTIONS: PROC( BUF,BUF_LEN )  ALTRET;

DCL BUF                      CHAR(BUF_LEN);
DCL BUF_LEN                  SBIN;

CONTINUE:
    DONE_PARSING= %NO#;
    DO UNTIL( DONE_PARSING );
       CALL GET_A_CMD( BUF,BUF_LEN )  ALTRET( END_OF_RECORD );  /* Get a cmd  */
       IF NOT DONE_PARSING THEN               /* If they didn't say to quit,  */
          CALL DO_A_CMD;                      /* execute their command.       */
       END;

END_OF_RECORD:
    IF NOT DONE_PARSING THEN
       IF ERRCODE.ERR# = %E$EOF THEN          /* Did we hit EOF?              */
          IF SI_DCB# = DCBNUM(M$SI) THEN      /* If we're reading from M$SI   */
             DONE= %YES#;                     /* then we're DONE now          */
          ELSE                                /* We're READing from M$SI2;    */
             IF SI_DCB# ~= F$DEFAULTS# THEN DO;
                CALL CLOSE_A_FILE( SI_DCB# ); /* CLOSE M$SI2                  */
                SI_DCB#= DCBNUM(M$SI);        /* Change DCBs                  */
                CALL XUR$SETDCBS( SI_DCB# );  /* Tell XUR we changed DCBs     */
                GOTO CONTINUE;                /* Go read another line of cmds */
                END;
             ELSE
                ;
       ELSE DO;
          CALL PUT_ERROR;                     /* Otherwise, put the finger.   */
          IF (ERRCODE.ERR# = %E$NOFILE) AND (SI_DCB# = DCBNUM(M$SI)) THEN
             DONE= %YES#;
          END;
    IF (CCBUF_CMD) AND (SI_DCB# ~= F$DEFAULTS#) THEN/*If command was in CCBUF,*/
       DONE= %YES#;                           /* we're done.                  */
ALT_RETURN:
    ALTRETURN;

END DO_1_LINE_OF_OPTIONS;
%EJECT;
/****
*
*   D O _ A _ C M D
*
*   A command has already been parsed and the code of same is in CMD#.  All we
*   do here is a large DO CASE on CMD#.
*
****/

DO_A_CMD: PROC  ALTRET;

    DO CASE( CMD# );
       CASE( %ALL_HELP## );
          CALL XUR$ALLMSG( XUH_PARAM )  ALTRET( HELP_ERR );

       CASE( %BYE## );
          PACKNUM= 0;
          NUM_TRIES = 0;
          X = MY_DEFAULT.TIMEOUT;
          CALL SET_TIMEOUT(X);
/*        CALL SEND_INIT;   */
          CALL SEND_PACKET('G',0,1,'L');
          CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );
          CALL SET_TIMEOUT(0);
          IF TYPE = 'Y' THEN GOTO XIT;

          CASE( %CG## );
             CG_FID = %BLK3_TEXT;
             CG_SPECIFIED = %YES#;
             IF STATION_SPECIFIED THEN CALL OPEN_TO_CG;

       CASE( %DEBUG## );
          CALL DO_DEBUG;

       CASE( %DONT_GREET## );

       CASE( %DONT_PROMPT## );

       CASE( %FINISH## );
          PACKNUM= 0;
          NUM_TRIES = 0;
          X = MY_DEFAULT.TIMEOUT;
          CALL SET_TIMEOUT(X);
/*        CALL SEND_INIT;   */
          CALL SEND_PACKET('G',0,1,'F');
          CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );
          CALL SET_TIMEOUT(0);
          IF TYPE = 'Y' THEN
             GOTO XIT;

       CASE( %HELP## );
          XUH_PARAM.HELP$= BLK3$->P_SYM.TEXTC$;
          CALL XUR$HELP( XUH_PARAM )   ALTRET( HELP_ERR );
          DO WHILE('0'B);
HELP_ERR:
             IF XUH_PARAM.ERR.ERR# ~= %E$NOHPROC  AND
                XUH_PARAM.ERR.ERR# ~= %E$BDTOPIC THEN
                CALL XUR$ERRMSG( XUH_PARAM.ERR );
             END;

       CASE( %LIST## );
          IF %BLK2_NSUBLKS = 0 THEN
             CMD_BUF= 'L';
          ELSE
             CALL CONCAT( CMD_BUF,'L ',%BLK3_TEXT );
          CALL M$YC( FPT_YC )  ALTRET( YC_ERR );
          DO WHILE('0'B);
YC_ERR:
             ERRDCB#= %ERRDCB;
             CALL XUR$ERRMSG( %MONERR,ERRDCB# );
             END;

       CASE( %LOCAL## );
          CALL DO_LOCAL_COMMAND        ALTRET( RE_TURN );

       CASE( %LOG## );
          CALL DO_LOG;

       CASE( %MORE_HELP## );
GET_MORE_HELP:
          CALL XUR$MOREMSG( XUH_PARAM )       ALTRET( HELP_ERR );

       CASE( %NULL## );
          IF M$SI$->F$DCB.EOMVAL#.VALUE# = BITBIN('012'O) THEN DO;
             CMD#= %MORE_HELP##;              /* Pretend they entered '?'     */
             GOTO GET_MORE_HELP;
             END;

       CASE( %NO_DEFAULTS## );


       CASE( %PROMPT## );
          IF %BLK3_COUNT > 0 THEN DO;
             PROMPT.VFC#= %NO#;
             PROMPT.L#= %BLK3_COUNT;
             PROMPT.NAME#= %BLK3_TEXT;
             END;
          ELSE DO;
             PROMPT.VFC#= %YES#;
             PROMPT.L#= LENGTHC('@');
             PROMPT.NAME#= '@';
             END;
          CALL XUR$INIT( XUR_INIT );

       CASE( %READ## );
          CALL DO_READ;

       CASE( %RECEIVE## );
          FILE_CNT= 0;
          MY= MY_DEFAULT;
          PACKNUM= 0;
          TX= 0;
          OPEN_IO= DEFAULT_OPEN;
          OPEN_IO.V_= VECTOR(OPEN_IO.V);
          HOW_RECEIVE= SET_FILE_WARNING - %SET_FILE_WARNING_ON## + 1;
          OPEN_IO.V.FUN#= %CREATE#;
          IF %BLK2_NSUBLKS = 0 THEN
             SRCE_FID= ' ';                   /* Only 'RECEIVE' was specified */
          ELSE
             IF %BLK2_NSUBLKS = 1 THEN        /* Was 'RECEIVE fid" specified? */
                SRCE_FID= %BLK3_TEXT;         /* Yep, Remember it.            */
             ELSE DO;
                SRCE_FID= %BLK2_SUBLK$(2)->P_SYM.TEXT;
                HOW_RECEIVE= %BLK2_SUBLK$(1)->P_SYM.CODE - %ON## + 1;
                END;
          CALL RECEIVE_A_FILE( %R_RINIT );
          CALL SNOOZE( DELAY );               /* Wait before we prompt again  */

       CASE( %SEND## );
          IF NOT IM_A_SERVER THEN DO;
             SRCE_FID= %BLK3_TEXT;
             CALL SEND;
             END;

       CASE( %SERVER## );
          CALL SERVER  ALTRET( XIT );

       CASE( %SET## );
          CALL SET;

       CASE( %SHOW## );
          CALL SHOW;

       CASE( %SILENT## );
          SILENT_MODE= %YES#;                 /* Shut up!                     */

       CASE( %STATION## );
          CG_STATION.ISTA.ISTATION# = %BLK3_TEXT;
          CG_STATION.OSTA.OSTATION# = %BLK3_TEXT;
          STATION_SPECIFIED = %YES#;
          IF CG_SPECIFIED THEN CALL OPEN_TO_CG;

       CASE( %STATISTICS## );
          CALL PUT( UNIMPLEMENTED_CMD );

       CASE( %TRANSMIT## );
          CALL SNOOZE( DELAY );               /* Give them time to go to micro*/
          CALL CONCAT( CMD_BUF,'C ',%BLK3_TEXT );
          CALL M$YC( FPT_YC )  ALTRET( YC_ERR );

       CASE( %XIT## );
XIT:
          IF SI_DCB# = DCBNUM(M$SI2) THEN DO; /* Are we READing thru M$SI2?   */
             CALL CLOSE_A_FILE( SI_DCB# );    /* CLOSE M$SI2                  */
             SI_DCB#= DCBNUM(M$SI);           /* Revert back to M$SI          */
             CALL XUR$SETDCBS( SI_DCB# );     /* Tell XUR that we changed DCBs*/
             END; /* Since we were in M$SI2 ignore the fact we got an END cmd */
          ELSE DO;                            /* Guess it's time to quit      */
             DONE= %YES#;
             DONE_PARSING= %YES#;
             END;

       CASE( ELSE );
          CALL PUT( '.. Oops!  Unknown option encountered by CP-6 Kermit.\' );

       END;

RE_TURN:
    RETURN;

END DO_A_CMD;
%EJECT;
/****
*
*   D O _ D E B U G
*
*   Do all the various things that need to be done based on what they said on
*   the DEBUG command.
*
****/

DO_DEBUG: PROC  ALTRET;

    FPT_OPEN= DEFAULT_OPEN;
    FPT_OPEN.V.FUN#= %CREATE#;
    FPT_OPEN.V.EXIST#= %OLDFILE#;
    DEBUG_OPTS= '0'B;
    DO J=0 TO %BLK2_NSUBLKS-1;
       BLK3$= %BLK2_SUBLK$(J);
       DEBUG_OPTS(%BLK3_CODE-%DEBUG_FID##)= %YES#;
       DO CASE( %BLK3_CODE );
          CASE( %DEBUG_FID## );
             IF %BLK4_CODE>=%ON## AND %BLK4_CODE<=%OVER## THEN DO;
                FPT_OPEN.V.EXIST#= %BLK4_CODE - %ON## + 1;
                BLK4$= %BLK3_SUBLK$(1);
                END;
             ELSE
                FPT_OPEN.V.EXIST#= %OLDFILE#; /* Extend (or create) the file  */
             DEBUG_FILE.LEN= %BLK4_COUNT;
             DEBUG_FILE.NAME#= %BLK4_TEXT;

          CASE( %DEBUG_ALL## );
             DO K=1 TO %DEBUG_WRITE##-%DEBUG_FID##;
                DEBUG_OPTS(K)= %YES#;
                END;

          CASE( %DEBUG_ERROR## );

          CASE( %DEBUG_MICRO## );

          CASE( %DEBUG_OFF## );
             CALL CLOSE_A_FILE( F$DEBUG# );
             GOTO RE_TURN;

          CASE( %DEBUG_ON## );

          CASE( %DEBUG_READ## );

          CASE( %DEBUG_RECEIVE## );

          CASE( %DEBUG_SEND## );

          CASE( %DEBUG_TIMEOUT## );

          CASE( %DEBUG_WRITE## );

          END;
       END;

    IF NOT F$DEBUG$->F$DCB.FCD# THEN DO;
       CALL OPEN_FID( F$DEBUG#,DEBUG_FILE.NAME#,DEBUG_FILE.LEN,FPT_OPEN )
                                                               WHENALTRETURN DO;
          DEBUG_FILE.LEN= LENGTHC('*DEBUG');
          DEBUG_FILE.NAME#= '*DEBUG';
          VEC1_= VECTOR(SUBSTR(DEBUG_FILE.NAME#,0,DEBUG_FILE.LEN));
          GOTO OOPS;
          END;
       END;

DO_DEBUG_SET_DEFAULTS: ENTRY;

    DEBUG_OPTS(0)= %NO#;
    IF DEBUG_OPTS = '0'B THEN
       DEBUG_OPTS(%DEBUG_MICRO##-%DEBUG_FID##)= %YES#;
    IF DEBUG_OPTS(%DEBUG_MICRO##-%DEBUG_FID##) THEN DO;
       DEBUG_OPTS(%DEBUG_ERROR##-%DEBUG_FID##)= %YES#;
       DEBUG_OPTS(%DEBUG_RECEIVE##-%DEBUG_FID##)= %YES#;
       DEBUG_OPTS(%DEBUG_SEND##-%DEBUG_FID##)= %YES#;
       DEBUG_OPTS(%DEBUG_TIMEOUT##-%DEBUG_FID##)= %YES#;
       END;

    VEC1_= VECTOR(SUBSTR(DEBUG_FILE.NAME#,0,DEBUG_FILE.LEN));
    IF F$DEBUG$->F$DCB.FCD# THEN              /* Is F$DEBUG OPEN?             */
       CALL POSITION_FILE( F$DEBUG#,DEBUG_KEY,DEBUG_FILE,WRITE_DEBUG )
                                              ALTRET( OOPS );

    CALL CONCAT( LO_BUF,'!',B$JIT.CCBUF );
    LEN= LENGTHC('!') + B$JIT.CCARS;
    CALL LOG( %DEBUG_INFO##,LO_BUF,LEN );

RE_TURN:
    RETURN;

OOPS:
    ERRDCB#= %ERRDCB;
    CALL XUR$ERRMSG( %MONERR,ERRDCB# );
ALT_RETURN:
    ALTRETURN;

END DO_DEBUG;
%EJECT;
/****
*
*   D O _ L O C A L _ C O M M A N D
*
*   Do whatever is needed to execute one of the LOCAL commands.  This usually
*   just means set up a command buffer to pass to PCL and let him do the work!
*
****/

DO_LOCAL_COMMAND: PROC  ALTRET;

    DO CASE( %BLK3_CODE );

       CASE( %LOCAL_COPY## );
          CALL CONCAT( CMD_BUF,'COPY ',%BLK4_TEXT );

       CASE( %LOCAL_CWD## );
          IF %BLK3_NSUBLKS > 0 THEN
             CALL CONCAT( CMD_BUF,'DIR .',%BLK4_TEXT );
          ELSE
             CALL CONCAT( CMD_BUF,'DIR' );

       CASE( %LOCAL_DELETE## );
          CALL CONCAT( CMD_BUF,'DEL ',%BLK4_TEXT );

       CASE( %LOCAL_DIR## );
          CALL CONCAT( CMD_BUF,'L ',%BLK4_TEXT );

       CASE( ELSE );
          GOTO RE_TURN;

       END;

    CALL M$YC( FPT_YC )  ALTRET( ALT_RETURN );

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END DO_LOCAL_COMMAND;
%EJECT;
/****
*
*   D O _ L O G
*
*   Do whatever is needed to take care of the new, possibly first, LOG command
*   they just issued.  If a previous LOG was in progress, CLOSE and SAVE it
*   and then process the latest one.
*
****/

DO_LOG: PROC  ALTRET;

    CALL CLOSE_A_FILE( F$LOG# );
    FPT_OPEN= DEFAULT_OPEN;
    FPT_OPEN.V.ACS#= %DIRECT#;
    FPT_OPEN.V.FUN#= %CREATE#;
    FPT_OPEN.V.EXIST#= %OLDFILE#;
    FPT_OPEN.V.ORG#= %KEYED#;
    IF %BLK2_NSUBLKS = 2 THEN DO; /* Was {ON|TO|OVER|INTO} specified?         */
       FPT_OPEN.V.EXIST#= %BLK3_CODE - %ON## + 1; /* Yep, use it!             */
       BLK3$= %BLK2_SUBLK$(1);
       END;
    IF %BLK3_TEXT = 'OFF'  OR  %BLK3_TEXT = 'off'  THEN
       GOTO RE_TURN;

    LOG_FILE.LEN= %BLK3_COUNT;
    LOG_FILE.NAME#= %BLK3_TEXT;
    VEC1_= VECTOR(SUBSTR(LOG_FILE.NAME#,0,LOG_FILE.LEN));
    CALL OPEN_FID( F$LOG#,LOG_FILE.NAME#,LOG_FILE.LEN,FPT_OPEN )
                                              WHENALTRETURN DO;
       LOG_FILE.LEN= LENGTHC('*KERMIT_LOG');
       LOG_FILE.NAME#= '*KERMIT_LOG';
       VEC1_= VECTOR(SUBSTR(LOG_FILE.NAME#,0,LOG_FILE.LEN));
       GOTO OOPS;
       END;
    CALL POSITION_FILE( F$LOG#,LOG_KEY,LOG_FILE,WRITE_LOG )  ALTRET( OOPS );
    WRITE_LOG.V.ONEWKEY#= %YES#;
    WRITE_LOG.V.NEWKEY#= %NO#;

RE_TURN:
    RETURN;

OOPS:
    ERRDCB#= %ERRDCB;
    CALL XUR$ERRMSG( %MONERR,ERRDCB# );
ALT_RETURN:
    ALTRETURN;

END DO_LOG;
%EJECT;
/****
*
*   D O _ R E A D
*
*   They issued a READ command (READ subsequent KERMIT commands from another
*   file).  Check to make sure they aren't issuing the READ from within a READ
*   file.  If so, bitch and ignore it.  Otherwise, OPEN the READ file and then
*   tell XUR$GETCMD that we switched DCBs.
*
****/

DO_READ: PROC  ALTRET;

    IF SI_DCB# = DCBNUM(M$SI2) THEN DO;       /* Are we already READing?      */
       CALL PUT( '.. Sorry, you can''t nest READ commands; this one ignored.\');
       END;
    ELSE DO;
       X= %BLK3_COUNT;
       CALL OPEN_FID( DCBNUM(M$SI2),%BLK3_TEXT,X )  ALTRET( OOPS );
       SI_DCB#= DCBNUM(M$SI2);                /* Remember where we're READing */
       CALL XUR$SETDCBS( SI_DCB# );           /* Tell XUR too                 */
       END;
RE_TURN:
    RETURN;

OOPS:
    ERRDCB#= %ERRDCB;
    CALL XUR$ERRMSG( %MONERR,ERRDCB# );
ALT_RETURN:
    ALTRETURN;

END DO_READ;
%EJECT;
/****
*
*   D O _ W E _ W A N T _ T H I S _ F I L E
*
*   See if the file name in CUR_FILE matches the one in TARGET.  If it does,
*   then RETURN else ALTRETURN.
*
****/

DO_WE_WANT_THIS_FILE: PROC  ALTRET;

    IF NOT TEST_OPEN_IO.V.OPER.NXTF# THEN
       OK_TO_SEND= %NO#;

    IF ERRCODE = '0'B THEN DO;
%IF OS_VERSION='B03';
       WILD_COMPARE.INPUT$= ADDR(CUR_FILE);
%ELSE;
       WILD_COMPARE.INPUT_= VECTOR(SUBSTR(CUR_FILE.NAME#,0,CUR_FILE.L#));
%ENDIF;
       CALL X$WILDCMP( WILD_COMPARE )     ALTRET( TIME_TO_QUIT );
       DO WHILE('0'B);
TIME_TO_QUIT:
          IF TARGET_WILD_POS > 0  AND
             SUBSTR(TARGET.NAME#,0,TARGET_WILD_POS) ~=
             SUBSTR(CUR_FILE.NAME#,0,TARGET_WILD_POS)  THEN DO;
             OK_TO_SEND= %NO#;
             END;
          GOTO ALT_RETURN;
          END;
       END;
    ELSE DO;
       IF NOT IM_A_SERVER THEN
          CALL XUR$ERRMSG( ERRCODE,ERRDCB# );
       ELSE DO;
          CALL WRITE_LOG_REC( %LOG_HEADER# );
          CALL SEND_ERROR_PACKET;
          END;
       OK_TO_SEND= %NO#;
       GOTO ALT_RETURN;
       END;
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END DO_WE_WANT_THIS_FILE;
%EJECT;
/****
*
*   E X P A N D
*
*   Expand a data segment.  VEC_ is a vector framing the segment that is to be
*   expanded by NUM_BYTES bytes.  If VEC_ = VECTOR(NIL) then the next
*   available data segment will be used.
*
****/

EXPAND: PROC( VEC_,NUM_BYTES,BUFSIZ )  ALTRET;
%VLP_VECTOR  (FPTN                     = VEC_,
              STCLASS=);
DCL NUM_BYTES                UBIN;
DCL BUFSIZ                   UBIN;

    GDS.V.SEGSIZE#= NUM_BYTES/4;
    GDS.RESULTS_= VECTOR(VEC_);
    CALL M$GDS( GDS )  ALTRET( ALT_RETURN );
    SUBSTR(VEC_.PTR$->IO_BUF,VEC_.W1.VSIZE#+1-NUM_BYTES,NUM_BYTES)= ' ';
    BUFSIZ= VEC_.W1.VSIZE#+1;
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END EXPAND;
%EJECT;
/****
*
*   F I X _ C P 6 _ F I L E _ N A M E
*
*   Fix up any file names based upon the settings of SET FILE NAMES and SET
*   FILE CP6 FIDS.
*
****/

FIX_CP6_FILE_NAME: PROC( NAME,LEN,DIRECTION );
DCL NAME                     CHAR(LEN);
DCL LEN                      UBIN;
DCL DIRECTION                UBIN;

    IF SET_FILE_NAMES = %SET_FILE_NAMES_LC## THEN
       DO X=0 TO LEN-1;
          CHR= SUBSTR(NAME,X,1);
          IF CHR>='A'  AND  CHR<='Z'  THEN
             SUBSTR(NAME,X,1)= BINASC(ASCBIN(CHR)+32);     /* Make it LC      */
          END;
    ELSE
       IF SET_FILE_NAMES = %SET_FILE_NAMES_UC## THEN
          DO X=0 TO LEN-1;
             CHR= SUBSTR(NAME,X,1);
             IF CHR>='a'  AND  CHR<='z'  THEN
                SUBSTR(NAME,X,1)= BINASC(ASCBIN(CHR)-32); /* Make it UC       */
             END;

    IF SET_FILE_CP6_FIDS = %SET_FILE_CP6_FIDS_NO## THEN DO;
       X= 0;
       IF LEN>1  AND  SUBSTR(NAME,LEN-1,1)='.' THEN
          LEN= LEN - 1;                       /* Ignore trailing period */
       DO WHILE( '1'B );
          CALL SEARCH( X,TMP1,BAD_FID_CHARS,NAME,X )  ALTRET( FID_IS_OK_NOW );
          SUBSTR(NAME,X,1)= SET_FILE_REPLACEMENT; /* Change character         */
          X= X + 1;                           /* Skip to next character       */
          END;
FID_IS_OK_NOW:
       END;

    IF DIRECTION ~= %SEND##  AND
       SET_FILE_PREFIX.LEN > 0 THEN DO;/* Should we add a prefix?             */
       STR1= NAME;
       CALL INDEX( X,'/',NAME );
       IF X = LENGTHC(NAME) THEN DO;
          CALL CONCAT( STR1,SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN),
                            NAME );
          LEN= LEN + SET_FILE_PREFIX.LEN;
          NAME= STR1;
          END;
       ELSE DO;
          CALL CONCAT( STR1,SUBSTR(NAME,0,X+1),
                            SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN),
                            SUBSTR(NAME,X+1) );
          LEN= LEN + SET_FILE_PREFIX.LEN;
          NAME= STR1;
          END;
       END;

RE_TURN:
    RETURN;

END FIX_CP6_FILE_NAME;
%EJECT;
/****
*
*   F I X _ P C _ F I L E _ N A M E
*
*   Attempt to determine if the file name being passed to the PC has an
*   extension in it and if so, change the delimiter that separates the file
*   name from the extension to a period.
*
****/

FIX_PC_FILE_NAME: PROC( NAME,LEN );
DCL NAME                     CHAR(LEN);
DCL LEN                      UBIN;

DCL I                        SBIN;


    /*
       If the SET FILE PREFIX has been specified, look for it on the file name.
       If found, remove it and continue.
    */
    IF SET_FILE_PREFIX.LEN > 0  AND
       LEN > SET_FILE_PREFIX.LEN  AND
       SUBSTR(NAME,0,SET_FILE_PREFIX.LEN) =
                     SUBSTR(SET_FILE_PREFIX.TEXT,0,SET_FILE_PREFIX.LEN) THEN DO;
       NAME= SUBSTR(NAME,SET_FILE_PREFIX.LEN);
       LEN= LEN - SET_FILE_PREFIX.LEN;
       END;
    ELSE
       /*
          Strip off pseudo subdirectory names if they requested it.
       */
       IF SET_FILE_SUBDIRECTORY = %SET_FILE_SUBDIRECTORY_ON## THEN DO;
          CALL INDEX1R(SET_FILE_SUBDIRECTORY_INDEX,SET_FILE_SUBDIRECTORY_CHAR,NAME,1)
               ALTRET( NO_SUBDIRECTORY_FOUND );
          NAME= SUBSTR(NAME,SET_FILE_SUBDIRECTORY_INDEX+1);
          LEN= LEN - SET_FILE_SUBDIRECTORY_INDEX - 1;
NO_SUBDIRECTORY_FOUND:
          END; /* Check for subdirectory */

    IF SET_FILE_PC_EXTENSIONS = %SET_FILE_PC_EXTENSIONS_YES## THEN DO;
       DO I=LEN-1 DOWNTO MAXIMUM(0,LEN-4) BY -1;
          IF SUBSTR(NAME,I,1) = SET_FILE_REPLACEMENT   OR
             SUBSTR(NAME,I,1) = '-'                   THEN DO;
             SUBSTR(NAME,I,1)= '.';
             EXIT;
             END;
          END;
       END;

RE_TURN:
    RETURN;

END FIX_PC_FILE_NAME;
%EJECT;
/****
*
*   F L U S H _ I N P U T ( aka FLUSHINPUT )
*
*   Dump all pending input to clear stacked up NACK's.
*
****/

FLUSH_INPUT: PROC;

    CALL M$TRMPRG( PURGE_TYPEAHEAD );
RE_TURN:
    RETURN;

END FLUSH_INPUT;
%EJECT;
/****
*
*   G E T _ A _ C M D
*
*   Get a command.  If we have previously parsed a line of them, then just
*   pick up the next one to be processed.  If none are left to process then
*   get another line/record of commands.
*
****/

GET_A_CMD: PROC( CMD,CMD_LEN )  ALTRET;
DCL CMD                      CHAR(CMD_LEN);
DCL CMD_LEN                  UBIN;

    CMD_NUM= CMD_NUM + 1;                     /* Point to next command        */
    IF CMD_NUM >= NUM_CMDS THEN               /* Anything left?               */
       IF CMD_NUM >= 9999 OR ADDR(CMD) = ADDR(NIL) THEN DO;/* Nope. Get more. */
          CMD_NUM= 0;                         /* Set number of commands to 0  */
          CALL SET_TIMEOUT( 0 );
          IF ADDR(CMD) = ADDR(NIL) THEN DO;   /* Get commands from user?      */
             CALL XUR$GETCMD( KERMIT_NODES,BLK1$,PROMPT ) ALTRET( OOPS );
             END;
          ELSE                                /* Else: parse what was passed  */
             CALL XUR$GETCMD( KERMIT_NODES,BLK1$, ,CMD,CMD_LEN ) ALTRET( OOPS );
          LEN= P_PCB.NCHARS;
          CALL LOG( %DEBUG_COMMAND##,STRNG,LEN );
          IF (NOT SILENT_MODE) AND (ADDR(CMD) = ADDR(NIL)) THEN
             CALL XUR$ECHOIF( M$LO# );
          IF BLK1$ = ADDR(NIL) THEN        /* Was command done by XUR$GETCMD? */
             GOTO DONE_FOR_NOW;
          ELSE
             NUM_CMDS= %BLK1_NSUBLKS;         /* Remember number of commands  */
          END;
       ELSE DO;
DONE_FOR_NOW:
          DONE_PARSING= %YES#;                /* Indicate we are done parsing */
          GOTO RE_TURN;
          END;
    BLK2$= %BLK1_SUBLK$(CMD_NUM);             /* Set up some PTRs to the PCB  */
    IF %BLK2_NSUBLKS > 0 THEN DO;
       BLK3$= %BLK2_SUBLK$(0);
       IF %BLK3_NSUBLKS > 0 THEN
          BLK4$= %BLK3_SUBLK$(0);
       END;
    CMD#= %BLK2_CODE;                         /* Remember the command we're on*/
RE_TURN:
    RETURN;

OOPS:                                         /* The label says it all!       */
    NUM_CMDS= 0;
    ERRCODE= PERRCODE;                        /* Load the error code returned */
    ERRDCB#= SI_DCB#;
ALT_RETURN:
    ALTRETURN;                                /* by XUR$GETCMD, then ALTRETURN*/

END GET_A_CMD;
%EJECT;
/****
*
*   G E T _ C H A R _ F R O M _ F I L E
*
*   Get another byte from the file that we are sending to the other computer.
*   The handling of repeated characters is also taken care of in here (kind
*   of).
*
****/

GET_CHAR_FROM_FILE: PROC  ALTRET;

GET_NEXT_CHAR:
    IO_INDX= IO_INDX + 1;                     /* Point to next input byte     */
    IF IO_INDX >= ARS THEN DO;                /* Past end of record?          */
       IF REC_CNT > 0  AND                    /* Any records already been read*/
          CUR_MODE = %SET_FILE_MODE_TEXT## THEN DO;
          IF REPEAT_CNT > 0 THEN DO;    /* Any repeated sequence in progress? */
             CALL BUILD_REPEAT_SEQUENCE  WHENALTRETURN DO;
                NEXT_CALL= %BUILD_SEQUENCE#;
                GOTO ALT_RETURN;
                END;
             END;
          CALL INSERT_EOR_CHARS( DATA_BUF,SIZE )  ALTRET( ALT_RETURN );
          END;
READ_AGAIN:
       CALL XSA$READ( READ_IN,XSA_PARAM )  ALTRET( EOF_HIT );
       REC_CNT= REC_CNT + 1;
       ARS= XSA_PARAM.ARS#;
       FILE_BYTE_CNT= FILE_BYTE_CNT + ARS + 2;
       CALL LOG( %DEBUG_READ##,IO_BUF,ARS );
       IO_INDX= 0;
       IF ARS <= 0 THEN                       /* If null record, go insert    */
          GOTO GET_NEXT_CHAR;                 /* EOR characters and read agn  */
       END;

    DO WHILE('0'B);
EOF_HIT:
       ERRCODE= XSA_PARAM.ERR;
       IF ERRCODE.ERR# = %E$EOF THEN DO;
          IF REPEAT_CNT > 0 THEN
             CALL BUILD_REPEAT_SEQUENCE  WHENALTRETURN DO;
                NEXT_CALL= %BUILD_SEQUENCE#;
                GOTO ALT_RETURN;
                END;
          AT_EOF= %YES#;
          GOTO ALT_RETURN;
          END;
       ELSE
          IF ERRCODE.ERR# = %E$LD THEN DO;    /* Lost Data?                   */
             CALL EXPAND( IO_,IO_BUF_SIZE,IO_BUF_SIZE )  ALTRET( NO_MEM );
             READ_IN.BUF_= IO_;
             BACKUP1.KEY_= VECTOR(NIL);
             BACKUP1.V.DCB#= DCBNUM(F$IN);
             BACKUP1.V.KEYR#= %NO#;
             CALL XSA$PRECORD( BACKUP1,XSA_PARAM )  WHENALTRETURN DO;
                ERRCODE= XSA_PARAM.ERR;
                IF ERRCODE.ERR# ~= %E$BOF THEN/*Did we try to BACKUP past BOF?*/
                   GOTO OH_DEAR;             /* Nope, go report the error.    */
                END;
             GOTO READ_AGAIN;
             END;
          ELSE DO;
OH_DEAR:
             CALL SEND_ERROR_PACKET;
             DO WHILE('0'B);
NO_MEM:
                CALL SEND_ERROR_PACKET( NO_MEM_FOR_IO_BUF,LENGTHC(NO_MEM_FOR_IO_BUF) );
                END;
             STATE= %A_ABORT;
ALT_RETURN:
             ALTRETURN;
             END;
       END;

RE_TURN:
    RETURN;

END GET_CHAR_FROM_FILE;
%EJECT;
/****
*
*   G E T _ D E F A U L T S
*
*   Read any default commands from the default file, :KERMIT_INI.  If no such
*   file exists, just RETURN.
*
****/

GET_DEFAULTS: PROC  ALTRET;

    FILE_CNT= 1;                              /* Start with current FMA       */

    DO WHILE( '0'B );
GET_ERR:
       ERRCODE= %MONERR;
       ERRDCB#= %ERRDCB;
       CALL INDEX( L,'.',DEFAULT.NAME );
       IF (ERRCODE.ERR# = %E$NOFILE)  AND  NOT F$DEFAULTS$->F$DCB.AMR#  THEN DO;
          FILE_CNT= FILE_CNT + 1;
          CALL INDEX( L,'.',DEFAULT.NAME );
          IF L >= LENGTHC(DEFAULT.NAME) THEN
             CALL INDEX( L,' ',DEFAULT.NAME );
          DO CASE( FILE_CNT );
             CASE( 1 );                       /* Current File Management Acct */

             CASE( 2 );                       /* Try logon account            */
                IF B$JIT.FACCN = B$JIT.ACCN THEN
                   GOTO TRY_LIBRARY_ACCT;
                CALL INSERT( DEFAULT.NAME,L,,'.',B$JIT.ACCN );
             CASE( 3 );                       /* As last resort, try :LIBRARY */
TRY_LIBRARY_ACCT:
                CALL INSERT( DEFAULT.NAME,L,,'.:LIBRARY' );
             CASE( ELSE );
                GOTO CHECK_ERR;
             END;
          CALL INDEX( DEFAULT.LEN,'  ',DEFAULT.NAME );
          END;
       END;

OPEN_IT:
    IF F$DEFAULTS$->F$DCB.AMR# AND F$DEFAULTS$->F$DCB.ASN# ~= %DEVICE# THEN DO;
       CALL OPEN_FID( F$DEFAULTS#,' ',0 )  ALTRET( GET_ERR );
       DEFAULT.LEN= LENGTHC(DEFAULT.NAME);
       CALL UNFID( F$DEFAULTS#,DEFAULT.NAME,DEFAULT.LEN )  ALTRET( GET_ERR );
       END;
    ELSE
       CALL OPEN_FID( F$DEFAULTS#,DEFAULT.NAME,DEFAULT.LEN )  ALTRET( GET_ERR );

    CALL PUT( ' \' );

    OFFSET= 0;
    IF PROMPTING THEN DO;
       CALL CONCAT( PROMPT.NAME#,SUBSTR(DEFAULT.NAME,0,DEFAULT.LEN),' Cmd> ' );
       PROMPT.VFC#= %NO#;
       PROMPT.L#= DEFAULT.LEN + LENGTHC(' Cmd> ');
       END;
    CALL XUR$INIT( XUR_INIT )  ALTRET( GET_ERR );
    SI_DCB#= F$DEFAULTS#;
    CALL XUR$SETDCBS( SI_DCB# );
    NUM_CMDS= 0;                            /* Force a READ from default file */
    DO WHILE( NOT DONE );
       CALL DO_1_LINE_OF_OPTIONS  ALTRET( RESET_DCBS );
       END;

RESET_DCBS:
    CALL PUT( ' \' );
    CALL CLOSE_A_FILE( F$DEFAULTS# );
    IF PROMPTING THEN DO;
       PROMPT.VFC#= %NO#;
       PROMPT.L#= LENGTHC('CP-6 Kermit> ');
       PROMPT.NAME#= 'CP-6 Kermit> ';
       END;
    ELSE DO;
       PROMPT.VFC#= %YES#;
       PROMPT.L#= LENGTHC('@');
       PROMPT.NAME#= '@';
       END;
    CALL XUR$INIT( XUR_INIT )  ALTRET( GET_ERR );
    SI_DCB#= DCBNUM(M$SI);
    CALL XUR$SETDCBS( SI_DCB#,M$LO# );

CHECK_ERR:
    IF (ERRCODE.ERR# = %E$NOFILE AND NOT F$DEFAULTS$->F$DCB.AMR#)  OR
       (ERRCODE.ERR# = %E$EOF)  OR
       (DONE)  THEN
RE_TURN:
       RETURN;
    ELSE
       CALL XUR$ERRMSG( ERRCODE,ERRDCB# );
ALT_RETURN:
    ALTRETURN;

END GET_DEFAULTS;
%EJECT;
/****
*
*   G E T _ F I D _ F R O M _ P A C K E T
*
*   Get a fid from the packet.  The main reason this is a separate subroutine
*   is to handle repeated characters that may be in the fid.  Sigh!
*
****/

GET_FID_FROM_PACKET: PROC( SRCE_FID,SRCE_LEN,DEST_FID,DEST_LEN );
DCL SRCE_FID                 CHAR(SRCE_LEN);
DCL SRCE_LEN                 UBIN;
DCL DEST_FID                 CHAR(80);
DCL DEST_LEN                 UBIN;

    PACKET_FID= ' ';
    DEST_LEN= 0;
    I= 0;
    DO WHILE( I < SRCE_LEN  OR  REPEAT_CNT > 0 );
       CALL GET_PACKET_CHAR( SRCE_FID,I );
       CALL STUFF( DEST_FID,DEST_LEN )  ALTRET( RE_TURN );
       END;

RE_TURN:
    RETURN;

END GET_FID_FROM_PACKET;
%EJECT;
/****
*
*   G E T _ P A C K E T _ C H A R
*
*   Get another character from the packet.  If a repeated sequence is in
*   progress, simply decrement the repeat count and return the repeated
*   character.  Otherwise, point to the next byte in the packet and return it.
*
****/

GET_PACKET_CHAR: PROC( BUF,INDX );
DCL BUF                      CHAR(INDX);
DCL INDX                     UBIN;

    IF REPEAT_CNT > 0 THEN DO;                /* Any repeat in progress?      */
       REPEAT_CNT= REPEAT_CNT - 1;         /* Just decrement count and return */
       GOTO RE_TURN;
       END;

    CHR= SUBSTR(BUF,INDX,1);                  /* Get next character           */
    CHR7_BIT= CHR_BIT & '177'O;               /* Leave only low order 7 bits  */
    INDX= INDX + 1;

    IF REPEATING  AND  CHR7 = MY.REPT  THEN DO; /* Is it a REPeaT character?  */
       CHR= SUBSTR(BUF,INDX,1);               /* Yep, get next byte           */
       CHR7_BIT= CHR_BIT & '177'O;
       INDX= INDX + 1;                        /* Point to next byte           */
       CALL UNCHAR( ,CHR7,REPEAT_CNT );       /* Make repeat count useable    */
       REPEAT_CNT= REPEAT_CNT - 1;            /* Don't count the first time   */

       CHR= SUBSTR(BUF,INDX,1);               /* Get byte after repeat count  */
       CHR7_BIT= CHR_BIT & '177'O;
       INDX= INDX + 1;

       END;

    BIN_MASK= '000'O;                         /* Assume binary mask of zero   */
    IF BINARY_QUOTING  AND  CHR7 = MY.QBIN THEN DO; /* Is IT qbin?            */
       BIN_MASK= '200'O;                      /* Remember the 8th bit         */
       CHR= SUBSTR(BUF,INDX,1);               /* Get byte after QBIN          */
       CHR7_BIT= CHR_BIT & '177'O;
       INDX= INDX + 1;                        /* Point to next byte           */
       END;

    IF CHR7 = MY.QUOTE THEN DO;               /* Is it the QUOTE character?   */
       CHR= SUBSTR(BUF,INDX,1);               /* get byte after the QUOTE char*/
       CHR7_BIT= CHR_BIT & '177'O;
       INDX= INDX + 1;                        /* Point to next byte           */
       IF (CHR7 = MY.QUOTE)  OR               /* If it's the QUOTE            */
          (BINARY_QUOTING  AND  CHR7 = MY.QBIN)  OR
          (REPEATING  AND  CHR7 = MY.REPT)  THEN /* or the .REPT char         */
          ;                                   /* Don't CTL it                 */
       ELSE
          CALL CTL( CHR,CHR );                /* else, CTL it                 */
       END;

    CHR_BIT= CHR_BIT | BIN_MASK;              /* OR in the 8th bit            */
RE_TURN:
    RETURN;

END GET_PACKET_CHAR;
%EJECT;
/****
*
*
*    Set the activation character set and timeout.
*
****/

INIT_ACTIVATION: PROC ALTRET;

IF NOT GOT_TRMCTL THEN DO;
       CALL M$GTRMCTL( ORIG_TRMCTL )      ALTRET( ALT_RETURN );
       CALL M$STRMCTL( STRMCTL )          ALTRET( ALT_RETURN );
       CALL SET_PARITY_MASK('Y');
       GOT_TRMCTL = %YES#;
       END;
    RETURN;
ALT_RETURN:
    ALTRETURN;
END INIT_ACTIVATION;
%EJECT;

/****
*
*   I N I T I A L I Z E
*
*   Initialize various things that can't be at compile time.
*
****/

INITIALIZE: PROC  ALTRET;

    F$DEFAULTS$= DCBADDR(DCBNUM(F$DEFAULTS)); /* Set up pointers to some DCBs */
    F$DEBUG$= DCBADDR(F$DEBUG#);
    F$LOG$= DCBADDR(DCBNUM(F$LOG));
    F$IN$= DCBADDR(DCBNUM(F$IN));
    F$OUT$= DCBADDR(DCBNUM(F$OUT));
    F$PACKET_IN$= DCBADDR(DCBNUM(F$PACKET_IN));
    F$PACKET_OUT$= DCBADDR(DCBNUM(F$PACKET_OUT));
    M$LO$= DCBADDR(DCBNUM(M$LO));
    M$SI$= DCBADDR(DCBNUM(M$SI));

    PROMPT.VFC#= %NO#;
    PROMPT.L#= LENGTHC('CP-6 Kermit> ');
    PROMPT.NAME#= 'CP-6 Kermit> ';

    CALL XUR$INIT( XUR_INIT )  ALTRET( ALT_RETURN );
    CALL XUR$SETDCBS( SI_DCB#,M$LO# );

/*  CALL M$INT( BREAK_CNTRL )  ALTRET( ALT_RETURN ); */

/**/
/* Initialize various limits and constants */
/**/
    PROTOCOL.MAX_INITIAL_RETRIES= 10;
    PROTOCOL.MAX_PACKET_RETRIES=  10;
    PROTOCOL.SYNCHR= BITASC('001'O);          /* SOH */

    DONE= %NO#;                               /* Assume we aren't DONE yet!   */
    GREETING= %YES#;                          /* Assume we will greet them    */
    NO_DEFAULTS= %NO#;                        /* Assume they want defaults    */
    PROMPTING= %YES#;                         /* Assume we will prompt also   */
    SILENT_MODE= %NO#;                        /* Assume we'll "tell all"!     */
    CG_MODE = %NO#;
    CG_SPECIFIED = %NO#;
    STATION_SPECIFIED = %NO#;


/**/
/* Initialize various things in auto */
/**/
    DEBUG_OPTS= '0'B;
    IF F$DEBUG$->F$DCB.AMR# THEN DO;          /* Is F$DEBUG SET externally?   */
       DEBUG_OPTS(%DEBUG_INFO##-%DEBUG_FID##)= %YES#; /* Turn INFO on         */
       FPT_OPEN= DEFAULT_OPEN;
       FPT_OPEN.V.ASN#= %FILE#;               /* Assume it's a FILE           */
       FPT_OPEN.V.FUN#= %CREATE#;             /* FUNction of CREATE           */
       CALL OPEN_FID( F$DEBUG#,' ',0,FPT_OPEN )  ALTRET( ALT_RETURN );
       CALL UNFID( F$DEBUG#,DEBUG_FILE.NAME#,DEBUG_FILE.LEN )
                                                 ALTRET( ALT_RETURN );
       END;

    CALL DO_DEBUG_SET_DEFAULTS;

/**/
/* Get buffer for reading/writing the transferred file. */
/**/
    IO_= VECTOR(NIL);
    CALL EXPAND( IO_,4096,IO_BUF_SIZE )  ALTRET( ALT_RETURN ); /* 1 K         */
    WRITE_OUT.BUF_= IO_;
    READ_IN.BUF_= IO_;
    XSA_PARAM.BBUF_= VECTOR(BBUF);
    XSA_PARAM.KBUF_= VECTOR(KBUF);

    PACKET_= VECTOR(NIL);
    CALL EXPAND( PACKET_,4096,PACKET_MAX_SIZE )  ALTRET( ALT_RETURN );
    DATA_= VECTOR(NIL);
    CALL EXPAND( DATA_,4096,DATA_MAX_SIZE )      ALTRET( ALT_RETURN );
    READ_PACKET.BUF_= PACKET_;
    WRITE_PACKET.BUF_= PACKET_;
    SIZE= 0;
    EOR_BYTE(0) = %CR;
    EOR_BYTE(1) = %LF;
    EOR_BYTE_LEN= LENGTHC(EOR_BYTE(0)) + LENGTHC(EOR_BYTE(1));
    CALL STUFF_CHAR_IN_PACKET( EOR_BYTE(0) );
    CALL STUFF_CHAR_IN_PACKET( EOR_BYTE(1) );
    EOR_CHARS= SUBSTR(DATA_BUF,0,SIZE);
    EOR_CHARS_LEN= SIZE;
    REPEAT_CNT= 0;

/**/
/* Initialize SET FILE BINARY EXTENSIONS */
/**/
    EXTEN.LEN(0) = LENGTHC('?_ARC');
    EXTEN.TEXT(0)=         '?_ARC';
    EXTEN.LEN(1) = LENGTHC('?-ARC');
    EXTEN.TEXT(1)=         '?-ARC';
    EXTEN.LEN(2) = LENGTHC('?_COM');
    EXTEN.TEXT(2)=         '?_COM';
    EXTEN.LEN(3) = LENGTHC('?-COM');
    EXTEN.TEXT(3)=         '?-COM';
    EXTEN.LEN(4) = LENGTHC('?_EXE');
    EXTEN.TEXT(4)=         '?_EXE';
    EXTEN.LEN(5) = LENGTHC('?-EXE');
    EXTEN.TEXT(5)=         '?-EXE';
    EXTEN.LEN(6) = LENGTHC('?_LIB');
    EXTEN.TEXT(6)=         '?_LIB';
    EXTEN.LEN(7) = LENGTHC('?-LIB');
    EXTEN.TEXT(7)=         '?-LIB';
    NUM_EXTENSIONS= 8;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END INITIALIZE;
%EJECT;
/****
*
*   I N S E R T _ E O R _ C H A R S
*
*   Insert the End Of Record sequence needed for the packet.  This is
*   currently always #M#J which is a CR,LF.
*
****/

INSERT_EOR_CHARS: PROC(BUF,SIZE)  ALTRET;
DCL BUF                      CHAR(SIZE);
DCL SIZE                     UBIN;

    IF SIZE + EOR_CHARS_LEN > THEIR.PACKET_LENGTH-3 THEN/* Is there room?     */
       GOTO ALT_RETURN;                           /* Nope, don't bother       */

    IF CUR_MODE = %SET_FILE_MODE_TEXT## THEN      /* Are we in TEXT mode?     */
       DO X=0 TO EOR_CHARS_LEN-1;       /* Yep, send end of line character(s) */
          SUBSTR(BUF,SIZE,1)= SUBSTR(EOR_CHARS,X,1);
          SIZE= SIZE + 1;
          END;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END INSERT_EOR_CHARS;
%EJECT;
/****
*
*   L O G
*
*   Write a record to the DEBUG file.  REC_TYPE indicates which type of record
*   it is.
*
****/

LOG: PROC( REC_TYPE,BUF,LEN );
DCL REC_TYPE                 SBIN;
DCL BUF                      CHAR(LEN);
DCL LEN                      UBIN;

DCL 1 REC,
      2 TYPE                 CHAR(4)   CALIGNED,
      2 HH_MM_SS_SS          CHAR(11)  CALIGNED,
      2 DATA                 CHAR(497) CALIGNED;

    IF DEBUG_OPTS(REC_TYPE-%DEBUG_FID##)  AND  F$DEBUG$->F$DCB.FCD# THEN DO;
       DEBUG_KEY.EDIT= DEBUG_KEY.EDIT + 1000;
       REC.TYPE= DEBUG_LABEL(REC_TYPE-%DEBUG_FID##);
       CALL M$TIME( GET_TIME );
       REC.HH_MM_SS_SS= HHMMSSSS;
       REC.DATA= SUBSTR(BUF,0,LEN);
       WRITE_DEBUG.BUF_= VECTOR(SUBSTR(REC.TYPE,0,LENGTHC(REC.TYPE)+LEN+
                                                  LENGTHC(REC.HH_MM_SS_SS)) );
       CALL M$WRITE( WRITE_DEBUG );
       END;

RE_TURN:
    RETURN;

END LOG;
%EJECT;
/****
*
*   M E R G E _ F I L E _ N A M E _ I N T O _ D C B
*
*   Merge the name in TARGET into the F$IN DCB for use on a subsequent "real"
*   OPEN (this is just a TEST OPEN).
*
****/

MERGE_FILE_NAME_INTO_DCB: PROC  ALTRET;

    TEST_OPEN_IO= DEFAULT_OPEN;
    TEST_OPEN_IO.V_= VECTOR(TEST_OPEN_IO.V);
    TEST_OPEN_IO.V.DCB#= DCBNUM(F$IN);
    TEST_OPEN_IO.V.FUN#= %IN#;                /* Make sure we open it input   */
    TEST_OPEN_IO.V.OPER.NXTF#= %YES#;         /* Assume more than one file    */
    TEST_OPEN_IO.V.OPER.TEST#= %YES#;
    TEST_OPEN_IO.V.ACS# = %SEQUEN#;
    TEST_OPEN_IO.V.SHARE# = %IN#;
    TEST_OPEN_IO.V.OPER.THISF#= %YES#;        /* Start with name in DCB       */
    CALL M$FID( FID_IO )  ALTRET( BAD_FID );  /* SRCE_FID -> TARGET           */
    IF TARGET.NAME# = ' ' THEN DO;
       TARGET.L#= LENGTHC('?');
       TARGET.NAME#= '?';
       END;
    CALL INDEX( TARGET_WILD_POS,'?',TARGET.NAME# );
    IO_NAME= TARGET;
    IF TARGET_WILD_POS = 0 THEN DO;           /* If leading ? then            */
       IO_NAME.L#= 0;                        /* we must search entire account */
       IO_NAME.NAME#= ' ';
       END;
    ELSE
       IF TARGET_WILD_POS < LENGTHC(IO_NAME.NAME#) THEN DO;/* If wildcarded   */
          IO_NAME.L#= TARGET_WILD_POS;        /* and ? is NOT first character */
          SUBSTR(IO_NAME.NAME#,TARGET_WILD_POS)= ' ';
          END;             /* then use characters up to ? as beginning prefix */
       ELSE
          TEST_OPEN_IO.V.OPER.NXTF#= %NO#;    /* Just one file                */

    CALL M$OPEN( MERGE_IN )  ALTRET( MERGE_ERR );/* Merge file name into F$IN */
RE_TURN:
    RETURN;

BAD_FID:
    CALL SEARCHR( L,X,SKIP_BLANKS,SRCE_FID )  WHENALTRETURN DO;
       L= LENGTHC(' ');
       END;
    CALL CONCAT( ERR_BUF,'File name passed to CP-6 (',
                         SUBSTR(SRCE_FID,0,L+1),
                         ') was not a valid CP-6 fid.' );
    CALL SEARCHR( L,X,SKIP_BLANKS,ERR_BUF );
    CALL SEND_ERROR_PACKET( ERR_BUF,L+1 );
    GOTO ALT_RETURN;

MERGE_ERR:
    CALL SEND_ERROR_PACKET;

ALT_RETURN:
    ALTRETURN;

END MERGE_FILE_NAME_INTO_DCB;
%EJECT;
/****
*
*   O P E N _ D E S T _ F I L E
*
*   OPEN the destination file; the one being RECEIVED by CP-6.  A record is
*   written to the LOG file (if one is OPEN) indicating that the transfer has
*   started.  If an error occurs, that too is recorded in the LOG file.
*
****/

OPEN_DEST_FILE: PROC  ALTRET;

    CALL WRITE_LOG_REC( %LOG_HEADER# );
    CP6_FID= ' ';
    CALL GET_FID_FROM_PACKET( PACKET.DATA_BUF,LEN,PACKET_FID,J );
    FILE_CNT= FILE_CNT + 1;
    IF FILE_CNT > 1  OR  SRCE_FID = ' '  OR  IM_A_SERVER  THEN DO;
       SRCE_FID= PACKET_FID;
       CALL FIX_CP6_FILE_NAME( SRCE_FID,J,%RECEIVE## );
       END;

    OPEN_IO.V.FUN#= %CREATE#;
    OPEN_IO.V.EXIST#= HOW_RECEIVE;
    OPEN_IO.V.DCB#= DCBNUM(F$OUT);
    CALL M$FID( FID_IO )  ALTRET( OOPS );
    IF SET_FILE_EDIT = %SET_FILE_EDIT_YES## THEN DO;/* Create EDIT keyed file?*/
       OPEN_IO.V.ORG#= %KEYED#;               /* yep.                         */
       WRITE_OUT.KEY_= VECTOR(OUT_KEY);
       OUT_KEY.LEN= LENGTHC(OUT_KEY.EDIT);
       OUT_KEY.EDIT= 0;
       END;
    ELSE DO;                                  /* Create a CONSEC file         */
       OPEN_IO.V.ORG#= %CONSEC#;
       WRITE_OUT.KEY_= VECTOR(NIL);
       END;
    CALL DETERMINE_RCVD_MODE;
    OPEN_IO.V.ACS#= %SEQUEN#;
    OPEN_IO.V.ASN#= %FILE#;
    OPEN_IO.V.CTG#= %NO#;
    OPEN_IO.V.RES#= MERGE_IN.V.RES#;
    OPEN_IO.V.SHARE#= %NONE#;
    OPEN_IO.ACCT_= VECTOR(IO_ACCT);
    OPEN_IO.NAME_= VECTOR(TARGET);
    OPEN_IO.PASS_= VECTOR(IO_PASS);
    OPEN_IO.SN_=   VECTOR(IO_SN);
    CALL XSA$OPEN( OPEN_IO,XSA_PARAM )  ALTRET( OOPS );
    IF TARGET.NAME# = PACKET_FID THEN  /* Does CP-6 NAME = one in the packet? */
       PACKET_FID= ' ';                       /* Yep, use CP-6 fid in LOG msgs*/
    CP6_FID_LEN= LENGTHC(CP6_FID);
    CALL UNFID( F$OUT#,CP6_FID,CP6_FID_LEN );
    CALL WRITE_LOG_REC( %LOG_STRT_RECEIVE# );
    CALL WRITE_LOG_REC( %LOG_MAX_PACKET_SIZES# );
    IO_CNT= 0;
    IO_LEN= 0;
    IO_BUF= ' ';
RE_TURN:
    RETURN;

OOPS:
    CALL SEND_ERROR_PACKET;
ALT_RETURN:
    ALTRETURN;

END OPEN_DEST_FILE;
%EJECT;
/****
*
*   O P E N _ F I D
*
*   Utility routine to OPEN DCB number DCB# to the file FID whose name is
*   FID_LEN bytes and the FPT to use on the OPEN is FPT_OPEN.  IF FID was
*   not passed, use the name currently in the DCB.  If FPT_OPEN was not
*   passed, use the DEFAULT_OPEN fpt.
*
****/

OPEN_FID: PROC( DCB#,FID,FID_LEN,OPEN_FPT )  ALTRET;
DCL DCB#                     UBIN;
DCL FID                      CHAR(FIDLEN);
DCL FID_LEN                  SBIN;
%FPT_OPEN    (FPTN                     = OPEN_FPT,
              STCLASS=" " );

DCL FIDLEN                   SBIN;

    IF ADDR(OPEN_FPT) = ADDR(NIL) THEN        /* Was an FPT passed?           */
       FPT_OPEN= DEFAULT_OPEN;                /* Nope, use default OPEN       */
    ELSE
       FPT_OPEN= OPEN_FPT;                    /* Yep, use it                  */
    FPT_OPEN.V_= VECTOR(FPT_OPEN.V);          /* Frame the V area in the FPT  */
    FPT_OPEN.V.DCB#= DCB#;                    /* Use their DCB#               */

    IF FID_LEN < 0 THEN DO;                   /* Should we find FID length?   */
       FIDLEN= -FID_LEN;                      /* Yep.                         */
       CALL SEARCHR( FIDLEN,X,SKIP_BLANKS,FID )  ALTRET( JUST_OPEN_IT );
       FIDLEN= FIDLEN + 1;
       END;
    ELSE
       FIDLEN= FID_LEN;                      /* Nope. They passed the FID_LEN */

    IF FID_LEN ~= 0 THEN DO;
       FPT_FID.V.SCRUB= '111111'B;
       FPT_FID.TEXTFID_= VECTOR(FID);
       CALL M$FID( FPT_FID )           ALTRET( ALT_RETURN );
       IF VLR_FID.NAME THEN                   /* Was NAME in FID?             */
          FPT_OPEN.NAME_= FPT_FID.NAME_;      /* Yep, use it on OPEN.         */
       ELSE
          FPT_OPEN.NAME_= VECTOR(NIL);        /* Nope.                        */
       IF VLR_FID.ACCT THEN                   /* Was ACCT in FID?             */
          FPT_OPEN.ACCT_= FPT_FID.ACCT_;      /* Yep, use it on the OPEN.     */
       ELSE
          FPT_OPEN.ACCT_= VECTOR(NIL);        /* Nope.                        */
       IF VLR_FID.PASS THEN                   /* Was PASSword in FID?         */
          FPT_OPEN.PASS_= FPT_FID.PASS_;      /* Yep, use it on the OPEN.     */
       ELSE
          FPT_OPEN.PASS_= VECTOR(NIL);        /* Nope.                        */
       IF VLR_FID.SN THEN                     /* Was an SN in the FID?        */
          FPT_OPEN.SN_= FPT_FID.SN_;          /* Yep, use it on the OPEN.     */
       ELSE
          FPT_OPEN.SN_= VECTOR(NIL);          /* Nope.                        */
       END;
JUST_OPEN_IT:
    CALL CLOSE_A_FILE( DCB# );                /* CLOSE the DCB, if it's OPEN  */
    IF DCB# = DCBNUM(F$IN)  OR  DCB# = DCBNUM(F$OUT)  THEN
       CALL XSA$OPEN( FPT_OPEN,XSA_PARAM )  ALTRET( ALT_RETURN );
    ELSE
       CALL M$OPEN( FPT_OPEN )              ALTRET( ALT_RETURN );
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END OPEN_FID;
%EJECT;
/****
*
*   O P E N _ N E X T _ F I L E
*
*   OPEN the next file.  If we can't, so indicate by ALTRETURNing.
*
****/

OPEN_NEXT_FILE: PROC  ALTRET;

    CALL M$OPEN( TEST_OPEN_IO )   ALTRET( NOT_OPENED ); /* OPEN [nxtf]        */
    CUR_FILE= F$IN$->F$DCB.NAME#;             /* Remember filename OPENed     */
    ERRCODE= '0'B;                            /* No error detected            */
    GOTO RE_TURN;

NOT_OPENED:
    CUR_FILE= F$IN$->F$DCB.NAME#;             /* Remember filename we tried   */
    ERRCODE= %MONERR;                         /* remember error code          */
    ERRDCB#= %ERRDCB;                         /* remember what DCB it was on  */
    IF ERRCODE.ERR# = %E$FDEOF THEN           /* End of File Directory?       */
ALT_RETURN:
       ALTRETURN;                             /* Yep!                         */
RE_TURN:
    RETURN;

END OPEN_NEXT_FILE;
%EJECT;
/****
*
*   OPEN the F$PACKET_IN and F$PACKET_OUT dcbs to the comgroup specified
*   in CG_FID. If either open fails, we close both dcbs and hope that
*   everything is still ok.
*
****/

OPEN_TO_CG: PROC;

    CALL CLOSE_A_FILE(DCBNUM(F$PACKET_IN));
    CALL M$FID(FID_CG);
    IF (CG_ASN=%FILE#) OR (CG_ASN=%COMGROUP#) THEN DO;
       CALL M$OPEN(OPEN_CG_IN) ALTRET(ALT_RETURN);
       CALL M$OPEN(OPEN_CG_OUT) ALTRET(ALT_RETURN);
       IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN);
       CG_MODE = %YES#;
       END;
     ELSE DO;
ALT_RETURN:
       CALL PUT('Sorry, that comgroup is not currently available\');
       CG_MODE = %NO#;
       CALL CLOSE_A_FILE(DCBNUM(F$PACKET_IN));
       CALL CLOSE_A_FILE(DCBNUM(F$PACKET_OUT));
       END;
END OPEN_TO_CG;
%EJECT;
/****
*
*   P A R S E _ C C B U F
*
*   See if any commands were passed in CCBUF (ie. on the invocation line).  If
*   so, parse them.  Then, note any options that are only legal on the
*   invocation line.  Then, read any commands from the default file
*   (:KERMIT_INI) unless the specified NO DEFAULTS.  Then perform any left
*   over options on the invocation line that have not already been taken care
*   of.
*
****/

PARSE_CCBUF: PROC  ALTRET;

    CCBUF_CMD= %NO#;
    IF B$JIT.CCDISP < B$JIT.CCARS  AND        /* Anything in CCBUF?           */
       SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP) ~= '('  AND
       SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP) ~= '()' THEN DO;
       OFFSET= LENGTHC('!') + B$JIT.CCDISP;
       CMD_BUF= SUBSTR(B$JIT.CCBUF,B$JIT.CCDISP+1);
       CMD_LEN= B$JIT.CCARS - B$JIT.CCDISP - 1;
       CMD_NUM= 9999;                       /* Force GET_A_CMD to look at CMD */
       NUM_CMDS= -1;
       CALL GET_A_CMD( CMD_BUF,CMD_LEN ) ALTRET(OOPS);/* Parse CCBUF commands */
       DO I=0 TO %BLK1_NSUBLKS-1;   /* Did they specify NO DEFAULTS in CCBUF? */
          IF %BLK1_SUBLK$(I)->P_SYM.CODE = %NO_DEFAULTS## THEN DO;
             IF %BLK1_NSUBLKS = 1 THEN        /* If ND is only CCBUF option,  */
                CCBUF_CMD= %NO#;          /* Get additional options from user */
             NO_DEFAULTS= %YES#;     /* They did, remember they did.          */
             END;
          ELSE
             IF %BLK1_SUBLK$(I)->P_SYM.CODE = %DONT_GREET## THEN
                GREETING= %NO#;               /* Remember not to greet them   */
             ELSE
                IF %BLK1_SUBLK$(I)->P_SYM.CODE = %DONT_PROMPT## THEN DO;
                   PROMPT.VFC#= %YES#;
                   PROMPT.L#= LENGTHC('@');
                   PROMPT.NAME#= '@';
                   PROMPTING= %NO#;
                   CALL XUR$INIT( XUR_INIT );
                   END;
                ELSE
                   IF %BLK1_SUBLK$(I)->P_SYM.CODE = %SILENT## THEN DO;
                      SILENT_MODE= %YES#;
%IF OS_VERSION~='B03';
                      XUR_INIT.ECHO#= %NEVER_ECHO#;
%ENDIF;
                      END;
                   ELSE
                      CCBUF_CMD= %YES#;
          END;
       IF GREETING THEN                       /* Did they want a greeting?    */
          CALL PUT( GREETING_MSG );           /* Yep, looks that way.         */
       IF NO_DEFAULTS THEN                    /* Did they say No DEFAULTS?    */
          GOTO SKIP_DEFAULTS;                 /* Yep, don't read them!        */
       CALL GET_DEFAULTS;                     /* Go read :KERMIT_INI file     */
       CMD_NUM= 9999;                       /* Force GET_A_CMD to look at CMD */
       NUM_CMDS= 0;
       CALL GET_A_CMD( CMD_BUF,CMD_LEN )  ALTRET( OOPS );
SKIP_DEFAULTS:
       CMD_NUM= -1;
       IF NOT DONE THEN                       /* If they aren't DONE already  */
          CALL DO_1_LINE_OF_OPTIONS( CMD_BUF,CMD_LEN );
       END;
    ELSE DO;
       CMD_NUM= 0;
       NUM_CMDS= 0;
       IF GREETING THEN                       /* Did they want a greeting?    */
          CALL PUT( GREETING_MSG );           /* Yep, looks that way!         */
       CALL GET_DEFAULTS;                     /* Go read :KERMIT_INI file     */
       END;
    OFFSET= 0;                           /* Set OFFSET for PUT_ERROR's finger */
    GOTO ARE_WE_DONE;

OOPS:
    CALL PUT_ERROR;                           /* Go give user the finger!     */
ARE_WE_DONE:
    IF CCBUF_CMD THEN
       DONE= %YES#;                           /* Quit now if cmd was in CCBUF */
RE_TURN:
    RETURN;

END PARSE_CCBUF;
%EJECT;
/****
*
*   P O S I T I O N _ F I L E
*
*   Position ourselves at the end of the indicated file (via DCB#).  If the
*   file is KEYED, return the KEY of the next record that will be written.
*
****/

POSITION_FILE: PROC( DCB#,KEY,NAME,FPT_WRITE )  ALTRET;
DCL DCB#                     UBIN;
DCL 1 KEY,
      2 LEN                  UBIN(9)   CALIGNED,
      2 EDIT                 UBIN(27)  CALIGNED,
      2 *                    CHAR(252) CALIGNED;
DCL 1 NAME,
      2 LEN                  UBIN,
      2 NAME#                CHAR(76);
%FPT_WRITE   (FPTN                     = FPT_WRITE,
              STCLASS=);

    F_FDS.DCB#= 0;                            /* Convince X$WRITE NOT to WRITE*/
    KEY.LEN= LENGTHC(KEY.EDIT);
    KEY.EDIT= 0;
    IF DCBADDR(DCB#)->F$DCB.ORG# = %KEYED# THEN DO;
       FPT_WRITE.KEY_= VECTOR(KEY);
       IF DCBADDR(DCB#)->F$DCB.FEXT THEN DO;
          IF DCBADDR(DCB#)->F$DCB.NRECS# > 0 THEN DO;
             PFIL_EOF.V.DCB#= DCB#;
             CALL M$PFIL( PFIL_EOF )  ALTRET( ALT_RETURN );
             BACKUP1.V.DCB#= DCB#;
             BACKUP1.V.KEYR#= %YES#;
             BACKUP1.KEY_= VECTOR(KEY);
             CALL M$PRECORD( BACKUP1 )  ALTRET( ALT_RETURN );
             IF KEY.LEN ~= LENGTHC(KEY.EDIT) THEN DO;
                CALL X$WRITE( F_FDS,FMT15_,VEC1_ );
                ME_BUF= LO_BUF;
                CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 );
                CALL CLOSE_A_FILE( DCB# );
                GOTO RE_TURN;
                END;
             ELSE
                IF KEY.EDIT >= 99999000 THEN DO;
                   CALL X$WRITE( F_FDS,FMT16_,VEC1_ );
                   ME_BUF= LO_BUF;
                   CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 );
                   CALL CLOSE_A_FILE( DCB# );
                   GOTO RE_TURN;
                   END;
             END;
          X= (KEY.EDIT/1000) + 1;
          CALL X$WRITE( F_FDS,FMT12_,VEC1_,VECTOR(X) );
          ME_BUF= LO_BUF;
          CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 );
          END;
       ELSE DO;
          CALL X$WRITE( F_FDS,FMT14_,VEC1_ );
          ME_BUF= LO_BUF;
          CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 );
          END;
       END;
    ELSE DO;
       FPT_WRITE.KEY_= VECTOR(NIL);
       CALL X$WRITE( F_FDS,FMT13_,VEC1_,VECTOR(DCBADDR(DCB#)->F$DCB.NRECS#) );
       ME_BUF= LO_BUF;
       CALL PUT( SUBSTR(ME_BUF,1,F_FDS.BUFX-1),F_FDS.BUFX-1 );
       END;

    F_FDS.DCB#= M$LO#;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END POSITION_FILE;
%EJECT;
/****
*
*   P R I N T _ E R R O R _ P A C K E T  ( aka PRERRPKT )
*
*   Print contents of error packet received from remote host.
*
****/

PRINT_ERROR_PACKET: PROC;

    CALL PUT('CP-6 KERMIT aborting with following error from remote KERMIT:\');
    CALL PUT( PACKET.DATA,LEN );
    STATE= %A_ABORT;
RE_TURN:
    RETURN;

END PRINT_ERROR_PACKET;
%EJECT;
/****
*
*   P U T
*
*   Output the passed message (the one in BUF) through DCB number DCB#.  If
*   LEN was not passed, then everything in BUF up to the first \ will be
*   printed.  If LEN is positive, it indicates the length of BUF.  If LEN is
*   negative then it indicates the maximum length of BUF.  In this case, BUF
*   is scanned from right to left (starting at the -LEN'th byte and working
*   left until a non blank is hit.  Everything from BUF upto and including the
*   non blank found will be printed.
*
****/

PUT: PROC( BUF,LEN,DCB#,WE_SHOULD_ECHO );
DCL BUF                      CHAR(BUFLEN);
DCL LEN                      SBIN;
DCL DCB#                     UBIN;
DCL WE_SHOULD_ECHO           BIT(1);

DCL BUFLEN                   SBIN;

    IF ADDR(LEN) = ADDR(NIL) THEN DO; /* Is BUF message delimited by a '\'? */
       BUFLEN= 132;
       CALL INDEX1( BUFLEN,'\',BUF );
       END;
    ELSE
       IF LEN < 0 THEN DO;                    /* Should we find BUF length?   */
          BUFLEN= -LEN;                       /* Yep.                         */
          CALL SEARCHR( BUFLEN,X,SKIP_BLANKS,BUF )  ALTRET( BLANK_LINE );
          BUFLEN= BUFLEN + 1;
          END;
       ELSE
          IF LEN = 0 THEN                     /* Empty buffer (blank line)?   */
BLANK_LINE:
             BUFLEN= LENGTHC(' ');            /* Just print a blank           */
          ELSE
             BUFLEN= LEN;                     /* Use the length they passed   */
    IF ADDR(DCB#) = ADDR(NIL) THEN DO;
       F_FDS.DCB#= DEFAULT_DCB#;
       END;
    ELSE DO;
       F_FDS.DCB#= DCB#;
       END;
    IF ADDR(WE_SHOULD_ECHO) ~= ADDR(NIL)  AND  WE_SHOULD_ECHO THEN DO;
       CALL X$WRITE( F_FDS,FMT_,VECTOR(BUF) );
       F_FDS.DCB#= DEFAULT_DCB#;              /* ECHO it to M$ME too.         */
       END;
    IF (NOT SILENT_MODE) OR (ADDR(DCB#) ~= ADDR(NIL)) THEN
       CALL X$WRITE( F_FDS,FMT_,VECTOR(BUF) );
RE_TURN:
    RETURN;

END PUT;
%EJECT;
/****
*
*   P U T _ C H A R _ I N _ P A C K E T
*
*   Insert CHR into the packet.  If CHR equals the previous character passed
*   to this routine then the REPEAT_CNT is just incremented.  Otherwise, the
*   previous character is put in the packet and CHR is put in PREV_CHR for the
*   next call.
*
****/

PUT_CHAR_IN_PACKET: PROC( CHR )  ALTRET;
DCL CHR                      CHAR(1);

    IF REPEATING THEN DO;                     /* Is repeating allowed?        */
       IF REPEAT_CNT > 0 THEN DO;             /* Anything in progress?        */
          IF CHR = PREV_CHR  AND  REPEAT_CNT < 94 THEN DO;
             REPEAT_CNT= REPEAT_CNT + 1;
             GOTO RE_TURN;
             END;
          CALL BUILD_REPEAT_SEQUENCE  WHENALTRETURN DO;
             NEXT_CALL= %PUT_CHAR_IN_PACKET#;
             CUR_CHR= CHR;
             GOTO ALT_RETURN;
             END;
          END;
       PREV_CHR= CHR;
       REPEAT_CNT= 1;
       END;
    ELSE DO;
       CALL CALC_SEQUENCE_LEN( CHR );
       IF SIZE+SEQUENCE_LEN > THEIR.PACKET_LENGTH-3 THEN DO;
          NEXT_CALL= %STUFF_CHAR_IN_PACKET#;
          CUR_CHR= CHR;
          GOTO ALT_RETURN;
          END;
       ELSE
          CALL STUFF_CHAR_IN_PACKET( CHR );
       END;

RE_TURN:
    RETURN;

ALT_RETURN:
       ALTRETURN;

END PUT_CHAR_IN_PACKET;
%EJECT;
/****
*
*   P U T _ E R R O R
*
*   Print out an error message.
*
****/

PUT_ERROR: PROC( FINGER_POS );
DCL FINGER_POS               SBIN;

    IF ERRCODE.ERR# = %E$SYNERR THEN DO;
       IF (ADDR(FINGER_POS) = ADDR(NIL))  AND  (NOT SILENT_MODE) THEN
          CALL XUR$ECHOIF( M$LO# );
       CALL XUR$ERRPTR( OFFSET+P_PCB.HI_CHAR,M$LO# );
    /* CALL PUT( '.. Syntax error; parsing stopped where indicated\' ); */
       END;
    ELSE
       CALL XUR$ERRMSG( ERRCODE,ERRDCB# );
RE_TURN:
    RETURN;

END PUT_ERROR;
%EJECT;
/****
*
*   R E C E I V E _ A _ F I L E  ( aka RECSW )
*
*   This is the state table switcher for receiving files.
*
****/

RECEIVE_A_FILE: PROC( INIT_STATE )  ALTRET;
DCL INIT_STATE               CHAR(1);

    NUM_TRIES= 0;
    STATE= INIT_STATE;

    DO WHILE( '1'B );
       DO SELECT( STATE );
          SELECT( %R_RINIT );
             CALL RECEIVE_INIT;
          SELECT( %F_FILE );
             CALL RECEIVE_FILE  ALTRET( RE_TURN );
          SELECT( %D_DATA );
             CALL RECEIVE_DATA;
          SELECT( %C_COMPLETE );
             GOTO RE_TURN;
          SELECT( %S_SINIT );
             GOTO RE_TURN;
          SELECT( %A_ABORT );
             GOTO RE_TURN;
          SELECT( ELSE );

          END;
       END;

RE_TURN:
    RETURN;

END RECEIVE_A_FILE;
%EJECT;
/****
*
*   R E C E I V E _ D A T A  ( aka RDATA )
*
*   Receive data
*
****/

RECEIVE_DATA: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %D_DATA );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
             CALL BUFEMP( DATA,LEN );
             NUM_DATA_PACKETS= NUM_DATA_PACKETS + 1;
             END;
          ELSE
             IF RCVD_PACKNUM ~= MOD(PACKNUM+63,64) THEN DO;
                GOTO NAK_THIS_PACKET;
                END;
          CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
          NUM_TRIES= 0;
          PACKNUM= MOD(RCVD_PACKNUM+1,64);

       SELECT( %F_FILE );
          IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO;
             CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
             NUM_TRIES= 0;
             END;
          ELSE
             STATE= %A_ABORT;

       SELECT( %Z_EOF );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
             CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
             IF IO_LEN > 0 THEN               /* Anything left to write?      */
                IF CUR_MODE = %SET_FILE_MODE_TEXT## THEN DO;
                   DO L=IO_LEN-1 DOWNTO 0 BY -1;
                      IF SUBSTR(IO_BUF,L,1) ~= %BINASC(0) THEN
                         GOTO IS_IT_CTL_Z;
                      END;
                   L= IO_LEN;
                   GOTO KEEP_IT;
IS_IT_CTL_Z:
                   IF SUBSTR(IO_BUF,L,1) = %SUB THEN
                      IF L>0 THEN
KEEP_IT:
                         CALL WRITE_RECORD( IO_BUF,L );
                      ELSE;
                   ELSE
                      CALL WRITE_RECORD( IO_BUF,L+1 );
                   END;
                ELSE
                   CALL WRITE_RECORD( IO_BUF,IO_LEN );
             IF LEN > 0  AND  SUBSTR(DATA_BUF,0,1) = 'D'  THEN
                /* Sender requested the transfer to be stopped */
                CALL CLOSE_A_FILE( DCBNUM(F$OUT),%RELEASE# );
             ELSE
                CALL CLOSE_A_FILE( DCBNUM(F$OUT) );
             CALL WRITE_LOG_REC( %LOG_NUM_DATA_PACKETS# );
             CALL WRITE_LOG_REC( %LOG_END_RECEIVE# );
             CALL WRITE_LOG_REC( %LOG_ELAPSED_TIME# );
             PACKNUM= MOD(RCVD_PACKNUM+1,64);
             STATE= %F_FILE;
             END;
          ELSE
             STATE= %A_ABORT;

       SELECT( %S_SINIT );
          STATE= %S_SINIT;
          CALL CLOSE_A_FILE( F$OUT#,SET_FILE_INCOMPLETE -
                                   %SET_FILE_INCOMPLETE_DISCARD##+1 );

       SELECT( %E_ERROR );
          STATE= %A_ABORT;
          CALL CLOSE_A_FILE( F$OUT#,SET_FILE_INCOMPLETE -
                                   %SET_FILE_INCOMPLETE_DISCARD##+1 );

       SELECT( ELSE );
NAK_THIS_PACKET:
          CALL SEND_PACKET( 'N',PACKNUM,0,' ' );

       END;

RE_TURN:
    RETURN;

END RECEIVE_DATA;
%EJECT;
/****
*
*   R E C E I V E _ F I L E  ( aka RFILE )
*
*   Receive File Header
*
****/

RECEIVE_FILE: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %S_SINIT );
          IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO;
             CALL SEND_OUR_PARAMS( %RECEIVE## );
             CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA );
             NUM_TRIES= 0;
             END;
          ELSE
             STATE= %A_ABORT;

       SELECT( %Z_EOF );
          IF RCVD_PACKNUM = MOD(PACKNUM+63,64) THEN DO;
             CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
             NUM_TRIES= 0;
             END;
          ELSE
             STATE= %A_ABORT;

       SELECT( %F_FILE );
          IF RCVD_PACKNUM ~= PACKNUM THEN DO;
             STATE= %A_ABORT;
             GOTO RE_TURN;
             END;

          REPEAT_CNT= 0;
          CALL OPEN_DEST_FILE  ALTRET( ALT_RETURN );

          CALL SEND_PACKET( 'Y',PACKNUM,0,' ' );

          AT_EOF= %NO#;                       /* We haven't seen a SUB yet!   */
          NUM_TRIES= 0;
          FILE_BYTE_CNT= 0;
          NEXT_CALL= %NOTHING#;
          NUM_DATA_PACKETS= 0;
          REC_CNT= 0;
          PACKNUM= MOD(PACKNUM+1,64);
          STATE= %D_DATA;

       SELECT( %B_BREAK );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
             CALL SEND_PACKET( 'Y',PACKNUM,0,' ' );
             STATE= %C_COMPLETE;
             END;
          ELSE
             STATE= %A_ABORT;

       SELECT( ELSE );
          STATE= %A_ABORT;
       END;
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END RECEIVE_FILE;
%EJECT;
/****
*
*   R E C E I V E _ I N I T  ( aka RINIT )
*
*   Receive Initialization
*
****/

RECEIVE_INIT: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_INITIAL_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    X= MY.TIMEOUT;
    CALL SET_TIMEOUT( X );                    /* Set packet read timeout      */

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %S_SINIT );
          CALL RECEIVE_THEIR_PARAMS( LEN,%RECEIVE## );
          CALL SEND_OUR_PARAMS( %RECEIVE## );
          CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA );
          NUM_TRIES= 0;
          PACKNUM= MOD(RCVD_PACKNUM+1,64);
          STATE= %F_FILE;

       SELECT( %E_ERROR );
          STATE= %A_ABORT;

       SELECT( ELSE );
          CALL SEND_PACKET( 'N',PACKNUM,0,' ' );

       END;

RE_TURN:
    RETURN;

END RECEIVE_INIT;
%EJECT;
/****
*
*   R E C E I V E _ P A C K
*
*   Read a packet.  Check to see if it is the special case where the user is
*   trying to exit out of SERVER mode.  If so, remember that and RETURN.
*   Otherwise, log a record in the DEBUG file (if we're DEBUGging), calculate
*   the checksum and check it.
*
****/

RECEIVE_PACK: PROC( TYPE,NUM,LEN,DATA )  ALTRET;
DCL TYPE                     UBIN(9)   CALIGNED;
DCL NUM                      UBIN;
DCL LEN                      UBIN;
DCL DATA(0:93)               UBIN(9)   CALIGNED;
DCL DATA_BIT(0:93) REDEF DATA BIT(9);
DCL IX SBIN;

DCL PACKET_ARS               UBIN;

    IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN);
READ_AGAIN:
    PACKET= '0'B;
    CALL M$READ( READ_PACKET )  ALTRET( TIMED_OUT );
    PACKET_ARS= F$PACKET_IN$ -> F$DCB.ARS#;
CONTINUE:
    SUBSTR(PACKET_BUF,PACKET_ARS,1)= F$PACKET_IN$ -> F$DCB.EOMCHAR#;
    CALL LOG( %DEBUG_RECEIVE##,PACKET,PACKET_ARS+LENGTHC(F$DCB.EOMCHAR#) );

    IF CHARMASK ~= '377'O THEN
       DO J=0 TO (PACKET_ARS+3)/4;
          PACKET_WORD(J) = PACKET_WORD(J) & WORDMASK;
          END;

    /*
       Do they just want out of SERVER mode?
    */
    IF IM_A_SERVER  AND
      (PACKET_ARS = 0                         OR
       SUBSTR(PACKET_BUF,0,PACKET_ARS) = ' '  OR
       SUBSTR(PACKET_BUF,0,PACKET_ARS) = 'END') THEN DO;
       PACKET_BUF= 'END';
       TRANSFER_INTERRUPTED= %YES#;
       GOTO RE_TURN;
       END;

    /*
        We have to flush the characters found between packets, so
        we look for a 'start_of_packet', and ignore anything that
        comes before that.
    */

    IF PACKET_ARS < 4 THEN GOTO READ_AGAIN;
    IF PACKET.MARK ~= MY.START_OF_PACKET THEN DO;
       CALL INDEX(IX,MY.START_OF_PACKET,SUBSTR(PACKET_BUF,0,PACKET_ARS))
          ALTRET(READ_AGAIN);
       PACKET_BUF = SUBSTR(PACKET_BUF,IX,PACKET_ARS-IX);
       PACKET_ARS = PACKET_ARS-IX;
       IF PACKET_ARS < 4 THEN GOTO READ_AGAIN;
       END;


    LEN= PACKET.LEN - 3 - ASCBIN(' ');

    CALL UNCHAR( ,PACKET.SEQ,NUM );

    TYPE= PACKET.TYPE;

    CALL BLOCK_MOVE( DATA,PACKET.DATA,LEN );

    CALL UNCHAR( ,PACKET.DATA(LEN),RCVD_CHECKSUM );

    CALL CALC_CHECKSUM( CHECKSUM );

    IF RCVD_CHECKSUM ~= CHECKSUM THEN         /* Bad checksum?                */
NAK_THIS_PACKET:
       TYPE= ASCBIN(%N_NAK);                  /* yep, NAK this packet         */

RE_TURN:
    RETURN;

TIMED_OUT:
    PACKET_ARS= F$PACKET_IN$ -> F$DCB.ARS#;
    IF (B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$TIMO) OR /* Did READ timeout?*/
    (B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$EOF) THEN
       IF PACKET_ARS > 0 THEN                          /* Yep, anything read? */
          GOTO CONTINUE;                               /* Yep, go use it      */
       ELSE DO;
          CALL LOG( %DEBUG_TIMEOUT##,' Timeout in RECEIVE_PACK.',25 );
          TYPE= ASCBIN(%N_NAK);
          END;
    ELSE
       IF B$TCB$->B$TCB.ALT$->B$ALT.ERR.CODE = %E$DI THEN /* Noisy line?      */
          GOTO READ_AGAIN;                                /* Yep, try again   */
       ELSE
          CALL M$MERC;
ALT_RETURN:
    ALTRETURN;

END RECEIVE_PACK;
%EJECT;
/****
*
*   R E C E I V E _ T H E I R _ P A R A M S  ( aka rpar )
*
*   Get the other host's send-init parameters.
*
****/

RECEIVE_THEIR_PARAMS: PROC( LEN,DIRECTION );
DCL LEN                      UBIN;
DCL DIRECTION                UBIN;

    CALL UNCHAR( THEIR.PACKET_LENGTH,DATA(0) );  /* MAXL */
    CALL UNCHAR( THEIR.TIMEOUT,      DATA(1) );  /* TIME */
    CALL UNCHAR( THEIR.PADDING,      DATA(2) );  /* NPAD */
    CALL    CTL( THEIR.PADCHAR,      DATA(3) );  /* PADC */
    CALL UNCHAR( THEIR.END_OF_LINE,  DATA(4) );  /* EOL  */
    THEIR.QUOTE= BINASC(DATA(5));                /* QCTL */
    IF LEN > 6 THEN
       THEIR.QBIN= BINASC(DATA(6));              /* QBIN */
    ELSE
       THEIR.QBIN= 'N';
    IF LEN > 7 THEN
       THEIR.BLOCK_CHECK= %ASCBIN('1');          /* CHKT */
    ELSE
       THEIR.BLOCK_CHECK= %ASCBIN('1');          /* CHKT */
    IF LEN > 8 THEN
       THEIR.REPT= BINASC(DATA(8));              /* REPT */
    ELSE
       THEIR.REPT= ' ';
    IF LEN > 9 THEN
       CALL UNCHAR( THEIR.CAPAS,DATA(9) );       /* MASK */
    ELSE
       CALL UNCHAR( THEIR.CAPAS,DATA(9) );       /* MASK */
    CALL SET_PARITY_MASK( THEIR.QBIN );
    IF DIRECTION = %RECEIVE## THEN DO;
       IF THEIR.QBIN = 'Y' THEN
          IF CHARMASK = '177'O THEN DO;    /* Do we need to do 8-bit quoting? */
             BINARY_QUOTING= %YES#;        /* Yep.                            */
             IF MY_DEFAULT.QBIN = 'Y' THEN /* If my default is a Y,           */
                MY.QBIN= '&';              /* send them an &                  */
             ELSE
                MY.QBIN= MY_DEFAULT.QBIN;  /* Otherwise, use what user said   */
             THEIR.QBIN= MY.QBIN;          /* Make theirs the same            */
             END;
          ELSE DO;
             BINARY_QUOTING= %NO#;         /* Don't do 8-bit quoting          */
             MY.QBIN= 'N';
             THEIR.QBIN= 'N';
             END;
       ELSE
          IF (THEIR.QBIN >= '!'  AND  THEIR.QBIN <= '>')   OR
             (THEIR.QBIN >= '`'  AND  THEIR.QBIN <= '~')  THEN DO;
             MY.QBIN= THEIR.QBIN;             /* Use their QBIN               */
             BINARY_QUOTING= %YES#;
             END;
          ELSE DO;                            /* Strange character            */
             MY.QBIN= 'N';                    /* Don't do 8-bit quoting       */
             BINARY_QUOTING= %NO#;
             END;
       IF (THEIR.REPT >= '!'  AND  THEIR.REPT <= '>')   OR
          (THEIR.REPT >= '`'  AND  THEIR.REPT <= '~')  THEN DO;
          MY.REPT= THEIR.REPT;
          REPEATING= %YES#;
          REPEAT_LEN= LENGTHC(THEIR.REPT) + 1;
          END;
       ELSE DO;
          REPEATING= %NO#;
          REPEAT_LEN= 0;
          MY.REPT= ' ';
          END;
       END;
    ELSE DO; /* DIRECTION = %SEND## */
       IF (THEIR.QBIN >= '!'  AND  THEIR.QBIN <= '>')   OR
          (THEIR.QBIN >= '`'  AND  THEIR.QBIN <= '~')  THEN DO;
          MY.QBIN= THEIR.QBIN;                /* Use their quote character    */
          BINARY_QUOTING= %YES#;
          END;
       ELSE DO;
          MY.QBIN= 'N';                       /* Don't do 8-bit quoting       */
          BINARY_QUOTING= %NO#;
          END;
       IF ((THEIR.REPT >= '!'  AND  THEIR.REPT <= '>')   OR
           (THEIR.REPT >= '`'  AND  THEIR.REPT <= '~'))  AND
          MY.REPT = THEIR.REPT  THEN DO;
          REPEATING= %YES#;
          REPEAT_LEN= LENGTHC(THEIR.REPT) + 1;
          END;
       ELSE DO;
          REPEATING= %NO#;
          REPEAT_LEN= 0;
          END;
       END;

RE_TURN:
    RETURN;

END RECEIVE_THEIR_PARAMS;
%EJECT;
/****
*
*   S E N D
*
*   SEND a file(s).
*
****/

SEND: PROC  ALTRET;

    SET_STEPCC.V.STEPCC# = 3;     /* default stepcc= can't find file */
    CALL MERGE_FILE_NAME_INTO_DCB  ALTRET( ALT_RETURN );
%IF OS_VERSION='B03';
    WILD_COMPARE.PATTERN$= ADDR(TARGET);
%ELSE;
    WILD_COMPARE.PATTERN_= VECTOR(SUBSTR(TARGET.NAME#,0,TARGET.L#));
%ENDIF;

    IF DELAY > 0  AND               /* Should we pause before initial packet? */
       NOT IM_A_SERVER THEN DO;
       CALL SNOOZE( DELAY );
       END;

    FILE_CNT= 0;                              /* No files sent yet...         */
    OK_TO_SEND= %YES#;
    PACKNUM= 0;                               /* Zero packet number           */
    TRANSFER_INTERRUPTED= %NO#;

    DO WHILE( OK_TO_SEND  AND  (NOT TRANSFER_INTERRUPTED) );
       CALL OPEN_NEXT_FILE             ALTRET( PUT_SUM );
       CALL DO_WE_WANT_THIS_FILE       ALTRET( CLOSE_F$IN );
       CALL SEND_A_FILE                ALTRET( CLOSE_F$IN );
CLOSE_F$IN:
       CALL CLOSE_A_FILE( DCBNUM(F$IN) );
       TEST_OPEN_IO.V.OPER.THISF#= %NO#;
       END;

PUT_SUM: ;
    IF FILE_CNT > 0  AND                      /* Were any file sent?          */
       (NOT TRANSFER_INTERRUPTED)  THEN DO;
       STATE= %B_BREAK;                       /* Send BREAK to stop transfer  */
       DO WHILE( STATE = %B_BREAK );
          CALL SEND_BREAK;
          END;
       END;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END SEND;
%EJECT;
/****
*
*   S E N D _ A _ F I L E  ( aka sendsw )
*
*   SENDSW is the state table switcher for sending files.  It loops until
*   either it finishes, or an error is encountered.  The routines called
*   by SENDSW are responsible for changing the state.
*
****/

SEND_A_FILE: PROC  ALTRET;

    CALL OPEN_FID( DCBNUM(F$IN),' ',0 )  ALTRET( OPEN_ERR );
    CALL DETERMINE_SEND_MODE;                 /* Determine MODE               */
    CP6_FID= SUBSTR(CUR_FILE.NAME#,0,CUR_FILE.L#);
    PACKET_FID= CP6_FID;
    X= CUR_FILE.L#;
    CALL FIX_PC_FILE_NAME( PACKET_FID,X );
    IF TARGET_WILD_POS = LENGTHC(TARGET.NAME#) THEN /* Just one file?         */
       IF NOT IM_A_SERVER THEN
          IF %BLK2_NSUBLKS > 1 THEN DO;       /* Was "AS" name specified?     */
             BLK3$= %BLK2_SUBLK$(1);          /* Yep, point to it.            */
             PACKET_FID= %BLK3_TEXT;
             END;

    CALL WRITE_LOG_REC( %LOG_HEADER# );
    CALL WRITE_LOG_REC( %LOG_STRT_SEND# );
    CALL WRITE_LOG_REC( %LOG_MAX_PACKET_SIZES# );
    SET_STEPCC.V.STEPCC# = 2;     /* stepcc= starting to send */

    X= MY.TIMEOUT;
    CALL SET_TIMEOUT( X );

    AT_EOF= %NO#;                             /* Assume we haven't hit EOF yet*/
    DONE_SENDING= %NO#;                       /* We aren't done yet           */
    FILE_BYTE_CNT= 0;                         /* Zero # bytes in file count   */
    NEXT_CALL= %NOTHING#;                     /* Zero this to start with      */
    NUM_TRIES= 0;                             /* Zero retry count             */
    NUM_DATA_PACKETS= 0;                      /* Zero count of Data packets   */
    REPEAT_CNT= 0;                            /* Zero the REPEAT count        */
    FILE_CNT= FILE_CNT + 1;                   /* Count this file              */
    IF FILE_CNT < 2 THEN
       STATE= %S_SINIT;
    ELSE
       STATE= %F_FILE;
    DO UNTIL( DONE_SENDING  OR  TRANSFER_INTERRUPTED );
       DO SELECT( STATE );
          SELECT( %D_DATA );
             CALL SEND_DATA;
          SELECT( %F_FILE );
             CALL SEND_FILE;
          SELECT( %Z_EOF );
             CALL SEND_EOF;
          SELECT( %S_SINIT );
             CALL SEND_INIT;
          SELECT( %B_BREAK );
             CALL SEND_BREAK;
          SELECT( %C_COMPLETE );
             DONE_SENDING= %YES#;
          SELECT( %A_ABORT );
             DONE_SENDING= %YES#;
          SELECT( ELSE );
             CALL CONCAT( ERR_BUF,'>> Unexpected SEND state of ''',
                                  STATE,
                                  ''' in SEND_A_FILE\' );
             CALL SEND_ERROR_PACKET( ERR_BUF,46 );

          END;
       END;


RE_TURN:
    RETURN;

OPEN_ERR:
    IF IM_A_SERVER THEN DO;
       CALL SEND_ERROR_PACKET;
       END;
    ELSE DO;
       ERRCODE= %MONERR;
       ERRDCB#= %ERRDCB;
       CALL XUR$ERRMSG( ERRCODE,ERRDCB# );
       END;
    OK_TO_SEND= %NO#;
ALT_RETURN:
    SET_STEPCC.V.STEPCC# = 3;     /* stepcc= can't find file */
    ALTRETURN;

END SEND_A_FILE;
%EJECT;
/****
*
*   S E N D _ B R E A K  ( aka SBREAK )
*
*   Send Break (EOT)
*
****/

SEND_BREAK: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL SEND_PACKET( 'B',PACKNUM,0,DATA );

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %N_NAK );
          IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN
             GOTO ACKUALLY_ITS_OK;

       SELECT( %Y_ACK );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
ACKUALLY_ITS_OK:
             NUM_TRIES= 0;                    /* Reset number of tries        */
             PACKNUM= MOD(PACKNUM+1,64);
             STATE= %C_COMPLETE;
             CALL SET_TIMEOUT( 0 );
             END;

       SELECT( %E_ERROR );
          CALL PRINT_ERROR_PACKET;

       SELECT( ELSE );
          STATE= %A_ABORT;

       END;

RE_TURN:
    RETURN;

END SEND_BREAK;
%EJECT;
/****
*
*   S E N D _ D A T A  ( aka SDATA )
*
*   Send File Data
*
****/

SEND_DATA: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL SEND_PACKET( 'D',PACKNUM,SIZE,DATA );

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %N_NAK );
          IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN
             GOTO ACKUALLY_ITS_OK;

       SELECT( %Y_ACK );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
ACKUALLY_ITS_OK:
             NUM_DATA_PACKETS= NUM_DATA_PACKETS + 1;
             NUM_TRIES= 0;                    /* Reset number of tries        */
             PACKNUM= MOD(PACKNUM+1,64);
             IF LEN > 0  AND
               (SUBSTR(DATA_BUF,0,1) = 'X' OR
                SUBSTR(DATA_BUF,0,1) = 'Z')  THEN DO;
                STATE= %Z_EOF;
                IF SUBSTR(DATA_BUF,0,1) = 'Z' THEN
                   TRANSFER_INTERRUPTED= %YES#; /* Stop multi file transfer   */
                END;
             ELSE DO;
                CALL BUFILL  ALTRET( RE_TURN );
                STATE= %D_DATA;
                END;
             END;

       SELECT( %E_ERROR );
          CALL PRINT_ERROR_PACKET;

       SELECT( ELSE );
          STATE= %A_ABORT;

       END;

RE_TURN:
    RETURN;

END SEND_DATA;
%EJECT;
/****
*
*   S E N D _ E O F  ( aka SEOF )
*
*   Send End-Of-File.
*
****/

SEND_EOF: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    IF  TRANSFER_INTERRUPTED  THEN DO;
       LEN= LENGTHC('D');
       SUBSTR(DATA_BUF,0,1)= 'D';
       END;
    ELSE
       LEN= 0;
    CALL SEND_PACKET( 'Z',PACKNUM,0,DATA );

    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );

       SELECT( %N_NAK );
          IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN
             GOTO ACKUALLY_ITS_OK;

       SELECT( %Y_ACK );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
ACKUALLY_ITS_OK:
             CALL WRITE_LOG_REC( %LOG_END_SEND# );
             CALL WRITE_LOG_REC( %LOG_NUM_DATA_PACKETS# );
             CALL WRITE_LOG_REC( %LOG_ELAPSED_TIME# );
             SET_STEPCC.V.STEPCC# = 0;  /* stepcc = successful send */
             NUM_TRIES= 0;                    /* Reset number of tries        */
             PACKNUM= MOD(PACKNUM+1,64);
             STATE= %C_COMPLETE;
             END;

       SELECT( %E_ERROR );
          CALL PRINT_ERROR_PACKET;

       SELECT( ELSE );
          STATE= %A_ABORT;

       END;

RE_TURN:
    RETURN;

END SEND_EOF;
%EJECT;
/****
*
*   S E N D _ E R R O R _ P A C K E T
*
*   Send an error packet to the "other computer".
*
****/

SEND_ERROR_PACKET: PROC( BUF,LEN );
DCL BUF                      CHAR(LEN);
DCL LEN                      UBIN;

    IF ADDR(BUF)=ADDR(NIL) THEN DO;
       FPT_ERRMSG.V.DCB#= %ERRDCB;
       ERRCODE= %MONERR;
       CALL M$ERRMSG( FPT_ERRMSG );
       CALL SEARCHR( I,X,SKIP_BLANKS,ERR_BUF )  WHENALTRETURN DO;
          I= LENGTHC(ERR_BUF) - 1;
          END;
       I= I + 1;
       END;
    ELSE DO;
       I= LEN;
       ERR_BUF= BUF;
       END;

    CALL SEND_PACKET( 'E',PACKNUM,I,ERR_BUF );
    CALL WRITE_LOG_REC( %LOG_ERRMSG#,I );
RE_TURN:
    RETURN;

END SEND_ERROR_PACKET;
%EJECT;
/****
*
*   S E N D _ F I L E  ( aka SFILE )
*
*   Send File Header.
*
****/

SEND_FILE: PROC  ALTRET;

    ARS= 0;
    IO_INDX= 999;
    REC_CNT= 0;                               /* Zero number record read      */
    OUT_INDX= 0;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_PACKET_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL SEARCHR( LEN,X,SKIP_BLANKS,PACKET_FID );
    CALL SEND_PACKET( 'F',PACKNUM,LEN+1,PACKET_FID );
    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

    DO SELECT( TYPE );
       SELECT( %N_NAK );
          IF RCVD_PACKNUM = MOD(PACKNUM+1,64) THEN
             GOTO ACK_UALLY_ITS_OK;
       SELECT( %Y_ACK );
          IF RCVD_PACKNUM = PACKNUM THEN DO;
ACK_UALLY_ITS_OK:
             NUM_TRIES= 0;
             PACKNUM= MOD(PACKNUM+1,64);
             CALL BUFILL  ALTRET( RE_TURN );
             STATE= %D_DATA;
             END;
       SELECT( %E_ERROR );
          CALL PRINT_ERROR_PACKET;
       SELECT( ELSE );
          STATE= %A_ABORT;
       END;

RE_TURN:
    RETURN;

END SEND_FILE;
%EJECT;
/****
*
*   S E N D _ I N I T  ( aka SINIT )
*
*   Send Initiate: send this host's parameters and get other sides back.
*
****/

SEND_INIT: PROC  ALTRET;

    NUM_TRIES= NUM_TRIES + 1;
    IF NUM_TRIES > PROTOCOL.MAX_INITIAL_RETRIES THEN DO;
       STATE= %A_ABORT;
       GOTO RE_TURN;
       END;

    CALL SEND_OUR_PARAMS( %SEND## );          /* Fill in our init info packet */
    CALL FLUSH_INPUT;                         /* Flush any pending input      */
    CALL SEND_PACKET( 'S',PACKNUM,PACKLEN,DATA );  /* Send our S packet       */
    CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );/* Get a reply            */

    DO SELECT( TYPE );                        /* What did they send?          */

       SELECT( %N_NAK );

       SELECT( %Y_ACK );
          IF RCVD_PACKNUM ~= PACKNUM THEN     /* Wrong packet number?         */
             EXIT;                            /* Yep, ignore it and try agn   */
          CALL RECEIVE_THEIR_PARAMS( LEN,%SEND## );
          NUM_TRIES= 0;
          PACKNUM= MOD(PACKNUM+1,64);
          STATE= %F_FILE;
       SELECT( %E_ERROR );
          CALL PRINT_ERROR_PACKET;
       SELECT( ELSE );
          STATE= %A_ABORT;

       END;

RE_TURN:
    RETURN;

END SEND_INIT;
%EJECT;
/****
*
*   S E N D _ O U R _ P A R A M S  ( aka SPAR )
*
*   Fill the data array with my send-init parameters
*
****/

SEND_OUR_PARAMS: PROC( DIRECTION );
DCL DIRECTION                UBIN;

    IF DIRECTION = %SEND## THEN               /* If we're SENDing, init MY    */
       MY= MY_DEFAULT;

    CALL TOCHAR( DATA(0),MY.PACKET_LENGTH );  /* MAXL */
    CALL TOCHAR( DATA(1),MY.TIMEOUT );        /* TIME */
    CALL TOCHAR( DATA(2),MY.PADDING );        /* NPAD */
    CALL    CTL( DATA(3),MY.PADCHAR );        /* PADC */
    CALL TOCHAR( DATA(4),MY.END_OF_LINE );    /* EOL  */
    SUBSTR(DATA_BUF,5,1)= MY.QUOTE;           /* QCTL */
    SUBSTR(DATA_BUF,6,1)= MY.QBIN;            /* QBIN */
    SUBSTR(DATA_BUF,7,1)= '1';                /* CHKT */
    SUBSTR(DATA_BUF,8,1)= MY.REPT;            /* REPT */
    PACKLEN= 9;

RE_TURN:
    RETURN;

END SEND_OUR_PARAMS;
%EJECT;
/****
*
*   S E N D _ P A C K E T
*
*   Send off the packet in progress.  If a LOG file is OPEN, write the packet
*   to the LOG file too.
*
****/

SEND_PACKET: PROC( TYPE,NUM,LEN,DATA )  ALTRET;
DCL TYPE                     CHAR(1);
DCL NUM                      UBIN;
DCL LEN                      UBIN;
DCL DATA(0:93)               UBIN(9)   CALIGNED;

    IF NOT GOT_TRMCTL THEN CALL INIT_ACTIVATION ALTRET(ALT_RETURN);
    IF THEIR.PADDING > 0 THEN                 /* Any padding needed?          */
       CALL SEND_PADCHARS( THEIR.PADDING );   /* Yep, go do it.               */

    PACKET.MARK= PROTOCOL.SYNCHR;             /* Usually SOH                  */
    UBIN9= LEN + 3;
    CALL TOCHAR( PACKET.LEN,UBIN9 );
    UBIN9= NUM;
    CALL TOCHAR( PACKET.SEQ,UBIN9 );
    PACKET.TYPE= ASCBIN(TYPE);
    CALL BLOCK_MOVE( PACKET.DATA,DATA,LEN );
    CALL CALC_CHECKSUM( CHECKSUM );
    UBIN9= CHECKSUM;
    CALL TOCHAR( PACKET.DATA(LEN),UBIN9 );
    PACKET.DATA(LEN+1)= ASCBIN(THEIR.END_OF_LINE);
    WRITE_PACKET.BUF_.BOUND= LEN + 4 + 1;
    CALL M$WRITE( WRITE_PACKET )  ALTRET( ALT_RETURN );
    CALL LOG( %DEBUG_SEND##,PACKET,WRITE_PACKET.BUF_.BOUND+1 );
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END SEND_PACKET;
%EJECT;
/****
*
*   S E N D _ P A D C H A R S
*
*   This currently does nothing!
*
****/

SEND_PADCHARS: PROC( COUNT );
DCL COUNT                    UBIN(9)   CALIGNED;

RE_TURN:
    RETURN;

END SEND_PADCHARS;
%EJECT;
/****
*
*   S E R V E R
*
*   This takes care of the SERVER mode.
*
****/

SERVER: PROC  ALTRET;

    NEXT_CALL= %NOTHING#;
    NUM_TRIES= 0;
    MY= MY_DEFAULT;
    PACKNUM= 0;
    REPEAT_CNT= 0;

    CALL PUT('CP-6 Kermit SERVER at your service\');
    CALL PUT('To shut me (the SERVER) down, enter BYE or FINISH on your local machine.\');

    IM_A_SERVER= %YES#;                       /* Remember I'm in SERVER mode  */
       IF GOT_TRMCTL THEN
       CALL M$STRMCTL( STRMCTL )  ALTRET( ALT_RETURN ); /* Set ACTONTRN AGAIN */
    ELSE
       CALL INIT_ACTIVATION  ALTRET( ALT_RETURN );

    DO WHILE('1'B);

       CALL RECEIVE_PACK( TYPE,RCVD_PACKNUM,LEN,DATA );

       IF PACKET_BUF = 'END' THEN DO;
          IM_A_SERVER= %NO#;                  /* I won't be a SERVER any more */
          GOTO RE_TURN;
          END;

       DO SELECT( TYPE );

          SELECT( %N_NAK );
             CALL SEND_PACKET( 'N',PACKNUM,0,' ' );

          SELECT( %I_INIT, %S_SINIT );        /* RECEIVE a file(s)            */
             PACKNUM= RCVD_PACKNUM;
             CALL RECEIVE_THEIR_PARAMS( LEN,%RECEIVE## );
             CALL SEND_OUR_PARAMS( %RECEIVE## );
             CALL SEND_PACKET( 'Y',PACKNUM,PACKLEN,DATA );
             FILE_CNT= 0;
             NUM_TRIES= 0;
             SRCE_FID= ' ';
             TX= 0;
             OPEN_IO= DEFAULT_OPEN;
             OPEN_IO.V_= VECTOR(OPEN_IO.V);
             HOW_RECEIVE= SET_FILE_WARNING - %SET_FILE_WARNING_ON## + 1;
             IF TYPE = %S_SINIT THEN DO;
                PACKNUM= MOD(PACKNUM+1,64);
                CALL RECEIVE_A_FILE( %F_FILE );
                PACKNUM = 0;
                NUM_TRIES = 0;
                END;

          SELECT( %R_RINIT );                 /* SEND file(s)                 */
             CALL GET_FID_FROM_PACKET( PACKET.DATA_BUF,LEN,SRCE_FID,K );
             IF K < LENGTHC(SRCE_FID) THEN
                SUBSTR(SRCE_FID,K)= ' ';
             CALL FIX_CP6_FILE_NAME( SRCE_FID,K,%SEND## );
             CALL SEND  WHENALTRETURN DO; END;
             IF FILE_CNT = 0 THEN DO;
                CALL CONCAT( LO_BUF,'.. Sorry, no files matching "',
                                    SUBSTR(TARGET.NAME#,0,TARGET.L#),
                                    '" were found on CP-6.' );
                CALL SEARCHR( L,X,SKIP_BLANKS,LO_BUF );
                CALL SEND_ERROR_PACKET( LO_BUF,L+1 );
                END;
             ELSE
                PACKNUM= 0;

          SELECT( %G_GENERIC );
             DO SELECT( SUBSTR(PACKET.DATA_BUF,0,1) );
                SELECT( %F_FINISH );
                   CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
                   IM_A_SERVER= %NO#;         /* I won't be a SERVER any more */
                   GOTO ALT_RETURN;
                SELECT( %L_BYE );
                   CALL SEND_PACKET( 'Y',RCVD_PACKNUM,0,' ' );
                   CALL CLOSE_A_FILE ( F$DEBUG# );
                   CALL CLOSE_A_FILE ( M$LO#, %SAVE# );
                   CMD_BUF= 'BYE';
%IF OS_VERSION~='B03';
                   FPT_YC.V.LINK#= %NO#;
%ENDIF;
                   CALL M$YC( FPT_YC );
                SELECT( ELSE );
                   CALL CONCAT( LO_BUF,'> GENERIC subcommand ',
                                       SUBSTR(PACKET.DATA_BUF,0,1),
                                ' has NOT been implemented by CP-6 KERMIT <\' );
                   CALL INDEX( K,'\',LO_BUF );
                   CALL SEND_ERROR_PACKET( LO_BUF,K );
                   CALL SEND_PACKET( 'Y',PACKNUM,0,' ' );
                END;

       /* SELECT( %K_KERMIT ); */

          SELECT( ELSE );
             CALL CONCAT( LO_BUF,'> CP-6 KERMIT SERVER got a type ',
                                 TYPE,
                                 ' packet and didn''t know what to do!\' );
             CALL INDEX( K,'\',LO_BUF );
             CALL SEND_ERROR_PACKET( LO_BUF,K );

          END;
       END;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END SERVER;
%EJECT;
/****
*
*   S E T
*
*   Do any and all SET commands.
*
****/

SET: PROC  ALTRET;

    DO J=0 TO %BLK2_NSUBLKS-1;
       BLK3$= %BLK2_SUBLK$(J);
       IF %BLK3_NSUBLKS > 0 THEN DO;
          BLK4$= %BLK3_SUBLK$(0);
          IF %BLK4_NSUBLKS > 0 THEN
             BLK5$= %BLK4_SUBLK$(0);
          END;
       DO CASE( %BLK3_CODE );
          CASE( %SET_BLOCK_CHECK## );
             DO CASE( %BLK4_CODE );
                CASE( %ONE_CHAR_CHECKSUM## );
                   BLOCK_CHECK= 1;
                CASE( %TWO_CHAR_CHECKSUM## );
                   CALL PUT( '.. Sorry, I only do 1 character checksums\' );
                CASE( %THREE_CHAR_CHECKSUM## );
                   CALL PUT( '.. Sorry, I only do 1 character checksums\' );
                END;
          CASE( %SET_DELAY## );
             CALL CHARBIN( DELAY,%BLK4_TEXT );
          CASE( %SET_FILE## );
             DO CASE( %BLK4_CODE );
                CASE( %SET_FILE_BINARY_EXTENSIONS## );
                   IF %BLK4_NSUBLKS <= %MAX_EXTENSIONS# THEN DO;
                      DO K=0 TO %BLK4_NSUBLKS-1;
                         BLK5$= %BLK4_SUBLK$(K);
                         EXTEN.LEN(K)= LENGTHC('?') + %BLK5_COUNT;
                         CALL CONCAT( EXTEN.TEXT(K),'?',%BLK5_TEXT );
                         END;
                      IF %BLK4_NSUBLKS = 1  AND  EXTEN.TEXT(0)='?NONE' THEN
                         NUM_EXTENSIONS= 0;
                      ELSE
                         NUM_EXTENSIONS= %BLK4_NSUBLKS;
                      END;
                   ELSE
                      CALL PUT('.. Too many extensions specified; max is 30.\');
                CASE( %SET_FILE_CP6_FIDS_YES## );
                   SET_FILE_CP6_FIDS= %SET_FILE_CP6_FIDS_YES##;
                CASE( %SET_FILE_CP6_FIDS_NO## );
                   SET_FILE_CP6_FIDS= %SET_FILE_CP6_FIDS_NO##;
                CASE( %SET_FILE_EDIT_YES## );
                   SET_FILE_EDIT= %SET_FILE_EDIT_YES##;
                CASE( %SET_FILE_EDIT_NO## );
                   SET_FILE_EDIT= %SET_FILE_EDIT_NO##;
                CASE( %SET_FILE_END_OF_RECORD## );
                   IF %BLK4_NSUBLKS > 2 THEN DO;
                      CALL X$WRITE( F_FDS,FMT35_ );
                      GOTO NEXT_J;
                      END;
                   ELSE DO;
                      SIZE= 0;
                      EOR_BYTE_LEN= 0;
                      DO K = 0 TO %BLK4_NSUBLKS-1;
                         BLK5$= %BLK4_SUBLK$(K);
                         CALL CHARBIN( L,%BLK5_TEXT );
                         IF L > 255 THEN DO;
                            CALL X$WRITE( F_FDS,FMT36_,VECTOR(L) );
                            GOTO NEXT_J;
                            END;
                         ELSE DO;
                            CALL STUFF_CHAR_IN_PACKET( BINASC(L) );
                            EOR_BYTE(K) = BINASC(L);
                            EOR_BYTE_LEN= EOR_BYTE_LEN + 1;
                            END;
                         END;
                      EOR_CHARS= SUBSTR(DATA_BUF,0,SIZE);
                      EOR_CHARS_LEN= SIZE;
                      END;
                CASE( %SET_FILE_INCOMPLETE_DISCARD## );
                   SET_FILE_INCOMPLETE= %SET_FILE_INCOMPLETE_DISCARD##;
                CASE( %SET_FILE_INCOMPLETE_KEEP## );
                   SET_FILE_INCOMPLETE= %SET_FILE_INCOMPLETE_KEEP##;
                CASE( %SET_FILE_MODE_AUTO## );
                   SET_FILE_MODE= %SET_FILE_MODE_AUTO##;
                CASE( %SET_FILE_MODE_BINARY## );
                   SET_FILE_MODE= %SET_FILE_MODE_BINARY##;
                CASE( %SET_FILE_MODE_TEXT## );
                   SET_FILE_MODE= %SET_FILE_MODE_TEXT##;
                CASE( %SET_FILE_NAMES_ASIS## );
                   SET_FILE_NAMES= %SET_FILE_NAMES_ASIS##;
                CASE( %SET_FILE_NAMES_LC## );
                   SET_FILE_NAMES= %SET_FILE_NAMES_LC##;
                CASE( %SET_FILE_NAMES_UC## );
                   SET_FILE_NAMES= %SET_FILE_NAMES_UC##;
                CASE( %SET_FILE_PC_EXTENSIONS_YES## );
                   SET_FILE_PC_EXTENSIONS= %SET_FILE_PC_EXTENSIONS_YES##;
                CASE( %SET_FILE_PC_EXTENSIONS_NO## );
                   SET_FILE_PC_EXTENSIONS= %SET_FILE_PC_EXTENSIONS_NO##;
                CASE( %SET_FILE_PREFIX## );
                   SET_FILE_PREFIX.LEN= %BLK5_COUNT;
                   SET_FILE_PREFIX.TEXT= %BLK5_TEXT;
                CASE( %SET_FILE_REPLACEMENT## );
                   SET_FILE_REPLACEMENT= %BLK5_TEXT;
                CASE( %SET_FILE_SUBDIRECTORY_CHAR## );
                   SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_ON##;
                   SET_FILE_SUBDIRECTORY_CHAR= %BLK5_TEXT;
                CASE( %SET_FILE_SUBDIRECTORY_OFF## );
                   SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_OFF##;
                CASE( %SET_FILE_SUBDIRECTORY_ON## );
                   SET_FILE_SUBDIRECTORY= %SET_FILE_SUBDIRECTORY_ON##;
                CASE( %SET_FILE_WARNING_ON## );
                   SET_FILE_WARNING= %SET_FILE_WARNING_ON##;
                CASE( %SET_FILE_WARNING_INTO## );
                   SET_FILE_WARNING= %SET_FILE_WARNING_INTO##;
                CASE( %SET_FILE_WARNING_OFF## );
                   SET_FILE_WARNING= %SET_FILE_WARNING_OFF##;
                CASE( ELSE );
                   CALL PUT( '.. Oops, X$PARSE knows of an option I don''t!\' );
                END;
          CASE( %SET_SEND## );
             DO K=0 TO %BLK3_NSUBLKS-1;
                BLK4$= %BLK3_SUBLK$(K);
                IF %BLK4_NSUBLKS > 0 THEN
                   BLK5$= %BLK4_SUBLK$(0);
                DO CASE( %BLK4_CODE );
                   CASE( %SEND_EIGHT_BIT_QUOTE## );
                      MY_DEFAULT.QBIN= %BLK5_TEXT;
                   CASE( %SEND_END_OF_LINE## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.END_OF_LINE= BINASC(L);
                   CASE( %SEND_PACKET_LENGTH## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.PACKET_LENGTH= L;
                   CASE( %SEND_PAUSE## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.PAUSE= L;
                   CASE( %SEND_PADDING## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.PADDING= L;
                   CASE( %SEND_PADCHAR## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.PADCHAR= BINASC(L);
                   CASE( %SEND_QUOTE## );
                      MY_DEFAULT.QUOTE= %BLK5_TEXT;
                   CASE( %SEND_REPT## );
                      MY_DEFAULT.REPT= %BLK5_TEXT;
                   CASE( %SEND_START_OF_PACKET## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.START_OF_PACKET= BINASC(L);
                   CASE( %SEND_TIMEOUT## );
                      CALL CHARBIN( L,%BLK5_TEXT );
                      MY_DEFAULT.TIMEOUT= L;
                   END;
                END;
          CASE( %SET_RETRY## );
             BLK5$= %BLK4_SUBLK$(0);
             DO CASE( %BLK4_CODE );
                CASE( %RETRY_INITIAL## );
                   CALL CHARBIN( PROTOCOL.MAX_INITIAL_RETRIES,%BLK5_TEXT );
                CASE( %RETRY_PACKETS## );
                   CALL CHARBIN( PROTOCOL.MAX_PACKET_RETRIES,%BLK5_TEXT );
                END;
          CASE( %SET_TAB_EXPANSION## );
            SET_TAB_EXPANSION= %BLK4_CODE;
          CASE( %SET_TABS## );
             DO K=0 TO %BLK3_NSUBLKS-1;
                BLK4$= %BLK3_SUBLK$(K);
                CALL CHARBIN( L,%BLK4_TEXT );
                TABS(K)= L;
                IF K > 0  AND  TABS(K) <= TABS(K-1) THEN DO;
                   VEC1_= VECTOR(L);
                   CALL X$WRITE( F_FDS,FMT32_,VEC1_ );
                   GOTO SET_DEFAULT_TABS;
                   END;
                IF TABS(K) > 255 THEN DO;     /* Tab value to large?          */
                   VEC1_= VECTOR(L);
                   CALL X$WRITE( F_FDS,FMT31_,VEC1_ );
                   GOTO SET_DEFAULT_TABS;
                   END;
                END;
             NUM_TABS= %BLK3_NSUBLKS;
             IF NUM_TABS = 1  AND  TABS(0)=0 THEN  /* Reset TABs to defaults? */
                GOTO SET_DEFAULT_TABS;

             IF TABS(0) = 0 THEN              /* No tabs?                     */
                NUM_TABS= 0;                  /* Yep.                         */

             DO WHILE('0'B);
SET_DEFAULT_TABS:
                L= 9;                         /* Start TABs at 9              */
                DO K=0 TO 39;
                   TABS(K)= L;
                   L= L + 8;                  /* and increment by 8           */
                   END;
                NUM_TABS= 40;
                END;
          CASE( ELSE );
             CALL PUT( '.. Oops, X$PARSE knows of an option I don''t!\' );
          END;
NEXT_J:
       END;

RE_TURN:
    RETURN;

END SET;
%EJECT;
/****
*
*   S E T _ P A R I T Y _ M A S K
*
*   Based upon the 8-bit quoting character passed (QBIN) and/or the parity
*   currently in use, setup CHARMASK and WORDMASK for use later to mask off
*   the parity bit.
*
****/

SET_PARITY_MASK: PROC( QBIN );
DCL QBIN                     CHAR(1);

    IF QBIN = 'Y' THEN DO;
       CALL M$GTRMATTR(FPT_GTRMATTR);
       IF (VLP_GTRMATTR.PARITY# = %KV_PRTTYP_NONE)   OR
          (VLP_GTRMATTR.PARITY# = %KV_PRTTYP_ZERO)  THEN DO;
          CHARMASK = '377'O;
          WORDMASK = '377377377377'O;
          END;
       ELSE DO;
          CHARMASK = '177'O;
          WORDMASK = '177177177177'O;
          END;
       END;
    ELSE
       IF (QBIN >= '!'  AND  QBIN <= '>')  OR
          (QBIN >= '^'  AND  QBIN <= '~') THEN DO;
          CHARMASK = '177'O;
          WORDMASK = '177177177177'O;
          END;
       ELSE DO;
          CHARMASK = '377'O;
          WORDMASK = '377377377377'O;
          END;

RE_TURN:
    RETURN;

END SET_PARITY_MASK;
%EJECT;
/****
*
*   S E T _ T I M E O U T
*
*   Set the timeout for READs.  This is generally done before a transfer
*   starts and after one is finished.
*
****/

SET_TIMEOUT: PROC( TIMEOUT_VALUE )  ALTRET;
DCL TIMEOUT_VALUE            UBIN;

    IF TIMEOUT.V.TIMEOUT# ~= TIMEOUT_VALUE THEN DO;
       TIMEOUT.V.TIMEOUT#= TIMEOUT_VALUE;
       CALL BINCHAR( INT5,TIMEOUT_VALUE );
       CALL CONCAT( LO_BUF,'Timeout value set to ',INT5 );
       CALL LOG( %DEBUG_TIMEOUT##,LO_BUF,26 );
        MY_STATION.EOFTIME# = TIMEOUT_VALUE;
       CALL M$EOM( TIMEOUT )  ALTRET( ALT_RETURN );
       END;

    IF TIMEOUT_VALUE > 0 THEN DO;
       CALL M$STRMCTL( STRMCTL );
       END;

RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END SET_TIMEOUT;
%EJECT;
/****
*
*   S H O W
*
*   Show the current settings of most SETable values.
*
****/

SHOW: PROC;

    MY= MY_DEFAULT;
    F_FDS.DCB#= DEFAULT_DCB#;
    CALL X$WRITE( F_FDS,FMT1_,VECTOR(MY.QUOTE),VECTOR(THEIR.QUOTE) );

    K= ASCBIN(THEIR.START_OF_PACKET);
    L= ASCBIN(MY.START_OF_PACKET);
    CALL CHARCTL( STR1,K );
    CALL CHARCTL( STR2,L );
    CALL X$WRITE( F_FDS,FMT2_,VECTOR(SUBSTR(STR1,0,6)),
                              VECTOR(SUBSTR(STR2,0,6)) );

    CALL X$WRITE( F_FDS,FMT3_,VECTOR(THEIR.TIMEOUT),VECTOR(MY.TIMEOUT) );

    CALL X$WRITE( F_FDS,FMT4_,VECTOR(THEIR.PACKET_LENGTH),
                              VECTOR(MY.PACKET_LENGTH) );

    CALL X$WRITE( F_FDS,FMT5_,VECTOR(THEIR.PADDING),VECTOR(MY.PADDING) );

    K= ASCBIN(MY.END_OF_LINE);
    CALL CHARCTL( STR1,K );
    CALL X$WRITE( F_FDS,FMT6_,VECTOR(SUBSTR(STR1,0,6)) );

    IF SET_FILE_CP6_FIDS = %SET_FILE_CP6_FIDS_NO## THEN
       STR1= 'No';
    ELSE
       STR1= 'Yes';
    IF SET_FILE_INCOMPLETE = %SET_FILE_INCOMPLETE_DISCARD## THEN
       STR2= 'Incomplete files will be discarded';
    ELSE
       STR2= 'Incomplete files will be kept';
    CALL X$WRITE( F_FDS,FMT7_,VECTOR(SUBSTR(STR1,0,3)),VECTOR(STR2) );

    IF SET_FILE_EDIT = %SET_FILE_EDIT_NO## THEN
       STR1= 'Received files will not be EDIT keyed';
    ELSE
       STR1= 'Received files will be EDIT keyed';
    CALL X$WRITE( F_FDS,FMT8_,VECTOR(SET_FILE_REPLACEMENT),VECTOR(STR1) );

    IF SET_FILE_NAMES = %SET_FILE_NAMES_ASIS## THEN
       STR1= 'Packet file names used ASIS';
    ELSE
       IF SET_FILE_NAMES = %SET_FILE_NAMES_LC## THEN
          STR1= 'Packet file names converted to LowerCase';
       ELSE
          STR1= 'Packet file names converted to UpperCase';
    CALL X$WRITE( F_FDS,FMT9_,VECTOR(STR1),VECTOR(DELAY) );

    CALL X$WRITE( F_FDS,FMT10_,VECTOR(PROTOCOL.MAX_INITIAL_RETRIES),
                               VECTOR(PROTOCOL.MAX_PACKET_RETRIES) );

    IF SET_TAB_EXPANSION = %SET_TAB_EXPANSION_ON## THEN
       STR1= 'On';
    ELSE
       IF SET_TAB_EXPANSION = %SET_TAB_EXPANSION_OFF## THEN
          STR1= 'Off';
       ELSE
          STR1= 'Lee blew it!';
    IF F$LOG$->F$DCB.FCD# THEN
       STR2= ' ';
    ELSE
       STR2= ' Was ';
    CALL X$WRITE( F_FDS,FMT11_,VECTOR(STR1),VECTOR(STR2),
                               VECTOR(LOG_FILE.NAME#) );

    IF NUM_TABS = 0 THEN
       STR1= 'Tabs: None';
    ELSE
       IF NUM_TABS = 40  AND  TABS(0) = 9  AND  TABS(39) = 321 THEN
          STR1= 'Tabs: Every 8 columns between 9 and 321';
       ELSE DO;
          STR1= 'Tabs: ';
          OUT_INDX= LENGTHC('Tabs: ');
          DO K=0 TO NUM_TABS-1;
             CALL BINCHAR( INT5,TABS(K) );
             L= 0;
             DO WHILE( L<4 AND SUBSTR(INT5,L,1)='0' );
                L= L + 1;
                END;
             IF OUT_INDX + 5-L + LENGTHC(', ') >= LENGTHC(STR1) THEN DO;
                CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) );
                STR1= ' ';
                OUT_INDX= LENGTHC('Tabs: ');
                END;
             CALL INSERT( STR1,OUT_INDX,,SUBSTR(INT5,L),', ' );
             OUT_INDX= OUT_INDX + 5-L + LENGTHC(', ');
             END;
          IF OUT_INDX > LENGTHC('Tabs: ') THEN
             SUBSTR(STR1,OUT_INDX-2,1)= ' ';  /* Blank out the trailing comma */
          END;
    CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) );

    IF SET_FILE_PC_EXTENSIONS = %SET_FILE_PC_EXTENSIONS_YES## THEN
       STR1= 'Yes';
    ELSE
       STR1= 'No';
    IF SET_FILE_MODE = %SET_FILE_MODE_AUTO## THEN
       STR2= 'Automatic';
    ELSE
       IF SET_FILE_MODE = %SET_FILE_MODE_BINARY## THEN
          STR2= 'Binary';
       ELSE
          STR2= 'Text';
    CALL X$WRITE( F_FDS,FMT33_,VECTOR(STR1),VECTOR(STR2) );

    IF SET_FILE_WARNING = %SET_FILE_WARNING_ON## THEN
       STR1= 'On (TO)';
    ELSE
       IF SET_FILE_WARNING = %SET_FILE_WARNING_INTO## THEN
          STR1= 'INTO';
       ELSE
          STR1= 'Off (OVER)';
    IF F$DEBUG$->F$DCB.FCD# THEN
       STR2= ' ';
    ELSE
       STR2= ' Was ';
    CALL X$WRITE( F_FDS,FMT34_,VECTOR(STR1),VECTOR(STR2),
                               VECTOR(DEBUG_FILE.NAME#) );

    IF SET_FILE_SUBDIRECTORY = %SET_FILE_SUBDIRECTORY_ON## THEN
       STR1= 'Yes';
    ELSE
       STR1= 'No';
    CALL X$WRITE( F_FDS,FMT37_,VECTOR(STR1),
                               VECTOR(SET_FILE_SUBDIRECTORY_CHAR) );

    IF SET_FILE_PREFIX.LEN = 0 THEN
       STR1= 'Disabled';
    ELSE
       STR1= SET_FILE_PREFIX.TEXT;
    CALL X$WRITE( F_FDS,FMT38_,VECTOR(STR1) );

    IF NUM_EXTENSIONS = 0 THEN
       STR1= 'Binary extensions: None';
    ELSE DO;
       STR1= 'Binary extensions: ';
       OUT_INDX= LENGTHC('Binary extensions: ');
       DO K = 0 TO NUM_EXTENSIONS-1;
          L= EXTEN.LEN(K);
          IF K < NUM_EXTENSIONS-1 THEN /* If not the last extension, put comma*/
             L= L + LENGTHC(', ');
          IF OUT_INDX + L >= LENGTHC(STR1) THEN DO;
             CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) );
             STR1= ' ';
             OUT_INDX= LENGTHC('Binary extensions: ');
             END;
          CALL INSERT( STR1,OUT_INDX,L,SUBSTR(EXTEN.TEXT(K),0,EXTEN.LEN(K)),
                                       ', ' );
          OUT_INDX= OUT_INDX + L;
          END;
       CALL X$WRITE( F_FDS,FMT_,VECTOR(STR1) );
       END;

RE_TURN:
    RETURN;

END SHOW;
%EJECT;
/****
*
*   S N O O Z E
*
*   Go to sleep for SECONDS seconds.
*
****/

SNOOZE: PROC( SECONDS );
DCL SECONDS                  UBIN;

     IF ~CG_MODE THEN DO;
        FPT_WAIT.V.UNITS# = SECONDS;
        CALL M$WAIT( FPT_WAIT )  ALTRET( RE_TURN );
        END;
RE_TURN:
    RETURN;

END SNOOZE;
%EJECT;
/****
*
*   S T U F F
*
*   Stuff CHR into BUF at byte LEN.  If need be, expand BUF first.
*
****/

STUFF: PROC( BUF,LEN )  ALTRET;
DCL BUF                      CHAR(LEN);
DCL LEN                      UBIN;

    IF LEN >= IO_BUF_SIZE THEN DO;
       CALL EXPAND( IO_,4096,IO_BUF_SIZE )  ALTRET( ALT_RETURN );
       END;

    SUBSTR(BUF,LEN,LENGTHC(CHR))= CHR;
    LEN= LEN + LENGTHC(CHR);
RE_TURN:
    RETURN;

ALT_RETURN:
    ALTRETURN;

END STUFF;
%EJECT;
/****
*
*   S T U F F _ C H A R _ I N _ P A C K E T
*
*   Stuff CHR into the out going data packet.
*
****/

STUFF_CHAR_IN_PACKET: PROC( CHR );
DCL CHR                      CHAR(1);
DCL CHR_BIT REDEF CHR        BIT(9)    CALIGNED;

DCL CHR7                     CHAR(1)   CALIGNED;
DCL CHR7_BIT REDEF CHR7      BIT(9)    CALIGNED;

    CHR7_BIT= CHR_BIT & '177'O;               /* Mask off parity bit          */
    IF BINARY_QUOTING AND (CHR ~= CHR7) THEN DO;
       SUBSTR(DATA_BUF,SIZE,1)= THEIR.QBIN;
       SIZE= SIZE + LENGTHC(THEIR.QBIN);
       END;
    IF CHR7 < ' '  OR
       CHR7 = MY.QUOTE  OR
       CHR7 = %DEL      OR
      (BINARY_QUOTING  AND  CHR7=MY.QBIN)  OR
      (REPEATING AND CHR7=MY.REPT)  THEN DO;
       SUBSTR(DATA_BUF,SIZE,1)= THEIR.QUOTE;
       SIZE= SIZE + LENGTHC(THEIR.QUOTE);
       IF (CHR7 = MY.QUOTE)  OR
          (BINARY_QUOTING  AND  CHR7=MY.QBIN)  OR
          (REPEATING AND CHR7=MY.REPT) THEN
          CHR7= CHR;
       ELSE
          CALL CTL( CHR7,CHR );
       END;
    ELSE
       CHR7= CHR;

    SUBSTR(DATA_BUF,SIZE,1)= CHR7;
    SIZE= SIZE + LENGTHC(CHR7);

RE_TURN:
    RETURN;

END STUFF_CHAR_IN_PACKET;
%EJECT;
/****
*
*   T O C H A R
*
*   Make SRCE printable by adding a space (ASCII 32) to it and return the
*   result in DEST_UBIN if it was passed or DEST if it wasn't.  The UNCHAR
*   subroutine does the reverse of this.
*
****/

TOCHAR: PROC( DEST,SRCE,DEST_UBIN );
DCL DEST                     UBIN(9)   CALIGNED;
DCL SRCE                     UBIN(9)   CALIGNED;
DCL DEST_UBIN                UBIN;

    IF ADDR(DEST_UBIN) = ADDR(NIL) THEN
       DEST= SRCE + ASCBIN(' ');
    ELSE
       DEST_UBIN= SRCE + ASCBIN(' ');
RE_TURN:
    RETURN;

END TOCHAR;
%EJECT;
/****
*
*   U N C H A R
*
*   Restore SRCE back to its original value by subtracting a space (ASCII 32)
*   from it and return the result in DEST_UBIN if it was passed or DEST if it
*   wasn't.  The TOCHAR subroutine does the reverse of this one.
*
****/

UNCHAR: PROC( DEST,SRCE,DEST_UBIN );
DCL DEST                     UBIN(9)   CALIGNED;
DCL SRCE                     UBIN(9)   CALIGNED;
DCL DEST_UBIN                UBIN;

    IF ADDR(DEST_UBIN) = ADDR(NIL) THEN
       DEST= SRCE - ASCBIN(' ');
    ELSE
       DEST_UBIN= SRCE - ASCBIN(' ');
RE_TURN:
    RETURN;

END UNCHAR;
%EJECT;
/****
*
*   U N F I D
*
*   Get the file name that DCB number DCB# is OPEN to and return the name in
*   FID and the length of the name in FID_LEN.
*
****/

UNFID: PROC( DCB#,FID,FID_LEN )  ALTRET;
DCL DCB#                     UBIN;
DCL FID                      CHAR(FIDLEN);
DCL FID_LEN                  SBIN;

DCL FIDLEN                   SBIN;

    IF NOT DCBADDR(DCB#)->F$DCB.FCD# THEN     /* If the DCB is not OPEN       */
       CALL OPEN_FID( DCB#,' ',0 )  ALTRET( PUT_ERR );  /* OPEN it.           */
    FIDLEN= FID_LEN;
    FPT_UNFID.V.DCB#= DCB#;
    FPT_UNFID.LEN_= VECTOR(FID_LEN);
    FPT_UNFID.TEXTFID_= VECTOR(FID);
    CALL M$UNFID( FPT_UNFID )  ALTRET( PUT_ERR );
RE_TURN:
    RETURN;

PUT_ERR:
    ERRDCB#= %ERRDCB;
    CALL XUR$ERRMSG( %MONERR,ERRDCB# );       /* Output error message         */
ALT_RETURN:
    ALTRETURN;

END UNFID;
%EJECT;
/****
*
*   W R I T E _ L O G _ R E C
*
*   Write a record into the LOG file (if one is OPEN).
*
****/

WRITE_LOG_REC: PROC( REC_KEY,MSG_LEN );
DCL REC_KEY                  UBIN;
DCL MSG_LEN                  UBIN;

    IF NOT F$LOG$->F$DCB.FCD# THEN            /* Is F$LOG OPEN?               */
       GOTO RE_TURN;                          /* Nope, Don't bother logging!  */

    LOG_KEY.EDIT= ((LOG_KEY.EDIT/1000)*1000) + ((REC_KEY/10)*10);
    F_FDS.DCB#= 0;

    DO SELECT( REC_KEY );

       SELECT( %LOG_HEADER# );
          CALL M$TIME( GET_UTS );
          CALL M$TIME( CONVERT_UTS );
          LOG_KEY.EDIT= LOG_KEY.EDIT + 1000;
          DAYU(1)= DAYU(1) + (ASCBIN('a')-ASCBIN('A'));
          DAYU(2)= DAYU(2) + (ASCBIN('a')-ASCBIN('A'));
          MMMDDYYU(1)= MMMDDYYU(1) + (ASCBIN('a')-ASCBIN('A'));
          MMMDDYYU(2)= MMMDDYYU(2) + (ASCBIN('a')-ASCBIN('A'));
          CALL X$WRITE( F_FDS,FMT17_,VECTOR(DAY),
                                     VECTOR(SUBSTR(MMMDDYY,0,6)),
                                     VECTOR(SUBSTR(MMMDDYY,8,2)),
                                     VECTOR(SUBSTR(HHMMSSSS,0,8)),
                                     VECTOR(B$JIT.ACCN),
                                     VECTOR(B$JIT.UNAME) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );
          START_UTS= UTS;

       SELECT( %LOG_STRT_SEND# );
          WHAT= 'Started but didn''t finish sending';
          GOTO TELL_ABOUT_SEND;

       SELECT( %LOG_END_SEND# );
          WHAT= 'Sent ';
TELL_ABOUT_SEND:
          IF PACKET_FID = CP6_FID THEN
             CALL X$WRITE( F_FDS,FMT19_,VECTOR(WHAT),
                                        VECTOR(CP6_FID),
                                        VECTOR(F$IN$->F$DCB.NRECS#),
                                        VECTOR(MODE) );
          ELSE
             CALL X$WRITE( F_FDS,FMT18_,VECTOR(WHAT),
                                        VECTOR(CP6_FID),
                                        VECTOR(PACKET_FID),
                                        VECTOR(F$IN$->F$DCB.NRECS#),
                                        VECTOR(MODE) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( %LOG_STRT_RECEIVE# );
          WHAT= 'Started but DIDN''T finish receiving';
          IF PACKET_FID = CP6_FID THEN
             CALL X$WRITE( F_FDS,FMT29_,VECTOR(WHAT),
                                        VECTOR(CP6_FID),
                                        VECTOR(MODE) );
          ELSE
             CALL X$WRITE( F_FDS,FMT30_,VECTOR(WHAT),
                                        VECTOR(PACKET_FID),
                                        VECTOR(CP6_FID),
                                        VECTOR(MODE) );
          GOTO TELL_ABOUT_RECEIVE;

       SELECT( %LOG_END_RECEIVE# );
          WHAT= 'Received';
          IF PACKET_FID = ' ' THEN
             CALL X$WRITE( F_FDS,FMT20_,VECTOR(WHAT),
                                        VECTOR(CP6_FID),
                                        VECTOR(IO_CNT),
                                        VECTOR(MODE) );
          ELSE
             CALL X$WRITE( F_FDS,FMT21_,VECTOR(WHAT),
                                        VECTOR(PACKET_FID),
                                        VECTOR(CP6_FID),
                                        VECTOR(IO_CNT),
                                        VECTOR(MODE) );
TELL_ABOUT_RECEIVE:
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( %LOG_MAX_PACKET_SIZES# );
          CALL X$WRITE( F_FDS,FMT22_,VECTOR(THEIR.PACKET_LENGTH),
                                     VECTOR(MY.PACKET_LENGTH) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( %LOG_NUM_DATA_PACKETS# );
          CALL X$WRITE( F_FDS,FMT23_,VECTOR(NUM_DATA_PACKETS),
                                     VECTOR(FILE_BYTE_CNT) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( %LOG_NUM_BYTES_SENT# );

       SELECT( %LOG_NUM_BYTES_RCVD# );

       SELECT( %LOG_ELAPSED_TIME# );
          CALL M$TIME( GET_UTS );
          END_UTS= UTS;
          UTS= END_UTS - START_UTS;
          CALL M$TIME( CONVERT_UTS );
          I= 0;
          DO UNTIL( (I>=LENGTHC(HHMMSSSS)-5)  OR
                    (SUBSTR(HHMMSSSS,I,1) ~= '0'  AND
                     SUBSTR(HHMMSSSS,I,1) ~= ':') );
             I= I + 1;
             END;
          ME_BUF= 'Elapsed time: ';
          L= LENGTHC('Elapsed time: ');

          IF I < 3 THEN DO;                   /* Did it take hours?           */
             IF SUBSTR(HHMMSSSS,0,2) = '01' THEN /* Yep, just one?            */
                SUBSTR(ME_BUF,L)= 'One';      /* Yep, spell it                */
             ELSE
                IF SUBSTR(HHMMSSSS,0,1) = '0' THEN /* < 10 hours?             */
                   SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,1,1);  /* Yep, 1 digit   */
                ELSE
                   SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,0,2);   /* Rediculous!   */
             CALL INDEX( L,'  ',ME_BUF );
             IF SUBSTR(HHMMSSSS,0,2) = '01' THEN /* Just one hour?            */
                SUBSTR(ME_BUF,L)= ' Hour, ';   /* Yep, proper grammar counts! */
             ELSE
                SUBSTR(ME_BUF,L)= ' Hours, ';   /* Plural                     */
             CALL INDEX( L,', ',ME_BUF );
             L= L + LENGTHC(', ');
             END;

          IF I < 6 THEN DO;                   /* Any minutes?                 */
             IF SUBSTR(HHMMSSSS,3,2) = '00' THEN /* Zero minutes?             */
                SUBSTR(ME_BUF,L)= 'No';       /* Nope, spell it               */
             ELSE
                IF SUBSTR(HHMMSSSS,3,2) = '01' THEN /* Just one minute?       */
                   SUBSTR(ME_BUF,L)= 'One';   /* Yep, spell it                */
                ELSE
                   IF SUBSTR(HHMMSSSS,3,1) = '0' THEN  /* < 10 minutes?       */
                      SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,4,1); /* One digit    */
                   ELSE
                      SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,3,2);
             CALL INDEX( L,'  ',ME_BUF );
             IF SUBSTR(HHMMSSSS,3,2) = '01' THEN  /* Just one minute?         */
                SUBSTR(ME_BUF,L)= ' Minute and';    /* Again, grammar counts! */
             ELSE
                SUBSTR(ME_BUF,L)= ' Minutes and';
             CALL INDEX( L,'  ',ME_BUF );
             L= L + LENGTHC(' ');
             END;

          IF SUBSTR(HHMMSSSS,6,5) = '00.00' THEN    /* Zero seconds?          */
             SUBSTR(ME_BUF,L)= 'No';          /* Yep, spell it                */
          ELSE
             IF SUBSTR(HHMMSSSS,6,1) = '0' THEN  /* less than 10 seconds?     */
                SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,7,4); /* Yep                */
             ELSE
                SUBSTR(ME_BUF,L)= SUBSTR(HHMMSSSS,6,5);
          CALL INDEX( L,'  ',ME_BUF );
          SUBSTR(ME_BUF,L)= ' Seconds';
          CALL M$GLINEATTR( FPT_GLINEATTR );
          CALL X$WRITE( F_FDS,FMT27_,VECTOR(ME_BUF),
                                     VECTOR(SPEED(VLP_LINEATTR.LINESPEED#)),
                                     VECTOR(PARITY_TBL(VLP_GTRMATTR.PARITY#)) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( %LOG_ERRMSG# );
          CALL X$WRITE( F_FDS,FMT28_,VECTOR(SUBSTR(ERR_BUF,0,MSG_LEN)) );
          WRITE_LOG.BUF_= VECTOR(SUBSTR(LO_BUF,1,F_FDS.BUFX-1));
          CALL M$WRITE( WRITE_LOG );

       SELECT( ELSE );

       END;

RE_TURN:
    RETURN;

END WRITE_LOG_REC;
%EJECT;
/****
*
*   W R I T E _ R E C O R D
*
*   Write a record to the file being RECEIVEd.
*
****/

WRITE_RECORD: PROC( BUF,LEN )  ALTRET;
DCL BUF                      CHAR(LEN);
DCL LEN                      SBIN;

    OUT_KEY.EDIT= OUT_KEY.EDIT + 1000;
    IF LEN <= 0 THEN
       WRITE_OUT.BUF_= VECTOR(NIL);
    ELSE
       WRITE_OUT.BUF_= VECTOR(SUBSTR(BUF,0,LEN));
    CALL XSA$WRITE( WRITE_OUT,XSA_PARAM )  ALTRET( CANT_WRITE );
    IO_CNT= IO_CNT + 1;
    FILE_BYTE_CNT= FILE_BYTE_CNT + LEN + EOR_BYTE_LEN;
    CALL LOG( %DEBUG_WRITE##,BUF,LEN );
    IO_BUF= ' ';
    IO_LEN= 0;
    TX= 0;
RE_TURN:
    RETURN;

CANT_WRITE:
    CALL SEND_ERROR_PACKET;
ALT_RETURN:
    ALTRETURN;

END WRITE_RECORD;

END KERMIT;
%EOD;
KERMIT$BREAK: PROC  ASYNC;

DCL BRK_CNT                  SBIN      SYMREF;

    BRK_CNT= BRK_CNT + 1;
RE_TURN:
    RETURN;

END KERMIT$BREAK;