$title('PERIPHERAL INTERCHANGE PROGRAM')
PIPMOD:
    DO;
/* P E R I P H E R A L  I N T E R C H A N G E  P R O G R A M

         COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982
         DIGITAL RESEARCH
         BOX 579
         PACIFIC GROVE, CA
         93950

         Revised:
            17 Jan 80  by  Thomas Rolander (MP/M 1.1)
            05 Oct 81  by  Ray Pedrizetti  (MP/M-86 2.0)
            18 Dec 81  by  Ray Pedrizetti  (CP/M-86 1.1)
            29 Jun 82  by  Ray Pedrizetti  (CCP/M-86 3.0) */

/*    Command lines used for CMD file generation         */

/* (on VAX)
	asm86 scd1.a86
        asm86 inpout.a86
	plm86 pip.plm debug xref optimize(3)
	link86 scd1.obj,inpout.obj,pip.obj, to pip.lnk
	loc86 pip.lnk od(sm(code,dats,data,const,stack)) -
              ad(sm(code(0), dats(10000h)))  ss(stack(+32)) to pip.
	h86 pip

   (on a micro)
	vax pip.h86 $fans
	gencmd pip data[b1000 m280 xfff]

        * note the beginning of the data segment will change when
	* the program is changed. see the 'MP2' file generated
	* by LOC86.  the constants are last to force hex generation
   */

   /* Compiler Directives */
/** $set (mpm) **/
/** $reset (cpm3) **/
/** $cond **/

declare    /* resets stack for error handling */
    reset label external;

DECLARE
    MAXB  ADDRESS EXTERNAL,     /* ADDR FIELD OF JMP BDOS */
    FCB (33) BYTE EXTERNAL,     /* DEFAULT FILE CONTROL BLOCK */
    BUFF(128)BYTE EXTERNAL;     /* DEFAULT BUFFER */

declare
    retry byte initial(0);  /* true if error has occured */

OUTD: PROCEDURE(B) external;
    DECLARE B BYTE;
    /* SEND B TO OUT: DEVICE */
    END OUTD;

INPD: PROCEDURE BYTE external;
    END INPD;

MON1: PROCEDURE(F,A) EXTERNAL;
    DECLARE F BYTE,
    A ADDRESS;
    END MON1;

MON2: PROCEDURE(F,A) BYTE EXTERNAL;
    DECLARE F BYTE,
    A ADDRESS;
    END MON2;

MON3: PROCEDURE(F,A) ADDRESS EXTERNAL;
    DECLARE F BYTE,
    A ADDRESS;
    END MON3;


plm: procedure public;

DECLARE
/** $if mpm **/
    VERSION  LITERALLY '0031H', /* REQUIRED FOR BDOS 3.1 OPERATION */
/** $else **/
/** $endif **/

    ENDFILE LITERALLY '1AH';    /* END OF FILE MARK */

DECLARE COPYRIGHT(*) BYTE DATA (
/** $if cpm3 **/
        ' (12/06/82) CP/M 3 PIP VERS 3.0 ');
/** $else **/
/** $endif **/


    /* LITERAL DECLARATIONS */
DECLARE
    LIT  LITERALLY 'LITERALLY',
    LPP  LIT '60',     /* LINES PER PAGE */
    TAB  LIT '09H',    /* HORIZONTAL TAB */
    FF   LIT '0CH',    /* FORM FEED */
    LA   LIT '05FH',   /* LEFT ARROW */
    LB   LIT '05BH',   /* LEFT BRACKET */
    RB   LIT '05DH',   /* RIGHT BRACKET */

    FSIZE  LIT '33',
    FRSIZE LIT '36',   /* SIZE OF RANDOM FCB */
    NSIZE  LIT '8',
    FNSIZE LIT '11',
    FEXT   LIT '9',
    FEXTL  LIT '3',

        /* scanner return type code */
    outt     LIT '0',   /* output device */
    PRNT     LIT '1',   /* PRINTER */
    LSTT     LIT '2',   /* list device */
    axot     lit '3',   /* auxilary output device */
    FILE     LIT '4',   /* file type */
    auxt     lit '5',   /* auxilary input/output device */
    CONS     LIT '6',   /* CONSOLE */
    axit     LIT '7',   /* auxilary input device */
    inpt     lit '8',   /* input device */
    NULT     LIT '9',   /* nul characters */
    EOFT     LIT '10',   /* EOF character */
    ERR      LIT '11',  /* error type */
    SPECL    LIT '12',  /* special character */
    DISKNAME LIT '13';  /* diskname letter */

DECLARE
    SEARFCB LIT 'FCB';   /* SEARCH FCB IN MULTI COPY */

DECLARE
    TRUE    LIT '1',
    FALSE   LIT '0',
    FOREVER LIT 'WHILE TRUE',
    cntrlc  lit '3',
    CR      LIT '13',
    LF      LIT '10',
    WHAT    LIT '63';

/** $if mpm **/
declare
    maxmcnt lit '128',    /* maximum multi sector count */
    maxmbuf lit '16384';  /* maximum multi sector buffer size */
/** $endif **/

DECLARE
    COLUMN   BYTE,      /* COLUMN COUNT FOR PRINTER TABS */
    LINENO   BYTE,      /* LINE WITHIN PAGE */
    FEEDBASE BYTE,      /* USED TO FEED SEARCH CHARACTERS */
    FEEDLEN  BYTE,      /* LENGTH OF FEED STRING */
    MATCHLEN BYTE,      /* USED IN MATCHING STRINGS */
    QUITLEN  BYTE,      /* USED TO TERMINATE QUIT COMMAND */
    CDISK    BYTE,      /* CURRENT DISK */
    SBLEN    ADDRESS,   /* SOURCE BUFFER LENGTH */
    DBLEN    ADDRESS,   /* DEST BUFFER LENGTH */
    tblen    address,   /* temp buffer length */
    SBASE    ADDRESS,   /* SOURCE BUFFER BASE */

    /* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION
    1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */
    DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */
    SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */

        /* source fcb, password and password mode */
    source structure (
        fcb(frsize)  byte,
/** $if mpm **/
        pwnam(nsize) byte,
        pwmode       byte,
/** $endif **/
        user         byte,
        type         byte ),

        /* temporary destination fcb, password and password mode */
    dest structure (
        fcb(frsize)  byte,
/** $if mpm **/
        pwnam(nsize) byte,
        pwmode       byte,
/** $endif **/
        user         byte,
        type         byte ),

        /* original destination fcb, password and password mode */
    odest structure (
        fcb(frsize)  byte,
/** $if mpm **/
        pwnam(nsize) byte,
        pwmode       byte,
/** $endif **/
        user         byte,
        type         byte ),

    filsize(3) byte,     /* file size random record number */

    DESTR    ADDRESS AT(.DEST.FCB(33)),    /* RANDOM RECORD POSITION */
    SOURCER  ADDRESS AT(.SOURCE.FCB(33)),  /* RANDOM RECORD POSITION */
    DESTR2   BYTE    AT(.DEST.FCB(35)),    /* RANDOM RECORD POSITION R2 */
    SOURCER2 BYTE    AT(.SOURCE.FCB(35)),  /* RANDOM RECORD POSITION R2 */

    extsave  byte,      /* temp extent byte for bdos bug */

    nsbuf   address,    /* next source buffer */ 
/** $if mpm **/
    bufsize address,    /* multsect buffer size */
    mseccnt  byte,      /* last multi sector count value */
/** $endif **/
    NSOURCE ADDRESS,    /* NEXT SOURCE CHARACTER */
    NDEST   ADDRESS;    /* NEXT DESTINATION CHARACTER */

DECLARE
    fastcopy byte,      /* true if copy directly to dbuf */
    dblbuf   byte,      /* true if both source and dest buffer used */
    concat   byte,      /* true if concatination command */
    ambig    byte,      /* true if file is ambig type */
    dfile    byte,      /* true if dest is file type */
    sfile    byte,      /* true if source is file type */
    made     byte,      /* true if destination file already made */
    opened   byte,      /* true if source file open */
    endofsrc byte,      /* true if end of source file */
    nendcmd  byte,      /* true if not end of command tail */
    insparc  byte,      /* true if in middle of sparce file */
    sparfil  byte,      /* true if sparce file being copied */
    MULTCOM  BYTE,      /* true if processing multiple commands */
    PUTNUM   BYTE,      /* SET WHEN READY FOR NEXT LINE NUM */
    CONCNT   BYTE,      /* COUNTER FOR CONSOLE READY CHECK */
    CHAR     BYTE,      /* LAST CHARACTER SCANNED */
    FLEN     BYTE;      /* FILE NAME LENGTH */

declare
    f1     byte,        /* f1 user attribute flag */
    f2     byte,        /* f2 user attribute flag */
    f3     byte,        /* f3 user attribute flag */
    f4     byte,        /* f4 user attribute flag */
    ro     byte,        /* read only attribute flag */
    sys    byte,        /* system attribute flag */
/** $if mpm **/
    exten  byte,        /* extention error code */
    odcnt  byte,        /* saves dcnt for open dest file */
    eretry byte,        /* error return flag */
/** $endif **/
    dcnt   byte;        /* error code or directory code */


DECLARE CBUFF(130) BYTE,   /* COMMAND BUFFER */
    MAXLEN       BYTE AT (.CBUFF(0)),  /* MAX BUFFER LENGTH */
    COMLEN       BYTE AT (.CBUFF(1)),  /* CURRENT LENGTH */
    COMBUFF(128) BYTE AT (.CBUFF(2)),  /* COMMAND BUFFER CONTENTS */
    CBP          BYTE;                 /* COMMAND BUFFER POINTER */

DECLARE
    CUSER BYTE, /* CURRENT USER NUMBER */
    last$user byte;

DECLARE /* CONTROL TOGGLE VECTOR */
    CONT(26) BYTE,   /* ONE FOR EACH ALPHABETIC */
    /* 00 01 02 03 04 05 06 07 08 09 10 11 12 13
        A  B  C  D  E  F  G  H  I  J  K  L  M  N
       14 15 16 17 18 19 20 21 22 23 24 25
        O  P  Q  R  S  T  U  V  W  X  Y  Z   */
    archiv byte  at(.cont(0)),     /* file archive */
    confrm byte  at(.cont(2)),     /* confirm copy */
    DELET  BYTE  AT(.CONT(3)),     /* DELETE CHARACTERS */
    ECHO   BYTE  AT(.CONT(4)),     /* ECHO CONSOLE CHARACTERS */
    FORMF  BYTE  AT(.CONT(5)),     /* FORM FILTER */
    GETU   BYTE  AT(.CONT(6)),     /* GET FILE, USER # */
    HEXT   BYTE  AT(.CONT(7)),     /* HEX FILE TRANSFER */
    IGNOR  BYTE  AT(.CONT(8)),     /* IGNORE :00 RECORD ON FILE */
    kilds  byte  at(.cont(10)),    /* kill filename display */
    LOWER  BYTE  AT(.CONT(11)),    /* TRANSLATE TO LOWER CASE */
    NUMB   BYTE  AT(.CONT(13)),    /* NUMBER OUTPUT LINES */
    OBJ    BYTE  AT(.CONT(14)),    /* OBJECT FILE TRANSFER */
    PAGCNT BYTE  AT(.CONT(15)),    /* PAGE LENGTH */
    QUITS  BYTE  AT(.CONT(16)),    /* QUIT COPY */
    RSYS   BYTE  AT(.CONT(17)),    /* READ SYSTEM FILES */
    STARTS BYTE  AT(.CONT(18)),    /* START COPY */
    TABS   BYTE  AT(.CONT(19)),    /* TAB SET */
    UPPER  BYTE  AT(.CONT(20)),    /* UPPER CASE TRANSLATE */
    VERIF  BYTE  AT(.CONT(21)),    /* VERIFY EQUAL FILES ONLY */
    WRROF  BYTE  AT(.CONT(22)),    /* WRITE TO R/O FILE */
    ZEROP  BYTE  AT(.CONT(25));    /* ZERO PARITY ON INPUT */

DECLARE ZEROSUP BYTE,  /* ZERO SUPPRESSION */
    (C3,C2,C1) BYTE;     /* LINE COUNT ON PRINTER  */


/** $if mpm **/
retcodes: procedure(a);
    declare a address;
    dcnt = low(a);
    exten = high(a);
    end retcodes;
/** $endif **/

BOOT: PROCEDURE;
    /* SYSTEM REBOOT */
    CALL MON1(0,0);
    END BOOT;


RDCHAR: PROCEDURE BYTE;
    /* READ CONSOLE CHARACTER */
    RETURN MON2(1,0);
    END RDCHAR;

PRINTCHAR: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    CALL MON1(2,CHAR AND 7FH);
    END PRINTCHAR;

CRLF: PROCEDURE;
    CALL PRINTCHAR(CR);
    CALL PRINTCHAR(LF);
    END CRLF;

printx: procedure(a);
    declare a address;
    call mon1(9,a);
    end printx;

PRINT: PROCEDURE(A);
    DECLARE A ADDRESS;
    /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
    NEXT DOLLAR SIGN IS ENCOUNTERED */
    CALL CRLF;
    CALL printx(A);
    END PRINT;

RDCOM: PROCEDURE;
    /* READ INTO COMMAND BUFFER */
    MAXLEN = 128;
    CALL MON1(10,.MAXLEN);
    END RDCOM;

CVERSION: PROCEDURE ADDRESS;
    RETURN MON3(12,0); /* VERSION NUMBER */
    END CVERSION;

SETDMA: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL MON1(26,A);
    END SETDMA;

/** $if mpm **/
setpw: procedure(fcba);
    declare fcba address;
    declare fcbs based fcba structure (
        fcb(frsize) byte,
        pwnam(nsize) byte );
    call setdma(.fcbs.pwnam(0));
    end setpw;
/** $endif **/

OPEN: PROCEDURE(fcba);
    DECLARE fcba ADDRESS;
    declare fcb based fcba (frsize) byte;
/** $if mpm **/
    CALL SETPW(fcba);
    call retcodes(mon3(15,fcba));
/** $else **/
/** $endif **/
    if dcnt <> 255 and rol(fcb(8),1) then
        do; call mon1(16,fcba);
        dcnt = 255;
/** $if mpm **/
        exten = 0;
/** $endif **/
        end;
    END OPEN;

CLOSE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(MON3(16,FCB));
/** $else **/
/** $endif **/
    END CLOSE;

SEARCH: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(MON3(17,FCB));
/** $else **/
/** $endif **/
    END SEARCH;

SEARCHN: PROCEDURE;
/** $if mpm **/
    call retcodes(MON3(18,0));
/** $else **/
/** $endif **/
    END SEARCHN;

DELETE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    CALL SETPW(FCB);
    call retcodes(MON3(19,FCB));
/** $else **/
/** $endif **/
    END DELETE;

DISKRD: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(MON3(20,FCB));
/** $else **/
/** $endif **/
    END DISKRD;

DISKWRITE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(MON3(21,FCB));
/** $else **/
/** $endif **/
    END DISKWRITE;

MAKE: procedure(fcba);
    declare fcba address;
/** $if mpm **/
    declare fcbs based fcba structure (
        fcb(frsize) byte,
        pwnam(nsize) byte );
    if fcbs.pwnam(0) = 0 then   /* zero if no password */
        fcbs.fcb(6) = fcbs.fcb(6) and 7fh;  /* reset password attribute */
    else do;
        fcbs.fcb(6) = fcbs.fcb(6) or 80h;  /* set password attribute */
        call setdma(.fcbs.pwnam(0));  /* set password dma */
        end;
    call retcodes(mon3(22,fcba));
/** $else **/
/** $endif **/
    END MAKE;

RENAME: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    CALL SETPW(FCB);
    call retcodes(MON3(23,FCB)) ;
/** $else **/
/** $endif **/
    END RENAME;

getdisk: procedure byte;
    return mon2(25,0);
    end getdisk;

SETIND: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(MON3(30,FCB));
/** $else **/
/** $endif **/
    END SETIND;

GETUSER: PROCEDURE BYTE;
    RETURN MON2(32,0FFH);
    END GETUSER;

SETUSER: PROCEDURE(USER);
    DECLARE USER BYTE;
    if last$user <> user then
        CALL MON1(32,(last$user:=USER));
    END SETUSER;

SETCUSER: PROCEDURE;
    CALL SETUSER(CUSER);
    END SETCUSER;

setduser: procedure;
    call setuser(odest.user);
    end setduser;

SETSUSER: PROCEDURE;
    CALL SETUSER(source.user);
    END SETSUSER;

RD$RANDOM: PROCEDURE(FCB) BYTE;
    DECLARE FCB ADDRESS;
/** $if mpm **/
    call retcodes(mon3(33,fcb));
/** $else **/
/** $endif **/
    return dcnt;
    END RD$RANDOM;

write$random: procedure(fcb) byte;
    declare fcb address;
/** $if mpm **/
    call retcodes(mon3(34,fcb));
/** $else **/
/** $endif **/
    return dcnt;
    end write$random;

retfsize: procedure(fcb) byte;
    declare fcb address;
    return mon2(35,fcb);
    end retfsize;

SET$RANDOM: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    /* SET RANDOM RECORD POSITION */
    CALL MON1(36,FCB);
    END SET$RANDOM;

/** $if mpm **/
multsect: procedure(cnt);
    declare cnt byte;
    if mseccnt <> cnt then
        call mon1(44,(mseccnt := cnt));
    end multsect;

flushbuf: procedure;
    call mon1(48, 0ffh);	/* 0FFH = flush and discard buffers */
    end flushbuf;

conatlst: procedure byte;
    return mon2(161,0);
    end conatlst;
/** $endif **/


MOVE: PROCEDURE(S,D,N);
    DECLARE (S,D) ADDRESS, N BYTE;
    DECLARE A BASED S BYTE, B BASED D BYTE;
        DO WHILE (N:=N-1) <> 255;
        B = A; S = S+1; D = D+1;
        END;
    END MOVE;

    /* errtype error messages */
    declare er00(*) byte data ('DISK READ$');
    declare er01(*) byte data ('DISK WRITE$');
    declare er02(*) byte data ('VERIFY$');
    declare er03(*) byte data ('INVALID DESTINATION$');
    declare er04(*) byte data ('INVALID SOURCE$');
    declare er05(*) byte data ('USER ABORTED$');
    declare er06(*) byte data ('BAD PARAMETER$');
    declare er07(*) byte data ('INVALID USER NUMBER$');
    declare er08(*) byte data ('INVALID FORMAT$');
    declare er09(*) byte data ('HEX RECORD CHECKSUM$');
    declare er10(*) byte data ('FILE NOT FOUND$');
    declare er11(*) byte data ('START NOT FOUND$');
    declare er12(*) byte data ('QUIT NOT FOUND$');
    declare er13(*) byte data ('INVALID HEX DIGIT$');
    declare er14(*) byte data ('CLOSE FILE$');
    declare er15(*) byte data ('UNEXPECTED END OF HEX FILE$');
    declare er16(*) byte data ('INVALID SEPARATOR$');
    declare er17(*) byte data ('NO DIRECTORY SPACE$');
    declare er18(*) byte data ('INVALID FORMAT WITH SPARCE FILE$');
/** $if mpm **/
    declare er19(*) byte data ('MAKE FILE$');
    declare er20(*) byte data ('OPEN FILE$');
    declare er21(*) byte data ('PRINTER BUSY$');
    declare er22(*) byte data ('CAN''T DELETE TEMP FILE$');
/** $endif **/

    declare errmsg(*) address data(
        .er00,.er01,.er02,.er03,.er04,
        .er05,.er06,.er07,.er08,.er09,
        .er10,.er11,.er12,.er13,.er14,
        .er15,.er16,.er17,.er18
/** $if mpm **/
        ,.er19,.er20,.er21,.er22
/** $endif **/
        );

    declare sper00(*) byte data ('NO DIRECTORY SPACE$');
    declare sper01(*) byte data ('NO DATA BLOCK$');
    declare sper02(*) byte data ('CAN''T CLOSE CURRENT EXTENT$');
    declare sper03(*) byte data ('SEEK TO UNWRITTEN EXTENT$');
    declare sper05(*) byte data ('RANDOM RECORD OUT OF RANGE$');
    declare sper06(*) byte data ('RECORDS DON''T MATCH$');
    declare sper07(*) byte data ('RECORD LOCKED$');
    declare sper08(*) byte data ('INVALID FILENAME$');
    declare sper09(*) byte data ('FCB CHECKSUM$');

    declare numspmsgs lit '10';  /* number of extended messages */
    declare special$msg(numspmsgs) address data(
        .sper00,.sper01,.sper02,.sper03,.sper00,
        .sper05,.sper06,.sper07,.sper08,.sper09);

/** $if mpm **/
    /* extended error messages */
    declare ex00(*) byte data ('$');  /* NO MESSAGE */
    declare ex01(*) byte data ('NONRECOVERABLE$');
    declare ex02(*) byte data ('R/O DISK$');
    declare ex03(*) byte data ('R/O FILE$');
    declare ex04(*) byte data ('INVALID DISK SELECT$');
    declare ex05(*) byte data ('INCOMPATIBLE MODE$');
    declare ex07(*) byte data ('INVALID PASSWORD$');
    declare ex08(*) byte data ('ALREADY EXISTS$');
    declare ex10(*) byte data ('LIMIT EXCEEDED$');

    declare nummsgs lit '11';  /* number of extended messages */
    declare extmsg(nummsgs) address data(
        .ex00,.ex01,.ex02,.ex03,.ex04,
        .ex05,.sper09,.ex07,.ex08,.sper08,
        .ex10);
/** $endif **/

error$cleanup: procedure;
/** $if mpm **/
    call multsect(1);
/** $endif **/
    eretry = 0;   /* initialize to no error retry */
    if opened then   /* if source file opened */
        do; call setsuser;
        call close(.source);
        opened = false;
        end;
    if made then
        do; call setduser;
        call close(.dest);
        call delete(.dest);  /* delete destination scratch file */
        end;
    /* Zero the command length in case this is a single command */
       comlen = 0;
       retry = true;
       call print(.('ERROR: $'));
    end error$cleanup;

error: procedure (errtype);
    declare errtype byte;

    call error$cleanup;
    call printx(errmsg(errtype));
    call crlf;
    go to reset;
    end error;

xerror: procedure (funcno,fileadr);
    declare temp    byte,
            i       byte,
            sdcnt   byte,
            sexten  byte,
            funcno  byte,
            fileadr address,
            fcb based fileadr (fsize) byte;

    declare message$index$tbl(17) byte data
            (2,18,13,15,9,3,10,20,14,10,22,17,19,0,1,0,1);

    sdcnt = dcnt;
    sexten = exten;
    call error$cleanup;

    if (funcno < 6) or (sdcnt <> 0ffh) then
       sexten = 0;
    else sexten = sexten and 0fh;

    call printx(errmsg(message$index$tbl(funcno)));

    if (funcno > 12) and (funcno < 17) and
       (sdcnt <> 0ffh) and (sdcnt <= numspmsgs) then
       do; call printchar(' ');
       call printx(special$msg(sdcnt-1));
       sexten = 0;
       end;

/** $if mpm **/
    if sexten < nummsgs then
       do; call printchar(' ');
       call printx(extmsg(sexten));
       end;
/** $endif **/

    call printx(.(' - $'));
    if fileadr <> 0 then
        do; call printchar('A' + fcb(0) - 1);
        call printchar(':');
            do i = 1 to fnsize;
            if (temp := fcb(i) and 07fh) <> ' ' then
                do; if i = fext then call printchar('.');
                call printchar(temp);
                end;
            end;
        end;
    call crlf;

    if (sdcnt = 3) or (sdcnt = 4) or (sdcnt = 6) or (sdcnt = 8) then
       eretry = ambig;
    else
       if (sexten = 3) or ((sexten > 4) and (sexten < 9)) or (sexten > 9) then
            eretry = ambig;

    go to reset;
    end xerror;

FORMERR: PROCEDURE;
    call error(8);  /* invalid format */
    END FORMERR;

CONBRK: PROCEDURE;
    /* CHECK CONSOLE CHARACTER READY */
    if mon2(11,0) <> 0 then
        if mon2(6,0fdh) = cntrlc then
           call error(5);
    END CONBRK;

MAXSIZE: procedure byte;
    /* three byte compare of random record field
       returns true if source.fcb.ranrec >= filesize */

    if (source.fcb(35) < filsize(2)) then
      return false;
    if (source.fcb(35) = filsize(2)) then
      do;
      if (source.fcb(34) < filsize(1)) then
        return false;
      if (source.fcb(34) = filsize(1)) then
        do;
        if (source.fcb(33) < filsize(0)) then
          return false;
        end;
      end;
    return true;
    end maxsize;

SETUPDEST: PROCEDURE;
    call setduser;  /* destination user */
/** $if mpm **/
    call move(.odest,.dest,(frsize + nsize + 1));  /* save original dest */
/** $else **/
/** $endif **/
    /* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
    CALL MOVE(.('$$$'),.DEST.FCB(FEXT),FEXTL);
/** $if mpm **/
    odest.fcb(6) = odest.fcb(6) or 80h;
    call open(.odest);  /* try to open destination file */
    odcnt = dcnt;       /* and save error code */
    if odcnt <> 255 then
        call close(.odest);
    else if (exten and 0fh) <> 0 then /* file exists */
        call xerror(7,.odest);        /* but can't open - error */

    CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */
    if dcnt = 255 and exten <> 0 then
        /* cant delete temp file */
        call xerror(10,.dest);
    CALL MAKE(.DEST); /* CREATE A NEW ONE */
    IF DCNT = 255 THEN 
        if (exten and 0fh) = 0 then 
            call xerror(11,.dest);  /* no directory space */
        else call xerror(12,.dest);  /* make file error */
/** $else **/
/** $endif **/
    DEST.FCB(32) = 0;
    made = true;
    END SETUPDEST;

SETUPSOURCE: PROCEDURE;
    declare (i,j) byte;
    CALL SETSUSER; /* SOURCE USER */
/** $if mpm **/
    source.fcb(6) = source.fcb(6) or 80h;
/** $endif **/
    CALL OPEN(.SOURCE);  /* open source */
    if dcnt <> 255 then
        opened = true;
    IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN
        /* skip system file */
        DCNT = 255;
    IF DCNT = 255 THEN
/** $if mpm **/
        if (exten and 0fh) = 0 then
            call xerror(6,.source);  /* file not found */
        else
            call xerror(7,.source);  /* open file error */
/** $else **/
/** $endif **/
    f1 = source.fcb(1) and 80h;  /* save file atributes */
    f2 = source.fcb(2) and 80h;
    f3 = source.fcb(3) and 80h;
    f4 = source.fcb(4) and 80h;
    ro = source.fcb(9) and 80h;
    sys = source.fcb(10) and 80h;
    dcnt = retfsize(.source);
    call move(.source.fcb(33),.filsize,3);
    SOURCE.FCB(32) = 0;
    source.fcb(33),source.fcb(34),source.fcb(35) = 0;
    /* cause immediate read with no preceding write */
    NSOURCE = 0ffffh;
    END SETUPSOURCE;

WRITEDEST: PROCEDURE;
    /* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION
    NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */
    DECLARE (J,DATAOK) BYTE,
        (tdest,n)      address;
    if not made then call setupdest;
    if (n := ndest and 0ff80h) = 0 then return;
    tdest = 0;
    call setduser;  /* destination user */
    if (sparfil := (sparfil or insparc)) then
        /* set up fcb from random record no. */
        do;
/** $if mpm **/
        call multsect(1);
/** $endif **/
        CALL SETDMA(.dbuff(tdest));
        if write$random(.dest) <> 0 then
            call xerror(16,.dest);  /* DISK WRITE ERROR */
        end;
    else
        CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */
/** $if mpm **/
    if fastcopy then
        do; bufsize = maxmbuf;
        call multsect(maxmcnt);
        end;
    else
        do; bufsize = 128;
        call multsect(1);
        end;
/** $endif **/

        do while n - tdest > 127;
/** $if mpm **/
        if fastcopy and (n - tdest < maxmbuf) then
            do; bufsize = n - tdest;
            call multsect(low(shr(bufsize,7)));
            end;
/** $endif **/
        /* SET DMA ADDRESS TO NEXT BUFFER */
        CALL SETDMA(.dbuff(tdest));
        call diskwrite(.dest);
        IF dcnt <> 0 THEN
            call xerror(14,.dest);  /* DISK WRITE ERROR */
/** $if mpm **/
        tdest = tdest + bufsize;
/** $else **/
/** $endif **/
        END;

    IF VERIF THEN /* VERIFY DATA WRITTEN OK */
        DO;
        call flushbuf;
        tdest = 0;
/** $if mpm **/
        call multsect(1);
/** $endif **/
        CALL SETDMA(.BUFF); /* FOR COMPARE */
            do while tdest < n;
            DATAOK = (RDRANDOM(.DEST) = 0);
            if (DESTR := DESTR + 1) = 0 then  /* 3 byte inc for */
                destr2 = destr2 + 1;  /* next random record */
            J = 0;
                /* PERFORM COMPARISON */
                DO WHILE DATAOK AND J < 80H;
                DATAOK = (BUFF(J) = DBUFF(tdest+J));
                J = J + 1;
                END;
            tdest = tdest + 128;
            IF NOT DATAOK THEN
                call xerror(0,.dest);  /* VERIFY ERROR */
            END;
        call diskrd(.dest);
        /* NOW READY TO CONTINUE THE WRITE OPERATION */
        END;
    CALL SETRANDOM(.DEST); /* set base record for sparce copy */
    call move(.dbuff(tdest),.dbuff(0),low(ndest := ndest - tdest));
    END WRITEDEST;

FILLSOURCE: PROCEDURE;
    /* FILL THE SOURCE BUFFER */
    call conbrk;
/** $if mpm **/
    if fastcopy then
        do; bufsize = maxmbuf;
        call multsect(maxmcnt);
        end;
    else do;
        bufsize = 128;
        call multsect(1);
        end;
/** $endif **/
    CALL SETSUSER; /* SOURCE USER NUMBER SET */
    nsource = nsbuf;
        do while sblen - nsbuf > 127; 
        if fastcopy and (sblen - nsbuf < maxmbuf) then
            do; bufsize = (sblen - nsbuf) and 0ff80h;
            call multsect(low(shr(bufsize,7)));
            end;
        /* SET DMA ADDRESS TO NEXT BUFFER POSIITION */
        CALL SETDMA(.SBUFF(nsbuf));
        extsave = source.fcb(12);  /* save extent field */
        call diskrd(.source);
        IF dcnt <> 0 THEN
            DO; IF dcnt <> 1 THEN
                call xerror(13,.source);  /* DISK READ ERROR */
            /* END - OF - FILE */
/** $if mpm **/
            if fastcopy then   /* add no. sectors copied */
                nsbuf = nsbuf + shl(double(exten),7);
             /* nsbuf = nsbuf + shl(double(exten and 0f0h),3); */
/** $endif **/
            /* check boundry condition for bug in bdos and correct */
            if (source.fcb(12) <> extsave) and (source.fcb(32) = 80h) then
                source.fcb(32) = 0;  /* zero current record */
            call set$random(.source);
            if (insparc := not maxsize) then
                do;
                if concat or (not fastcopy) then
                    /* invalid format with sparce file */
                    call xerror(1,.source);
                end;
            else
                do;
                call close(.source);
                opened = false;
                end;
            endofsrc = true;  /* set end of source file */
            SBUFF(nsbuf) = ENDFILE; return;
            END;
        ELSE
/** $if mpm **/
            nsbuf = nsbuf + bufsize;
/** $else **/
/** $endif **/
        END;
    END FILLSOURCE;

PUTDCHAR: PROCEDURE(B);
    DECLARE B BYTE;
    /* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY ODEST.TYPE */
    IF B >= ' ' THEN
        DO; COLUMN = COLUMN + 1;
        IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */
            DO; IF COLUMN > DELET THEN RETURN;
            END;
        END;
    if echo then call mon1(2,b);  /* echo to console */
	do case odest.type;
        /* CASE 0 IS OUT */
            CALL OUTD(B);
        /* CASE 1 IS PRN, TABS EXPANDED, LINES LISTED */
            call mon1(5,b);
        /* CASE 2 IS LST */
            CALL MON1(5,B);
        /* CASE 3 IS axo */
axocase:
/** $if not mpm **/
            CALL MON1(4,B);
/** $else **/
/** $endif **/
        /* CASE 4 IS DESTINATION FILE */
            DO;
            IF NDEST >= DBLEN THEN CALL WRITEDEST;
            DBUFF(NDEST) = B;
            NDEST = NDEST+1;
            END;
        /* CASE 5 IS AUX */
           goto axocase;
        /* CASE 6 IS CON */
            CALL MON1(2,B);
        END; /* of case */
    END PUTDCHAR;

PUTDESTC: PROCEDURE(B);
    DECLARE (B,I) BYTE;
    /* WRITE DESTINATION CHARACTER, TAB EXPANSION */
    IF B <> TAB THEN CALL PUTDCHAR(B);
    ELSE IF TABS = 0 THEN CALL PUTDCHAR(B);
    ELSE  /* B IS TAB CHAR, TABS > 0 */
        DO; I = COLUMN;
            DO WHILE I >= TABS;
            I = I - TABS;
            END;
        I = TABS - I;
            DO WHILE I > 0;
            I = I - 1;
            CALL PUTDCHAR(' ');
            END;
        END;
    IF B = CR THEN COLUMN = 0;
    END PUTDESTC;

PRINT1: PROCEDURE(B);
    DECLARE B BYTE;
    IF (ZEROSUP := ZEROSUP AND B = 0) THEN
        CALL PUTDESTC(' ');
    ELSE
        CALL PUTDESTC('0'+B);
    END PRINT1;

PRINTDIG: PROCEDURE(D);
    DECLARE D BYTE;
    CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B);
    END PRINTDIG;

NEWLINE: PROCEDURE;
    DECLARE ONE BYTE;
    ONE = 1;
    ZEROSUP = (NUMB = 1);
    C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0);
    CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1);
    IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */
        DO; CALL PUTDESTC(':'); CALL PUTDESTC(' ');
        END;
    ELSE
        CALL PUTDESTC(TAB);
    END NEWLINE;

PUTDEST: PROCEDURE(B);
    DECLARE (I,B) BYTE;
    /* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */
    IF FORMF THEN /* SKIP FORM FEEDS */
        DO; IF B = FF THEN RETURN;
        END;
    IF PUTNUM THEN /* END OF LINE OR START OF FILE */
        DO;
        IF (B <> FF) and (b <> endfile) THEN
            DO;    /* NOT FORM FEED or end of file */
            IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */
                DO; IF I=1 THEN I=LPP;
                IF (LINENO := LINENO + 1) >= I THEN
                    DO; LINENO = 0; /* NEW PAGE */
                    CALL PUTDESTC(FF);
                    END;
                END;
            IF NUMB > 0 THEN
                CALL NEWLINE;
            PUTNUM = FALSE;
            END;
        END;
    IF B = FF THEN LINENO = 0;
    CALL PUTDESTC(B);
    IF B = LF THEN PUTNUM = TRUE;
    END PUTDEST;


UTRAN: PROCEDURE(B) BYTE;
    DECLARE B BYTE;
    /* TRANSLATE ALPHA TO UPPER CASE */
    IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */
        B = B AND 101$1111B; /* TO UPPER CASE */
    RETURN B;
    END UTRAN;

LTRAN: PROCEDURE(B) BYTE;
    DECLARE B BYTE;
    /* TRANSLATE TO LOWER CASE ALPHA */
    IF B >= 'A' AND B <= 'Z' THEN
        B = B OR 10$0000B; /* TO LOWER */
    RETURN B;
    END LTRAN;

GETSOURCEC: PROCEDURE BYTE;
    /* READ NEXT SOURCE CHARACTER */
    DECLARE (B,CONCHK) BYTE;

    CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */
        DO CASE source.type;
        /* CASE 0 IS out */
            go to notsource;
        /* CASE 1 IS prn */
            go to notsource;
        /* CASE 2 IS lst */
            notsource:
                  call error(4);  /* INVALID SOURCE */
        /* CASE 3 IS axo */
            go to notsource;
        /* CASE 4 IS SOURCE FILE */
            DO;
            IF NSOURCE >= SBLEN THEN
                do; if dblbuf or (not dfile) then
                    nsbuf = 0;
                else if (nsource <> 0ffffh) then
                    do; call writedest;
                    nsbuf = ndest;
                    end;
                CALL FILLSOURCE;
                end;
            B = SBUFF(NSOURCE);
            NSOURCE = NSOURCE + 1;
            END;
        /* CASE 5 IS AUX */
           goto axicase;
        /* CASE 6 IS CON */
            DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
            B = MON2(1,0);
            END;
        /* CASE 7 IS axi */
axicase:
/** $if not mpm **/
            B = MON2(3,0) AND 7FH;
/** $else **/
/** $endif **/
        /* CASE 7 IS INP */
            B = INPD;
        END; /* OF CASES */

    IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */
        DO;
        IF obj THEN /* SOURCE IS AN OBJECT FILE */
            CONCHK = ((CONCNT := CONCNT + 1) = 0);
        ELSE /* ASCII */
            CONCHK = (B = LF);
        IF CONCHK THEN
            DO;
            call CONBRK;
            END;
        END;
    IF ZEROP THEN B = B AND 7FH;
    IF UPPER THEN RETURN UTRAN(B);
    IF LOWER THEN RETURN LTRAN(B);
    RETURN B;
    END GETSOURCEC;

GETSOURCE: PROCEDURE BYTE;
    /* GET NEXT SOURCE CHARACTER */
    DECLARE CHAR BYTE;
    MATCH: PROCEDURE(B) BYTE;
        /* MATCH START AND QUIT STRINGS */
        DECLARE (B,C) BYTE;
        IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */
            DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */
            RETURN TRUE;
            END;
        IF C = CHAR THEN MATCHLEN = MATCHLEN + 1;
        ELSE
            MATCHLEN = 0; /* NO MATCH */
        RETURN FALSE;
        END MATCH;

    IF QUITLEN > 0 THEN
        DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF;
        RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */
        END;
    DO FOREVER; /* LOOKING FOR START */
    IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */
        DO; FEEDLEN = FEEDLEN - 1;
        CHAR = COMBUFF(FEEDBASE);
        FEEDBASE = FEEDBASE + 1;
        RETURN CHAR;
        END;
    IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE;
    IF STARTS > 0 THEN /* LOOKING FOR START STRING */
        DO; IF MATCH(STARTS) THEN
            DO; FEEDBASE = STARTS; STARTS = 0;
            FEEDLEN = MATCHLEN + 1;
            matchlen = 0;
            END; /* OTHERWISE NO MATCH, SKIP CHARACTER */
        END;
    ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */
        DO; IF MATCH(QUITS) THEN
            DO; QUITS = 0; QUITLEN = 2;
            /* SUBSEQUENTLY RETURN CR, LF, ENDFILE */
            RETURN CR;
            END;
        RETURN CHAR;
        END;
    ELSE
        RETURN CHAR;
    END; /* OF DO FOREVER */
    END GETSOURCE;

RD$EOF: PROCEDURE BYTE;
    /* RETURN TRUE IF END OF FILE */
    CHAR = GETSOURCE;
    IF obj THEN RETURN (endofsrc and (nsource > nsbuf));
    RETURN (CHAR = ENDFILE);
    END RD$EOF;


HEXRECORD: PROCEDURE;
    DECLARE (h, hbuf, RL, CS, RT) BYTE,
        zerorec byte,  /* true if last record had length of zero */
        LDA ADDRESS;  /* LOAD ADDRESS WHICH FOLLOWS : */

    ckhex: procedure byte;
        IF H - '0' <= 9 THEN
            RETURN H-'0';
        IF H - 'A' > 5 THEN
            CALL xerror(2,.source);  /* invalid hex digit */
        RETURN H - 'A' + 10;
        end ckhex;

    rdhex: procedure byte;
        call putdest(h := getsource);
        return ckhex;
        end rdhex;

    RDCS: PROCEDURE BYTE;
        /* READ BYTE WITH CHECKSUM */
        RETURN CS := CS + (SHL(RDHEX,4) OR RDHEX);
        END RDCS;

    RDADDR: PROCEDURE ADDRESS;
        /* READ DOUBLE BYTE WITH CHECKSUM */
        RETURN SHL(DOUBLE(RDCS),8) OR RDCS;
        END RDADDR;

    /* READ HEX FILE AND CHECK EACH RECORD
    FOR VALID DIGITS, AND PROPER CHECKSUM */
    zerorec = false;
    /* READ NEXT RECORD */
    h = getsource;
        do forever;
        /* SCAN FOR THE ':' */
            DO WHILE h <> ':';
            IF (h = ENDFILE) THEN
                do; if zerorec then return;
                CALL xerror(3,.source);  /* unexpected end of hex file */
                end;
            call putdest(h);
            h = getsource;
            END;

        /* ':' FOUND */
        /* check for end of hex record */
        h = getsource;
        rl = shl(ckhex,4);
        hbuf = h; h = getsource;
        rl = rl or ckhex;
        if (rl = 0) then zerorec = true;
        else zerorec = false;
        if (zerorec and ignor) then
            do while (h <> ':') and (h <> endfile);
            h = getsource;
            end;
        else do; call putdest(':');
            call putdest(hbuf);
            call putdest(h);
            cs = rl;
            LDA = RDADDR; /* LOAD ADDRESS */

            /* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */
            RT = RDCS; /* RECORD TYPE */
                DO WHILE RL <> 0; RL = RL - 1;
                hbuf = RDCS;
                /* INCREMENT LA HERE FOR EXACT ADDRESS */
                END;

            /* CHECK SUM */
            IF rdcs <> 0 THEN
                CALL xerror(4,.source);  /* hex record checksum */
            h = getsource;
            end;
        end; /* do forever */
    END HEXRECORD;

CK$STRINGS: PROCEDURE;
    IF STARTS > 0 THEN
        call error(11);  /* START NOT FOUND */
    IF QUITS  > 0 THEN
        call error(12);  /* QUIT NOT FOUND */
    END CK$STRINGS;

CLOSEDEST: PROCEDURE;
        DO WHILE (LOW(NDEST) AND 7FH) <> 0;
        CALL PUTDEST(ENDFILE);
        END;
    CALL CK$STRINGS;
    CALL WRITEDEST;
    call setduser;  /* destination user */
    CALL CLOSE(.DEST);
    IF DCNT = 255 THEN
/** $if mpm **/
        call xerror(8,.dest);  /* CLOSE FILE */
    IF odcnt <> 255 THEN /* FILE EXISTS */
        do;
/** $else **/
/** $endif **/
        IF ROL(odest.fcb(9),1) THEN /* READ ONLY */
            DO;
            IF NOT WRROF THEN
                DO;
                    do while ((dcnt <> 'Y') and (dcnt <> 'N'));
                    CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)? $'));
                    dcnt = utran(rdchar);
                    end;
                IF dcnt <> 'Y' THEN
                    DO; CALL PRINT(.('**NOT DELETED**$'));
                    CALL CRLF;
                    CALL DELETE(.DEST);
                    RETURN;
                    END;
                CALL CRLF;
                END;
            END;
        /* reset r/o and sys attributes */
        odest.fcb(9) = odest.fcb(9) and 7fh;
        odest.fcb(10) = odest.fcb(10) AND 7FH;
        CALL SETIND(.odest);
        CALL DELETE(.odest);
        END;
    CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */
    CALL RENAME(.DEST);
    /* set destination attributes same as source */
    odest.fcb(1) = (odest.fcb(1) and 07fh) or f1;
    odest.fcb(2) = (odest.fcb(2) and 07fh) or f2;
    odest.fcb(3) = (odest.fcb(3) and 07fh) or f3;
    odest.fcb(4) = (odest.fcb(4) and 07fh) or f4;
    odest.fcb(8) = (odest.fcb(8) and 07fh);
    odest.fcb(9) = (odest.fcb(9) and 07fh) or ro;
    odest.fcb(10) = (odest.fcb(10) and 07fh) or sys;
    odest.fcb(11) = (odest.fcb(11) and 07fh);
    call setind(.odest);
    if archiv then   /* set archive bit */
        do; call setsuser;
        source.fcb(11) = source.fcb(11) or 080h;
        source.fcb(12) = 0;
        call setind(.source);
        end;
    END CLOSEDEST;

SIZE$MEMORY: PROCEDURE;
    /* SET UP SOURCE AND DESTINATION BUFFERS */
    if not dblbuf then
        do;  /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
        sbase = .memory;
        sblen,dblen = ((maxb - .memory) and 0ff80h) - 128;
        end;
    else do;  /* may need to write destination buffer */
        sblen,dblen = (shr((maxb - .memory),1) and 0ff80h) - 128;
        sbase = .memory + dblen + 128;
        if ndest >= dblen then call writedest;
        nsbuf = 0;
        end;
    END SIZE$MEMORY;

setupeob: procedure;
    /* sets nsbuf to end of source buffer */
    declare i byte;
    if (not obj) and (nsbuf <> 0) then
        do; tblen = nsbuf - 128;
            do i = 0 to 128;
            if (sbuff(tblen + i)) = endfile then
                do; nsbuf = tblen + i;
                return;
                end;
            end;
        end;
    end setupeob;

SIMPLECOPY: PROCEDURE;
    DECLARE I BYTE;
    declare
        fast lit '0',  /* fast file to file copy */
        chrt lit '1',  /* character transfer option */
        dubl lit '2';  /* double buffer required for file copy */
    declare optype(26) byte data (
    /* option type for each option character */
        fast,  /* for A option */
        fast,  /* for B option */
        fast,  /* for C option */
        dubl,  /* for D option */
        chrt,  /* for E option */
        dubl,  /* for F option */
        fast,  /* for G option */
        chrt,  /* for H option */
        dubl,  /* for I option */
        fast,  /* for J option */
        fast,  /* for K option */
        chrt,  /* for L option */
        fast,  /* for M option */
        dubl,  /* for N option */
        fast,  /* for O option */
        dubl,  /* for P option */
        dubl,  /* for Q option */
        fast,  /* for R option */
        dubl,  /* for S option */
        dubl,  /* for T option */
        chrt,  /* for U option */
        fast,  /* for V option */
        fast,  /* for W option */
        fast,  /* for X option */
        fast,  /* for Y option */
        chrt); /* for Z option */

    chkrandom: procedure;
        call setsuser;
        call set$random(.source);
/** $if mpm **/
        call multsect(1);
/** $endif **/
        call setdma(.buff);
            do forever;
            if (((dcnt := rd$random(.source)) = 0) or maxsize) then
                do; destr = sourcer;
                destr2 = sourcer2;
                endofsrc = false;
                return;
                end;
            if dcnt = 1 then
                do; if (sourcer := sourcer + 1) = 0 then
                    sourcer2 = sourcer2 + 1;
                end;
            else if dcnt = 4 then
                do;
                if (sourcer := (sourcer + 128) and 0ff80h) = 0 then
                    sourcer2 = sourcer2 + 1;
                end;
            else
                call xerror(15,.source);
            end;
        end chkrandom;

    fastcopy = (sfile and dfile);
    endofsrc = false;
    dblbuf = false;
    sparfil = false;
    insparc = false;
        /* LOOK FOR PARAMETERS */
        DO I = 0 TO 25;
        IF CONT(I) <> 0 THEN
            DO;
            IF optype(i) = chrt THEN
                FASTCOPY = FALSE;
            else
            if optype(i) = dubl then
                do; dblbuf = (sfile and dfile);
                fastcopy = false;
                end;
            END;
        END;

    CALL SIZE$MEMORY;
    if sfile then 
        CALL SETUPSOURCE;
        /* FILES READY FOR COPY */

    if fastcopy then
        do while not endofsrc;
        CALL FILLSOURCE;
        if endofsrc and concat then
            do; call setupeob;
            ndest = nsbuf;
            if nendcmd then return;
            end;
        ndest = nsbuf;
        CALL WRITEDEST;
        nsbuf = ndest;
        if (endofsrc and insparc) then
            call chkrandom;
        end;

    else do;
        /* PERFORM THE ACTUAL COPY FUNCTION */
        IF HEXT OR IGNOR THEN /* HEX FILE */
            call hexrecord;
        ELSE
            DO WHILE NOT RD$EOF;
            CALL PUTDEST(CHAR);
            END;
        if concat and nendcmd then
            do; nsbuf = ndest;
            return;
            end;
        end;

    if dfile then
        CALL CLOSEDEST;
    END SIMPLECOPY;

MULTCOPY: PROCEDURE;
    DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS;

    PRNAME: PROCEDURE;
        /* PRINT CURRENT FILE NAME */
        DECLARE (I,C) BYTE;
        CALL CRLF;
            DO I = 1 TO FNSIZE;
            IF (C := odest.fcb(I)) <> ' ' THEN
                DO; IF I = FEXT THEN CALL PRINTCHAR('.');
                CALL PRINTCHAR(C);
                END;
            END;
        END PRNAME;

    archck: procedure byte;
        /* check if archive bit is set in any extent of source file */
        if not archiv then
            return 1;
        call setsuser;
        source.fcb(12) = what;
        call search(.source);
            do while dcnt <> 255;
            call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),15);
            if not rol(source.fcb(11),1) then
                return 1;
            call searchn;
            end;
        return 0;
        end archck; 

/** $if mpm **/
    /* initialize counters if not error retry */
    if eretry = 0 then NEXTDIR, NCOPIED = 0;
/** $else **/
/** $endif **/

        DO FOREVER;
        /* FIND A MATCHING ENTRY */
        CALL SETSUSER; /* SOURCE USER */
        CALL SETDMA(.BUFF);
        searfcb(12) = 0;
        CALL SEARCH(.SEARFCB);
        NDCNT = 0;
            DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR;
            NDCNT = NDCNT + 1;
            CALL SEARCHN;
            END;
        /* FILE CONTROL BLOCK IN BUFFER */
        IF DCNT = 255 THEN
            DO; IF NCOPIED = 0 THEN
                call xerror(9,.searfcb);  /* file not found */
            if not kilds then
                CALL CRLF;
            RETURN;
            END;
        NEXTDIR = NDCNT + 1;
        /* GET THE FILE CONTROL BLOCK NAME TO DEST */
        CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15);
        CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */
        if archck then
            do; odest.fcb(12) = 0;
            source.fcb(12) = 0;
            IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */
                DO; if not kilds then    /* kill display option */
                    do; IF NCOPIED = 0 THEN
                        CALL PRINT(.('COPYING -$'));
                    dcnt = false;
                        do while ((dcnt <> 'Y') and (dcnt <> 'N'));
                        call prname;
                        if confrm then
                            do; call printx(.(' (Y/N)? $'));
                            dcnt = utran(rdchar);
                            end;
                        else
                            dcnt = 'Y';
                        end;
                    end;
                ncopied = ncopied + 1;
                made = false;  /* destination file not made */
                if (dcnt = 'Y') or (kilds) then
                    CALL SIMPLECOPY;
                END;
            end;
        END;
    END MULTCOPY;

CK$DISK: PROCEDURE;
    /* error if same user and same disk */
    IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN
        CALL FORMERR;
    END CK$DISK;

GNC: PROCEDURE BYTE;
    IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR;
    RETURN UTRAN(COMBUFF(CBP));
    END GNC;

DEBLANK: PROCEDURE;
        DO WHILE (CHAR := GNC) = ' ';
        END;
    END DEBLANK;

CK$EOL: PROCEDURE;
    CALL DEBLANK;
    IF CHAR <> CR THEN CALL FORMERR;
    END CK$EOL;

SCAN: PROCEDURE(FCBA);
    DECLARE FCBA ADDRESS,         /* ADDRESS OF FCB TO FILL */
    fcbs based fcba structure (    /* FCB STRUCTURE */
        fcb(frsize) byte,
/** $if mpm **/
        pwnam(nsize) byte,
        pwmode byte,
/** $endif **/
        user byte,
        type byte );
    DECLARE (I,K) BYTE;  /* TEMP COUNTERS */

    /* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME.
    THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */

    DELIMITER: PROCEDURE(C) BYTE;
        DECLARE (I,C) BYTE;
        DECLARE DEL(*) BYTE DATA
        (' =.:;,<>',CR,LA,LB,RB);
            DO I = 0 TO LAST(DEL);
            IF C = DEL(I) THEN RETURN TRUE;
            END;
        RETURN FALSE;
        END DELIMITER;

    PUTCHAR: PROCEDURE;
        FCBS.FCB(FLEN:=FLEN+1) = CHAR;
        IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */
        END PUTCHAR;

    FILLQ: PROCEDURE(LEN);
        /* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */
        DECLARE LEN BYTE;
        CHAR = WHAT; /* QUESTION MARK */
            DO WHILE FLEN < LEN; 
            CALL PUTCHAR;
            END;
        END FILLQ;

    SCANPAR: PROCEDURE;
        DECLARE (I,J) BYTE;
        /* SCAN OPTIONAL PARAMETERS */
        CHAR = GNC; /* SCAN PAST BRACKET */
            DO WHILE NOT(CHAR = CR OR CHAR = RB);
            IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */
                DO; IF CHAR = ' ' THEN
                    CHAR = GNC;
                ELSE
                    call error(6);  /* BAD PARAMETER */
                END;
            ELSE
                DO; /* SCAN PARAMETER VALUE */
                IF CHAR = 'S' OR CHAR = 'Q' THEN
                    DO; /* START OR QUIT COMMAND */
                    J = CBP + 1; /* START OF STRING */
                        DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR);
                        END;
                     CHAR=GNC;
                    END;
                ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN
                    J = 1;
                ELSE
                    DO WHILE (K := (CHAR := GNC) - '0') <= 9;
                    J = J * 10 + K;
                    END;
                CONT(I) = J;
                IF I = 6 THEN /* SET SOURCE USER */
                    DO;
                    IF J > 15 THEN
                        call error(7);  /* INVALID USER NUMBER */
                    fcbs.user = J;
                    END;
                END;
            END;
        CHAR = GNC;
        END SCANPAR;


    /* scan procedure entry point */

    /* INITIALIZE FILE CONTROL BLOCK TO EMPTY */
    fcbs.type = ERR; CHAR = ' '; FLEN = 0;
/** $if mpm **/
        DO WHILE FLEN < (FRSIZE + NSIZE);
        IF FLEN = FNSIZE THEN CHAR = 0;
        ELSE IF FLEN = FRSIZE THEN CHAR = ' ';
        call putchar;
        END;
    fcbs.pwnam(0) = 0;
    fcbs.pwmode = 1;
/** $else **/
/** $endif **/
    fcbs.fcb(0) = cdisk +1;    /* initialize to current disk */
    fcbs.user = cuser;    /* and current user */
    /* CLEAR PARAMETERS */
        DO I = 0 TO 25; CONT(I) = 0;
        END;
    FEEDLEN,MATCHLEN,QUITLEN = 0;

    /* DEBLANK COMMAND BUFFER */
    CALL DEBLANK;

    /* CHECK PERIPHERALS AND DISK FILES */
    /* SCAN NEXT NAME */
        DO FOREVER;
        FLEN = 0;
            DO WHILE NOT DELIMITER(CHAR);
            IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */
                RETURN;
            IF CHAR = '*' THEN CALL FILLQ(NSIZE);
            ELSE CALL PUTCHAR;
            CHAR = GNC;
            END;

        /* CHECK FOR DISK NAME OR DEVICE NAME */
        IF CHAR = ':' THEN
            DO; IF FLEN = 1 THEN
                /* MAY BE DISK NAME A ... P */
                DO;
                IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 16 THEN
                    RETURN;  /* ERROR, INVALID DISK NAME */
                CALL DEBLANK; /* MAY BE DISK NAME ONLY */
                IF DELIMITER(CHAR) THEN
                    DO; IF CHAR = LB THEN
                        CALL SCANPAR;
                    CBP = CBP - 1;
                    fcbs.type = DISKNAME;
                    RETURN;
                    END;
                END;
            ELSE
            /* MAY BE A THREE CHARACTER DEVICE NAME */
            IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */
                RETURN;
            ELSE
                /* LOOK FOR DEVICE NAME */
                DO; DECLARE (I,J,K) BYTE, M LITERALLY '9',
                IO(*) BYTE DATA
                ('OUTPRNLSTAXO',
                  0,0,0,         /* fake area for file type */
                 'AUX',
                 'CONAXIINPNULEOF',0);

                J = 255;
                    DO K = 0 TO M;
                    I = 0;
                        DO WHILE ((I:=I+1) <= 3) AND
                        IO(J+I) = fcbs.fcb(I);
                        END;
                    IF I = 4 THEN /* COMPLETE MATCH */
                        DO; fcbs.type = k;
                        /* SCAN PARAMETERS */
                        IF GNC = LB THEN CALL SCANPAR;
                        CBP = CBP - 1;
                        RETURN;
                        END;
                    J = J + 3;  /* OTHERWISE TRY NEXT DEVICE */
                    END;
                RETURN;  /* ERROR, NO DEVICE NAME MATCH */
                END;
            IF CHAR = LB THEN /* PARAMETERS FOLLOW */
                CALL SCANPAR;
            END;
        ELSE
            /* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */
            DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */
                RETURN;
            FLEN = NSIZE;
            IF CHAR = '.' THEN /* SCAN FILE TYPE */
                DO WHILE NOT DELIMITER(CHAR := GNC);
                IF FLEN >= FNSIZE THEN
                    RETURN;  /* ERROR, TYPE FIELD TOO LONG */
                IF CHAR = '*' THEN CALL FILLQ(FNSIZE);
                ELSE CALL PUTCHAR;
                END;
/** $if mpm **/
            FLEN = 0;
            IF CHAR = ';' THEN  /* SCAN PASSWORD */
                DO WHILE NOT DELIMITER(CHAR := GNC);
                IF FLEN >= NSIZE THEN
                    /* ERROR, PW TOO LONG */ RETURN;
                ELSE  /* SAVE PASSWORD */
                    FCBS.PWNAM(FLEN) = CHAR;
                    FLEN = FLEN + 1;
                END;
/** $endif **/
            IF CHAR = LB THEN
                CALL SCANPAR;
            /* RESCAN DELIMITER NEXT TIME AROUND */
            CBP = CBP - 1;
            fcbs.type = FILE;
            FCBS.FCB(32) = 0;
            RETURN;
            END;
        END;
    END SCAN;


/* PLM (PIP) ENTRY POINT */
    /* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED
    FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */

    if not retry then
        do; CALL MOVE(.BUFF,.COMLEN,80H);
        MULTCOM = (COMLEN = 0);

        /* GET CURRENT CP/M VERSION */
        IF low(CVERSION) < VERSION THEN
            DO;
/** $if cpm3 **/
            CALL PRINT(.('REQUIRES CP/M 3$'));
/** $else **/
/** $endif **/
            CALL BOOT;
            END;

        call mon1(45,255);  /* set return error mode */

/** $if cpm3 **/
        call mon1(109,1);  /* set CP/M 3 control-C status mode */
/** $endif **/

        if multcom then
            do;
/** $if cpm3 **/
            call printx(.('CP/M 3 PIP VERSION 3.0$'));
/** $else **/
/** $endif **/
            call crlf;
            end;

        cuser,last$user = getuser;  /* GET CURRENT USER */
        cdisk = getdisk;            /* GET CURRENT DISK */
/** $if mpm **/
        mseccnt = 1;
/** $endif **/
        eretry = false; /* need to initialize here for first time */
        end;


    /* START HERE ON RESET EXIT FROM THE PROCEDURE 'ERROR' */
/** $if mpm **/
    if eretry <> 0 then 
        do; call multcopy;
        comlen = multcom;
        end;
/** $endif **/
    /* MAIN PROCESSING LOOP.  PROCESS UNTIL CR ONLY */
        DO FOREVER;
        C1, C2, C3 = 0;     /* LINE COUNT = 000000 */
        CONCNT,COLUMN = 0;  /* PRINTER TABS */
        ndest,nsbuf = 0;
        ambig = false;
        made = false;       /* destination file not made */
        opened = false;     /* source file not opened */
        concat = false;
        eretry = false;
        PUTNUM = TRUE;      /* ACTS LIKE LF OCCURRED ON ASCII FILE */
        dfile,sfile = true;
        nendcmd = true;
        LINENO = 254;       /* INCREMENTED TO 255 > PAGCNT */
        /* READ FROM CONSOLE IF NOT A ONELINER */
        IF MULTCOM THEN
            DO; CALL PRINTCHAR('*'); CALL RDCOM;
            CALL CRLF;
            END;
        CBP = 255;
        IF COMLEN = 0 THEN      /* character = <CR> */
            do; call setcuser;  /* restore current user */
            CALL BOOT;          /* normal exit from pip here */
            end;

        /* LOOK FOR SPECIAL CASES FIRST */

        CALL SCAN(.odest);
        if ambig then
            call xerror(5,.odest);  /* invalid destination */
        call deblank;  /* check for equal sign or left arrow */
        if (char <> '=') and (char <> la) then call formerr;
        call scan(.source);

        IF odest.type = DISKNAME THEN
            DO;
            IF source.type <> file then call formerr;
            CALL CK$EOL;
            CALL CK$DISK;
            odest.type = file;  /* set for character transfer */
            /* MAY BE MULTI COPY */
            IF AMBIG THEN  /* FORM IS A:=B:AFN */
                DO;
                CALL MOVE(.source.fcb(0),.searfcb(0),frsize);
                CALL MULTCOPY;
                END;
            ELSE DO;  /* FORM IS A:=B:UFN */
                CALL MOVE(.source.fcb(1),.odest.fcb(1),frsize - 1);
                CALL SIMPLECOPY;
                END;
            END;

        else IF (odest.type = FILE) and (source.type = DISKNAME) THEN
                DO;
                CALL CK$EOL;
                CALL CK$DISK;
                source.type = file;  /* set for character transfer */
/** $if mpm **/
                call move(.odest.fcb(1),.source.fcb(1),(frsize+nsize));
/** $else **/
/** $endif **/
                CALL SIMPLECOPY;
                END;

        else if (odest.type > cons) then
            call error(3);  /* invalid destination */
        else do;
            IF odest.type <> FILE THEN dfile = false;
/** $if not mpm **/
            /* no conditional attach list device */
/** $else **/
/** $endif **/
            /* SCAN AND COPY UNTIL CR */
                DO WHILE nendcmd;
                sfile = true;
                call deblank;
                IF (CHAR <> ',' AND CHAR <> CR) THEN
                    call error(16);  /* invalid separator */
                concat = concat or (nendcmd := (char = ','));
                IF odest.type = PRNT THEN
                    DO; NUMB = 1;
                    IF TABS = 0 THEN TABS = 8;
                    IF PAGCNT = 0 THEN PAGCNT = 1;
                    END;
                IF (source.type < file) or (source.type > eoft) or ambig THEN
                    call error(4);  /* invalid source */
                IF source.type <> FILE THEN  /* NOT A SOURCE FILE */
                    sfile = false;
                IF source.type = NULT THEN
                    /* SEND 40 NULLS TO OUTPUT DEVICE */
                    DO sfile = 0 TO 39; CALL PUTDEST(0);
                    END;
                ELSE IF source.type = EOFT THEN
                    CALL PUTDEST(ENDFILE);
                else call simplecopy;
 
                CALL CK$STRINGS;
                /* READ ENDFILE, GO TO NEXT SOURCE */

                if nendcmd then call scan(.source);
                END;
            end;

        /* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */
        COMLEN = MULTCOM;

        END; /* DO FOREVER */
    end plm;
    END;

EOF