home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / DRIPAK.ZIP / CPM_3-0 / SOURCES / PIP.PLM < prev    next >
Text File  |  1982-12-31  |  60KB  |  1,926 lines
  1. $title('PERIPHERAL INTERCHANGE PROGRAM')
  2. PIPMOD:
  3.     DO;
  4. /* 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
  5.  
  6.          COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982
  7.          DIGITAL RESEARCH
  8.          BOX 579
  9.          PACIFIC GROVE, CA
  10.          93950
  11.  
  12.          Revised:
  13.             17 Jan 80  by  Thomas Rolander (MP/M 1.1)
  14.             05 Oct 81  by  Ray Pedrizetti  (MP/M-86 2.0)
  15.             18 Dec 81  by  Ray Pedrizetti  (CP/M-86 1.1)
  16.             29 Jun 82  by  Ray Pedrizetti  (CCP/M-86 3.0) */
  17.  
  18. /*    Command lines used for CMD file generation         */
  19.  
  20. /* (on VAX)
  21.     asm86 scd1.a86
  22.         asm86 inpout.a86
  23.     plm86 pip.plm debug xref optimize(3)
  24.     link86 scd1.obj,inpout.obj,pip.obj, to pip.lnk
  25.     loc86 pip.lnk od(sm(code,dats,data,const,stack)) -
  26.               ad(sm(code(0), dats(10000h)))  ss(stack(+32)) to pip.
  27.     h86 pip
  28.  
  29.    (on a micro)
  30.     vax pip.h86 $fans
  31.     gencmd pip data[b1000 m280 xfff]
  32.  
  33.         * note the beginning of the data segment will change when
  34.     * the program is changed. see the 'MP2' file generated
  35.     * by LOC86.  the constants are last to force hex generation
  36.    */
  37.  
  38.    /* Compiler Directives */
  39. /** $set (mpm) **/
  40. /** $reset (cpm3) **/
  41. /** $cond **/
  42.  
  43. declare    /* resets stack for error handling */
  44.     reset label external;
  45.  
  46. DECLARE
  47.     MAXB  ADDRESS EXTERNAL,     /* ADDR FIELD OF JMP BDOS */
  48.     FCB (33) BYTE EXTERNAL,     /* DEFAULT FILE CONTROL BLOCK */
  49.     BUFF(128)BYTE EXTERNAL;     /* DEFAULT BUFFER */
  50.  
  51. declare
  52.     retry byte initial(0);  /* true if error has occured */
  53.  
  54. OUTD: PROCEDURE(B) external;
  55.     DECLARE B BYTE;
  56.     /* SEND B TO OUT: DEVICE */
  57.     END OUTD;
  58.  
  59. INPD: PROCEDURE BYTE external;
  60.     END INPD;
  61.  
  62. MON1: PROCEDURE(F,A) EXTERNAL;
  63.     DECLARE F BYTE,
  64.     A ADDRESS;
  65.     END MON1;
  66.  
  67. MON2: PROCEDURE(F,A) BYTE EXTERNAL;
  68.     DECLARE F BYTE,
  69.     A ADDRESS;
  70.     END MON2;
  71.  
  72. MON3: PROCEDURE(F,A) ADDRESS EXTERNAL;
  73.     DECLARE F BYTE,
  74.     A ADDRESS;
  75.     END MON3;
  76.  
  77.  
  78. plm: procedure public;
  79.  
  80. DECLARE
  81. /** $if mpm **/
  82.     VERSION  LITERALLY '0031H', /* REQUIRED FOR BDOS 3.1 OPERATION */
  83. /** $else **/
  84. /** $endif **/
  85.  
  86.     ENDFILE LITERALLY '1AH';    /* END OF FILE MARK */
  87.  
  88. DECLARE COPYRIGHT(*) BYTE DATA (
  89. /** $if cpm3 **/
  90.         ' (12/06/82) CP/M 3 PIP VERS 3.0 ');
  91. /** $else **/
  92. /** $endif **/
  93.  
  94.  
  95.     /* LITERAL DECLARATIONS */
  96. DECLARE
  97.     LIT  LITERALLY 'LITERALLY',
  98.     LPP  LIT '60',     /* LINES PER PAGE */
  99.     TAB  LIT '09H',    /* HORIZONTAL TAB */
  100.     FF   LIT '0CH',    /* FORM FEED */
  101.     LA   LIT '05FH',   /* LEFT ARROW */
  102.     LB   LIT '05BH',   /* LEFT BRACKET */
  103.     RB   LIT '05DH',   /* RIGHT BRACKET */
  104.  
  105.     FSIZE  LIT '33',
  106.     FRSIZE LIT '36',   /* SIZE OF RANDOM FCB */
  107.     NSIZE  LIT '8',
  108.     FNSIZE LIT '11',
  109.     FEXT   LIT '9',
  110.     FEXTL  LIT '3',
  111.  
  112.         /* scanner return type code */
  113.     outt     LIT '0',   /* output device */
  114.     PRNT     LIT '1',   /* PRINTER */
  115.     LSTT     LIT '2',   /* list device */
  116.     axot     lit '3',   /* auxilary output device */
  117.     FILE     LIT '4',   /* file type */
  118.     auxt     lit '5',   /* auxilary input/output device */
  119.     CONS     LIT '6',   /* CONSOLE */
  120.     axit     LIT '7',   /* auxilary input device */
  121.     inpt     lit '8',   /* input device */
  122.     NULT     LIT '9',   /* nul characters */
  123.     EOFT     LIT '10',   /* EOF character */
  124.     ERR      LIT '11',  /* error type */
  125.     SPECL    LIT '12',  /* special character */
  126.     DISKNAME LIT '13';  /* diskname letter */
  127.  
  128. DECLARE
  129.     SEARFCB LIT 'FCB';   /* SEARCH FCB IN MULTI COPY */
  130.  
  131. DECLARE
  132.     TRUE    LIT '1',
  133.     FALSE   LIT '0',
  134.     FOREVER LIT 'WHILE TRUE',
  135.     cntrlc  lit '3',
  136.     CR      LIT '13',
  137.     LF      LIT '10',
  138.     WHAT    LIT '63';
  139.  
  140. /** $if mpm **/
  141. declare
  142.     maxmcnt lit '128',    /* maximum multi sector count */
  143.     maxmbuf lit '16384';  /* maximum multi sector buffer size */
  144. /** $endif **/
  145.  
  146. DECLARE
  147.     COLUMN   BYTE,      /* COLUMN COUNT FOR PRINTER TABS */
  148.     LINENO   BYTE,      /* LINE WITHIN PAGE */
  149.     FEEDBASE BYTE,      /* USED TO FEED SEARCH CHARACTERS */
  150.     FEEDLEN  BYTE,      /* LENGTH OF FEED STRING */
  151.     MATCHLEN BYTE,      /* USED IN MATCHING STRINGS */
  152.     QUITLEN  BYTE,      /* USED TO TERMINATE QUIT COMMAND */
  153.     CDISK    BYTE,      /* CURRENT DISK */
  154.     SBLEN    ADDRESS,   /* SOURCE BUFFER LENGTH */
  155.     DBLEN    ADDRESS,   /* DEST BUFFER LENGTH */
  156.     tblen    address,   /* temp buffer length */
  157.     SBASE    ADDRESS,   /* SOURCE BUFFER BASE */
  158.  
  159.     /* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION
  160.     1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */
  161.     DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */
  162.     SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */
  163.  
  164.         /* source fcb, password and password mode */
  165.     source structure (
  166.         fcb(frsize)  byte,
  167. /** $if mpm **/
  168.         pwnam(nsize) byte,
  169.         pwmode       byte,
  170. /** $endif **/
  171.         user         byte,
  172.         type         byte ),
  173.  
  174.         /* temporary destination fcb, password and password mode */
  175.     dest structure (
  176.         fcb(frsize)  byte,
  177. /** $if mpm **/
  178.         pwnam(nsize) byte,
  179.         pwmode       byte,
  180. /** $endif **/
  181.         user         byte,
  182.         type         byte ),
  183.  
  184.         /* original destination fcb, password and password mode */
  185.     odest structure (
  186.         fcb(frsize)  byte,
  187. /** $if mpm **/
  188.         pwnam(nsize) byte,
  189.         pwmode       byte,
  190. /** $endif **/
  191.         user         byte,
  192.         type         byte ),
  193.  
  194.     filsize(3) byte,     /* file size random record number */
  195.  
  196.     DESTR    ADDRESS AT(.DEST.FCB(33)),    /* RANDOM RECORD POSITION */
  197.     SOURCER  ADDRESS AT(.SOURCE.FCB(33)),  /* RANDOM RECORD POSITION */
  198.     DESTR2   BYTE    AT(.DEST.FCB(35)),    /* RANDOM RECORD POSITION R2 */
  199.     SOURCER2 BYTE    AT(.SOURCE.FCB(35)),  /* RANDOM RECORD POSITION R2 */
  200.  
  201.     extsave  byte,      /* temp extent byte for bdos bug */
  202.  
  203.     nsbuf   address,    /* next source buffer */ 
  204. /** $if mpm **/
  205.     bufsize address,    /* multsect buffer size */
  206.     mseccnt  byte,      /* last multi sector count value */
  207. /** $endif **/
  208.     NSOURCE ADDRESS,    /* NEXT SOURCE CHARACTER */
  209.     NDEST   ADDRESS;    /* NEXT DESTINATION CHARACTER */
  210.  
  211. DECLARE
  212.     fastcopy byte,      /* true if copy directly to dbuf */
  213.     dblbuf   byte,      /* true if both source and dest buffer used */
  214.     concat   byte,      /* true if concatination command */
  215.     ambig    byte,      /* true if file is ambig type */
  216.     dfile    byte,      /* true if dest is file type */
  217.     sfile    byte,      /* true if source is file type */
  218.     made     byte,      /* true if destination file already made */
  219.     opened   byte,      /* true if source file open */
  220.     endofsrc byte,      /* true if end of source file */
  221.     nendcmd  byte,      /* true if not end of command tail */
  222.     insparc  byte,      /* true if in middle of sparce file */
  223.     sparfil  byte,      /* true if sparce file being copied */
  224.     MULTCOM  BYTE,      /* true if processing multiple commands */
  225.     PUTNUM   BYTE,      /* SET WHEN READY FOR NEXT LINE NUM */
  226.     CONCNT   BYTE,      /* COUNTER FOR CONSOLE READY CHECK */
  227.     CHAR     BYTE,      /* LAST CHARACTER SCANNED */
  228.     FLEN     BYTE;      /* FILE NAME LENGTH */
  229.  
  230. declare
  231.     f1     byte,        /* f1 user attribute flag */
  232.     f2     byte,        /* f2 user attribute flag */
  233.     f3     byte,        /* f3 user attribute flag */
  234.     f4     byte,        /* f4 user attribute flag */
  235.     ro     byte,        /* read only attribute flag */
  236.     sys    byte,        /* system attribute flag */
  237. /** $if mpm **/
  238.     exten  byte,        /* extention error code */
  239.     odcnt  byte,        /* saves dcnt for open dest file */
  240.     eretry byte,        /* error return flag */
  241. /** $endif **/
  242.     dcnt   byte;        /* error code or directory code */
  243.  
  244.  
  245. DECLARE CBUFF(130) BYTE,   /* COMMAND BUFFER */
  246.     MAXLEN       BYTE AT (.CBUFF(0)),  /* MAX BUFFER LENGTH */
  247.     COMLEN       BYTE AT (.CBUFF(1)),  /* CURRENT LENGTH */
  248.     COMBUFF(128) BYTE AT (.CBUFF(2)),  /* COMMAND BUFFER CONTENTS */
  249.     CBP          BYTE;                 /* COMMAND BUFFER POINTER */
  250.  
  251. DECLARE
  252.     CUSER BYTE, /* CURRENT USER NUMBER */
  253.     last$user byte;
  254.  
  255. DECLARE /* CONTROL TOGGLE VECTOR */
  256.     CONT(26) BYTE,   /* ONE FOR EACH ALPHABETIC */
  257.     /* 00 01 02 03 04 05 06 07 08 09 10 11 12 13
  258.         A  B  C  D  E  F  G  H  I  J  K  L  M  N
  259.        14 15 16 17 18 19 20 21 22 23 24 25
  260.         O  P  Q  R  S  T  U  V  W  X  Y  Z   */
  261.     archiv byte  at(.cont(0)),     /* file archive */
  262.     confrm byte  at(.cont(2)),     /* confirm copy */
  263.     DELET  BYTE  AT(.CONT(3)),     /* DELETE CHARACTERS */
  264.     ECHO   BYTE  AT(.CONT(4)),     /* ECHO CONSOLE CHARACTERS */
  265.     FORMF  BYTE  AT(.CONT(5)),     /* FORM FILTER */
  266.     GETU   BYTE  AT(.CONT(6)),     /* GET FILE, USER # */
  267.     HEXT   BYTE  AT(.CONT(7)),     /* HEX FILE TRANSFER */
  268.     IGNOR  BYTE  AT(.CONT(8)),     /* IGNORE :00 RECORD ON FILE */
  269.     kilds  byte  at(.cont(10)),    /* kill filename display */
  270.     LOWER  BYTE  AT(.CONT(11)),    /* TRANSLATE TO LOWER CASE */
  271.     NUMB   BYTE  AT(.CONT(13)),    /* NUMBER OUTPUT LINES */
  272.     OBJ    BYTE  AT(.CONT(14)),    /* OBJECT FILE TRANSFER */
  273.     PAGCNT BYTE  AT(.CONT(15)),    /* PAGE LENGTH */
  274.     QUITS  BYTE  AT(.CONT(16)),    /* QUIT COPY */
  275.     RSYS   BYTE  AT(.CONT(17)),    /* READ SYSTEM FILES */
  276.     STARTS BYTE  AT(.CONT(18)),    /* START COPY */
  277.     TABS   BYTE  AT(.CONT(19)),    /* TAB SET */
  278.     UPPER  BYTE  AT(.CONT(20)),    /* UPPER CASE TRANSLATE */
  279.     VERIF  BYTE  AT(.CONT(21)),    /* VERIFY EQUAL FILES ONLY */
  280.     WRROF  BYTE  AT(.CONT(22)),    /* WRITE TO R/O FILE */
  281.     ZEROP  BYTE  AT(.CONT(25));    /* ZERO PARITY ON INPUT */
  282.  
  283. DECLARE ZEROSUP BYTE,  /* ZERO SUPPRESSION */
  284.     (C3,C2,C1) BYTE;     /* LINE COUNT ON PRINTER  */
  285.  
  286.  
  287. /** $if mpm **/
  288. retcodes: procedure(a);
  289.     declare a address;
  290.     dcnt = low(a);
  291.     exten = high(a);
  292.     end retcodes;
  293. /** $endif **/
  294.  
  295. BOOT: PROCEDURE;
  296.     /* SYSTEM REBOOT */
  297.     CALL MON1(0,0);
  298.     END BOOT;
  299.  
  300.  
  301. RDCHAR: PROCEDURE BYTE;
  302.     /* READ CONSOLE CHARACTER */
  303.     RETURN MON2(1,0);
  304.     END RDCHAR;
  305.  
  306. PRINTCHAR: PROCEDURE(CHAR);
  307.     DECLARE CHAR BYTE;
  308.     CALL MON1(2,CHAR AND 7FH);
  309.     END PRINTCHAR;
  310.  
  311. CRLF: PROCEDURE;
  312.     CALL PRINTCHAR(CR);
  313.     CALL PRINTCHAR(LF);
  314.     END CRLF;
  315.  
  316. printx: procedure(a);
  317.     declare a address;
  318.     call mon1(9,a);
  319.     end printx;
  320.  
  321. PRINT: PROCEDURE(A);
  322.     DECLARE A ADDRESS;
  323.     /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
  324.     NEXT DOLLAR SIGN IS ENCOUNTERED */
  325.     CALL CRLF;
  326.     CALL printx(A);
  327.     END PRINT;
  328.  
  329. RDCOM: PROCEDURE;
  330.     /* READ INTO COMMAND BUFFER */
  331.     MAXLEN = 128;
  332.     CALL MON1(10,.MAXLEN);
  333.     END RDCOM;
  334.  
  335. CVERSION: PROCEDURE ADDRESS;
  336.     RETURN MON3(12,0); /* VERSION NUMBER */
  337.     END CVERSION;
  338.  
  339. SETDMA: PROCEDURE(A);
  340.     DECLARE A ADDRESS;
  341.     CALL MON1(26,A);
  342.     END SETDMA;
  343.  
  344. /** $if mpm **/
  345. setpw: procedure(fcba);
  346.     declare fcba address;
  347.     declare fcbs based fcba structure (
  348.         fcb(frsize) byte,
  349.         pwnam(nsize) byte );
  350.     call setdma(.fcbs.pwnam(0));
  351.     end setpw;
  352. /** $endif **/
  353.  
  354. OPEN: PROCEDURE(fcba);
  355.     DECLARE fcba ADDRESS;
  356.     declare fcb based fcba (frsize) byte;
  357. /** $if mpm **/
  358.     CALL SETPW(fcba);
  359.     call retcodes(mon3(15,fcba));
  360. /** $else **/
  361. /** $endif **/
  362.     if dcnt <> 255 and rol(fcb(8),1) then
  363.         do; call mon1(16,fcba);
  364.         dcnt = 255;
  365. /** $if mpm **/
  366.         exten = 0;
  367. /** $endif **/
  368.         end;
  369.     END OPEN;
  370.  
  371. CLOSE: PROCEDURE(FCB);
  372.     DECLARE FCB ADDRESS;
  373. /** $if mpm **/
  374.     call retcodes(MON3(16,FCB));
  375. /** $else **/
  376. /** $endif **/
  377.     END CLOSE;
  378.  
  379. SEARCH: PROCEDURE(FCB);
  380.     DECLARE FCB ADDRESS;
  381. /** $if mpm **/
  382.     call retcodes(MON3(17,FCB));
  383. /** $else **/
  384. /** $endif **/
  385.     END SEARCH;
  386.  
  387. SEARCHN: PROCEDURE;
  388. /** $if mpm **/
  389.     call retcodes(MON3(18,0));
  390. /** $else **/
  391. /** $endif **/
  392.     END SEARCHN;
  393.  
  394. DELETE: PROCEDURE(FCB);
  395.     DECLARE FCB ADDRESS;
  396. /** $if mpm **/
  397.     CALL SETPW(FCB);
  398.     call retcodes(MON3(19,FCB));
  399. /** $else **/
  400. /** $endif **/
  401.     END DELETE;
  402.  
  403. DISKRD: PROCEDURE(FCB);
  404.     DECLARE FCB ADDRESS;
  405. /** $if mpm **/
  406.     call retcodes(MON3(20,FCB));
  407. /** $else **/
  408. /** $endif **/
  409.     END DISKRD;
  410.  
  411. DISKWRITE: PROCEDURE(FCB);
  412.     DECLARE FCB ADDRESS;
  413. /** $if mpm **/
  414.     call retcodes(MON3(21,FCB));
  415. /** $else **/
  416. /** $endif **/
  417.     END DISKWRITE;
  418.  
  419. MAKE: procedure(fcba);
  420.     declare fcba address;
  421. /** $if mpm **/
  422.     declare fcbs based fcba structure (
  423.         fcb(frsize) byte,
  424.         pwnam(nsize) byte );
  425.     if fcbs.pwnam(0) = 0 then   /* zero if no password */
  426.         fcbs.fcb(6) = fcbs.fcb(6) and 7fh;  /* reset password attribute */
  427.     else do;
  428.         fcbs.fcb(6) = fcbs.fcb(6) or 80h;  /* set password attribute */
  429.         call setdma(.fcbs.pwnam(0));  /* set password dma */
  430.         end;
  431.     call retcodes(mon3(22,fcba));
  432. /** $else **/
  433. /** $endif **/
  434.     END MAKE;
  435.  
  436. RENAME: PROCEDURE(FCB);
  437.     DECLARE FCB ADDRESS;
  438. /** $if mpm **/
  439.     CALL SETPW(FCB);
  440.     call retcodes(MON3(23,FCB)) ;
  441. /** $else **/
  442. /** $endif **/
  443.     END RENAME;
  444.  
  445. getdisk: procedure byte;
  446.     return mon2(25,0);
  447.     end getdisk;
  448.  
  449. SETIND: PROCEDURE(FCB);
  450.     DECLARE FCB ADDRESS;
  451. /** $if mpm **/
  452.     call retcodes(MON3(30,FCB));
  453. /** $else **/
  454. /** $endif **/
  455.     END SETIND;
  456.  
  457. GETUSER: PROCEDURE BYTE;
  458.     RETURN MON2(32,0FFH);
  459.     END GETUSER;
  460.  
  461. SETUSER: PROCEDURE(USER);
  462.     DECLARE USER BYTE;
  463.     if last$user <> user then
  464.         CALL MON1(32,(last$user:=USER));
  465.     END SETUSER;
  466.  
  467. SETCUSER: PROCEDURE;
  468.     CALL SETUSER(CUSER);
  469.     END SETCUSER;
  470.  
  471. setduser: procedure;
  472.     call setuser(odest.user);
  473.     end setduser;
  474.  
  475. SETSUSER: PROCEDURE;
  476.     CALL SETUSER(source.user);
  477.     END SETSUSER;
  478.  
  479. RD$RANDOM: PROCEDURE(FCB) BYTE;
  480.     DECLARE FCB ADDRESS;
  481. /** $if mpm **/
  482.     call retcodes(mon3(33,fcb));
  483. /** $else **/
  484. /** $endif **/
  485.     return dcnt;
  486.     END RD$RANDOM;
  487.  
  488. write$random: procedure(fcb) byte;
  489.     declare fcb address;
  490. /** $if mpm **/
  491.     call retcodes(mon3(34,fcb));
  492. /** $else **/
  493. /** $endif **/
  494.     return dcnt;
  495.     end write$random;
  496.  
  497. retfsize: procedure(fcb) byte;
  498.     declare fcb address;
  499.     return mon2(35,fcb);
  500.     end retfsize;
  501.  
  502. SET$RANDOM: PROCEDURE(FCB);
  503.     DECLARE FCB ADDRESS;
  504.     /* SET RANDOM RECORD POSITION */
  505.     CALL MON1(36,FCB);
  506.     END SET$RANDOM;
  507.  
  508. /** $if mpm **/
  509. multsect: procedure(cnt);
  510.     declare cnt byte;
  511.     if mseccnt <> cnt then
  512.         call mon1(44,(mseccnt := cnt));
  513.     end multsect;
  514.  
  515. flushbuf: procedure;
  516.     call mon1(48, 0ffh);    /* 0FFH = flush and discard buffers */
  517.     end flushbuf;
  518.  
  519. conatlst: procedure byte;
  520.     return mon2(161,0);
  521.     end conatlst;
  522. /** $endif **/
  523.  
  524.  
  525. MOVE: PROCEDURE(S,D,N);
  526.     DECLARE (S,D) ADDRESS, N BYTE;
  527.     DECLARE A BASED S BYTE, B BASED D BYTE;
  528.         DO WHILE (N:=N-1) <> 255;
  529.         B = A; S = S+1; D = D+1;
  530.         END;
  531.     END MOVE;
  532.  
  533.     /* errtype error messages */
  534.     declare er00(*) byte data ('DISK READ$');
  535.     declare er01(*) byte data ('DISK WRITE$');
  536.     declare er02(*) byte data ('VERIFY$');
  537.     declare er03(*) byte data ('INVALID DESTINATION$');
  538.     declare er04(*) byte data ('INVALID SOURCE$');
  539.     declare er05(*) byte data ('USER ABORTED$');
  540.     declare er06(*) byte data ('BAD PARAMETER$');
  541.     declare er07(*) byte data ('INVALID USER NUMBER$');
  542.     declare er08(*) byte data ('INVALID FORMAT$');
  543.     declare er09(*) byte data ('HEX RECORD CHECKSUM$');
  544.     declare er10(*) byte data ('FILE NOT FOUND$');
  545.     declare er11(*) byte data ('START NOT FOUND$');
  546.     declare er12(*) byte data ('QUIT NOT FOUND$');
  547.     declare er13(*) byte data ('INVALID HEX DIGIT$');
  548.     declare er14(*) byte data ('CLOSE FILE$');
  549.     declare er15(*) byte data ('UNEXPECTED END OF HEX FILE$');
  550.     declare er16(*) byte data ('INVALID SEPARATOR$');
  551.     declare er17(*) byte data ('NO DIRECTORY SPACE$');
  552.     declare er18(*) byte data ('INVALID FORMAT WITH SPARCE FILE$');
  553. /** $if mpm **/
  554.     declare er19(*) byte data ('MAKE FILE$');
  555.     declare er20(*) byte data ('OPEN FILE$');
  556.     declare er21(*) byte data ('PRINTER BUSY$');
  557.     declare er22(*) byte data ('CAN''T DELETE TEMP FILE$');
  558. /** $endif **/
  559.  
  560.     declare errmsg(*) address data(
  561.         .er00,.er01,.er02,.er03,.er04,
  562.         .er05,.er06,.er07,.er08,.er09,
  563.         .er10,.er11,.er12,.er13,.er14,
  564.         .er15,.er16,.er17,.er18
  565. /** $if mpm **/
  566.         ,.er19,.er20,.er21,.er22
  567. /** $endif **/
  568.         );
  569.  
  570.     declare sper00(*) byte data ('NO DIRECTORY SPACE$');
  571.     declare sper01(*) byte data ('NO DATA BLOCK$');
  572.     declare sper02(*) byte data ('CAN''T CLOSE CURRENT EXTENT$');
  573.     declare sper03(*) byte data ('SEEK TO UNWRITTEN EXTENT$');
  574.     declare sper05(*) byte data ('RANDOM RECORD OUT OF RANGE$');
  575.     declare sper06(*) byte data ('RECORDS DON''T MATCH$');
  576.     declare sper07(*) byte data ('RECORD LOCKED$');
  577.     declare sper08(*) byte data ('INVALID FILENAME$');
  578.     declare sper09(*) byte data ('FCB CHECKSUM$');
  579.  
  580.     declare numspmsgs lit '10';  /* number of extended messages */
  581.     declare special$msg(numspmsgs) address data(
  582.         .sper00,.sper01,.sper02,.sper03,.sper00,
  583.         .sper05,.sper06,.sper07,.sper08,.sper09);
  584.  
  585. /** $if mpm **/
  586.     /* extended error messages */
  587.     declare ex00(*) byte data ('$');  /* NO MESSAGE */
  588.     declare ex01(*) byte data ('NONRECOVERABLE$');
  589.     declare ex02(*) byte data ('R/O DISK$');
  590.     declare ex03(*) byte data ('R/O FILE$');
  591.     declare ex04(*) byte data ('INVALID DISK SELECT$');
  592.     declare ex05(*) byte data ('INCOMPATIBLE MODE$');
  593.     declare ex07(*) byte data ('INVALID PASSWORD$');
  594.     declare ex08(*) byte data ('ALREADY EXISTS$');
  595.     declare ex10(*) byte data ('LIMIT EXCEEDED$');
  596.  
  597.     declare nummsgs lit '11';  /* number of extended messages */
  598.     declare extmsg(nummsgs) address data(
  599.         .ex00,.ex01,.ex02,.ex03,.ex04,
  600.         .ex05,.sper09,.ex07,.ex08,.sper08,
  601.         .ex10);
  602. /** $endif **/
  603.  
  604. error$cleanup: procedure;
  605. /** $if mpm **/
  606.     call multsect(1);
  607. /** $endif **/
  608.     eretry = 0;   /* initialize to no error retry */
  609.     if opened then   /* if source file opened */
  610.         do; call setsuser;
  611.         call close(.source);
  612.         opened = false;
  613.         end;
  614.     if made then
  615.         do; call setduser;
  616.         call close(.dest);
  617.         call delete(.dest);  /* delete destination scratch file */
  618.         end;
  619.     /* Zero the command length in case this is a single command */
  620.        comlen = 0;
  621.        retry = true;
  622.        call print(.('ERROR: $'));
  623.     end error$cleanup;
  624.  
  625. error: procedure (errtype);
  626.     declare errtype byte;
  627.  
  628.     call error$cleanup;
  629.     call printx(errmsg(errtype));
  630.     call crlf;
  631.     go to reset;
  632.     end error;
  633.  
  634. xerror: procedure (funcno,fileadr);
  635.     declare temp    byte,
  636.             i       byte,
  637.             sdcnt   byte,
  638.             sexten  byte,
  639.             funcno  byte,
  640.             fileadr address,
  641.             fcb based fileadr (fsize) byte;
  642.  
  643.     declare message$index$tbl(17) byte data
  644.             (2,18,13,15,9,3,10,20,14,10,22,17,19,0,1,0,1);
  645.  
  646.     sdcnt = dcnt;
  647.     sexten = exten;
  648.     call error$cleanup;
  649.  
  650.     if (funcno < 6) or (sdcnt <> 0ffh) then
  651.        sexten = 0;
  652.     else sexten = sexten and 0fh;
  653.  
  654.     call printx(errmsg(message$index$tbl(funcno)));
  655.  
  656.     if (funcno > 12) and (funcno < 17) and
  657.        (sdcnt <> 0ffh) and (sdcnt <= numspmsgs) then
  658.        do; call printchar(' ');
  659.        call printx(special$msg(sdcnt-1));
  660.        sexten = 0;
  661.        end;
  662.  
  663. /** $if mpm **/
  664.     if sexten < nummsgs then
  665.        do; call printchar(' ');
  666.        call printx(extmsg(sexten));
  667.        end;
  668. /** $endif **/
  669.  
  670.     call printx(.(' - $'));
  671.     if fileadr <> 0 then
  672.         do; call printchar('A' + fcb(0) - 1);
  673.         call printchar(':');
  674.             do i = 1 to fnsize;
  675.             if (temp := fcb(i) and 07fh) <> ' ' then
  676.                 do; if i = fext then call printchar('.');
  677.                 call printchar(temp);
  678.                 end;
  679.             end;
  680.         end;
  681.     call crlf;
  682.  
  683.     if (sdcnt = 3) or (sdcnt = 4) or (sdcnt = 6) or (sdcnt = 8) then
  684.        eretry = ambig;
  685.     else
  686.        if (sexten = 3) or ((sexten > 4) and (sexten < 9)) or (sexten > 9) then
  687.             eretry = ambig;
  688.  
  689.     go to reset;
  690.     end xerror;
  691.  
  692. FORMERR: PROCEDURE;
  693.     call error(8);  /* invalid format */
  694.     END FORMERR;
  695.  
  696. CONBRK: PROCEDURE;
  697.     /* CHECK CONSOLE CHARACTER READY */
  698.     if mon2(11,0) <> 0 then
  699.         if mon2(6,0fdh) = cntrlc then
  700.            call error(5);
  701.     END CONBRK;
  702.  
  703. MAXSIZE: procedure byte;
  704.     /* three byte compare of random record field
  705.        returns true if source.fcb.ranrec >= filesize */
  706.  
  707.     if (source.fcb(35) < filsize(2)) then
  708.       return false;
  709.     if (source.fcb(35) = filsize(2)) then
  710.       do;
  711.       if (source.fcb(34) < filsize(1)) then
  712.         return false;
  713.       if (source.fcb(34) = filsize(1)) then
  714.         do;
  715.         if (source.fcb(33) < filsize(0)) then
  716.           return false;
  717.         end;
  718.       end;
  719.     return true;
  720.     end maxsize;
  721.  
  722. SETUPDEST: PROCEDURE;
  723.     call setduser;  /* destination user */
  724. /** $if mpm **/
  725.     call move(.odest,.dest,(frsize + nsize + 1));  /* save original dest */
  726. /** $else **/
  727. /** $endif **/
  728.     /* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
  729.     CALL MOVE(.('$$$'),.DEST.FCB(FEXT),FEXTL);
  730. /** $if mpm **/
  731.     odest.fcb(6) = odest.fcb(6) or 80h;
  732.     call open(.odest);  /* try to open destination file */
  733.     odcnt = dcnt;       /* and save error code */
  734.     if odcnt <> 255 then
  735.         call close(.odest);
  736.     else if (exten and 0fh) <> 0 then /* file exists */
  737.         call xerror(7,.odest);        /* but can't open - error */
  738.  
  739.     CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */
  740.     if dcnt = 255 and exten <> 0 then
  741.         /* cant delete temp file */
  742.         call xerror(10,.dest);
  743.     CALL MAKE(.DEST); /* CREATE A NEW ONE */
  744.     IF DCNT = 255 THEN 
  745.         if (exten and 0fh) = 0 then 
  746.             call xerror(11,.dest);  /* no directory space */
  747.         else call xerror(12,.dest);  /* make file error */
  748. /** $else **/
  749. /** $endif **/
  750.     DEST.FCB(32) = 0;
  751.     made = true;
  752.     END SETUPDEST;
  753.  
  754. SETUPSOURCE: PROCEDURE;
  755.     declare (i,j) byte;
  756.     CALL SETSUSER; /* SOURCE USER */
  757. /** $if mpm **/
  758.     source.fcb(6) = source.fcb(6) or 80h;
  759. /** $endif **/
  760.     CALL OPEN(.SOURCE);  /* open source */
  761.     if dcnt <> 255 then
  762.         opened = true;
  763.     IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN
  764.         /* skip system file */
  765.         DCNT = 255;
  766.     IF DCNT = 255 THEN
  767. /** $if mpm **/
  768.         if (exten and 0fh) = 0 then
  769.             call xerror(6,.source);  /* file not found */
  770.         else
  771.             call xerror(7,.source);  /* open file error */
  772. /** $else **/
  773. /** $endif **/
  774.     f1 = source.fcb(1) and 80h;  /* save file atributes */
  775.     f2 = source.fcb(2) and 80h;
  776.     f3 = source.fcb(3) and 80h;
  777.     f4 = source.fcb(4) and 80h;
  778.     ro = source.fcb(9) and 80h;
  779.     sys = source.fcb(10) and 80h;
  780.     dcnt = retfsize(.source);
  781.     call move(.source.fcb(33),.filsize,3);
  782.     SOURCE.FCB(32) = 0;
  783.     source.fcb(33),source.fcb(34),source.fcb(35) = 0;
  784.     /* cause immediate read with no preceding write */
  785.     NSOURCE = 0ffffh;
  786.     END SETUPSOURCE;
  787.  
  788. WRITEDEST: PROCEDURE;
  789.     /* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION
  790.     NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */
  791.     DECLARE (J,DATAOK) BYTE,
  792.         (tdest,n)      address;
  793.     if not made then call setupdest;
  794.     if (n := ndest and 0ff80h) = 0 then return;
  795.     tdest = 0;
  796.     call setduser;  /* destination user */
  797.     if (sparfil := (sparfil or insparc)) then
  798.         /* set up fcb from random record no. */
  799.         do;
  800. /** $if mpm **/
  801.         call multsect(1);
  802. /** $endif **/
  803.         CALL SETDMA(.dbuff(tdest));
  804.         if write$random(.dest) <> 0 then
  805.             call xerror(16,.dest);  /* DISK WRITE ERROR */
  806.         end;
  807.     else
  808.         CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */
  809. /** $if mpm **/
  810.     if fastcopy then
  811.         do; bufsize = maxmbuf;
  812.         call multsect(maxmcnt);
  813.         end;
  814.     else
  815.         do; bufsize = 128;
  816.         call multsect(1);
  817.         end;
  818. /** $endif **/
  819.  
  820.         do while n - tdest > 127;
  821. /** $if mpm **/
  822.         if fastcopy and (n - tdest < maxmbuf) then
  823.             do; bufsize = n - tdest;
  824.             call multsect(low(shr(bufsize,7)));
  825.             end;
  826. /** $endif **/
  827.         /* SET DMA ADDRESS TO NEXT BUFFER */
  828.         CALL SETDMA(.dbuff(tdest));
  829.         call diskwrite(.dest);
  830.         IF dcnt <> 0 THEN
  831.             call xerror(14,.dest);  /* DISK WRITE ERROR */
  832. /** $if mpm **/
  833.         tdest = tdest + bufsize;
  834. /** $else **/
  835. /** $endif **/
  836.         END;
  837.  
  838.     IF VERIF THEN /* VERIFY DATA WRITTEN OK */
  839.         DO;
  840.         call flushbuf;
  841.         tdest = 0;
  842. /** $if mpm **/
  843.         call multsect(1);
  844. /** $endif **/
  845.         CALL SETDMA(.BUFF); /* FOR COMPARE */
  846.             do while tdest < n;
  847.             DATAOK = (RDRANDOM(.DEST) = 0);
  848.             if (DESTR := DESTR + 1) = 0 then  /* 3 byte inc for */
  849.                 destr2 = destr2 + 1;  /* next random record */
  850.             J = 0;
  851.                 /* PERFORM COMPARISON */
  852.                 DO WHILE DATAOK AND J < 80H;
  853.                 DATAOK = (BUFF(J) = DBUFF(tdest+J));
  854.                 J = J + 1;
  855.                 END;
  856.             tdest = tdest + 128;
  857.             IF NOT DATAOK THEN
  858.                 call xerror(0,.dest);  /* VERIFY ERROR */
  859.             END;
  860.         call diskrd(.dest);
  861.         /* NOW READY TO CONTINUE THE WRITE OPERATION */
  862.         END;
  863.     CALL SETRANDOM(.DEST); /* set base record for sparce copy */
  864.     call move(.dbuff(tdest),.dbuff(0),low(ndest := ndest - tdest));
  865.     END WRITEDEST;
  866.  
  867. FILLSOURCE: PROCEDURE;
  868.     /* FILL THE SOURCE BUFFER */
  869.     call conbrk;
  870. /** $if mpm **/
  871.     if fastcopy then
  872.         do; bufsize = maxmbuf;
  873.         call multsect(maxmcnt);
  874.         end;
  875.     else do;
  876.         bufsize = 128;
  877.         call multsect(1);
  878.         end;
  879. /** $endif **/
  880.     CALL SETSUSER; /* SOURCE USER NUMBER SET */
  881.     nsource = nsbuf;
  882.         do while sblen - nsbuf > 127; 
  883.         if fastcopy and (sblen - nsbuf < maxmbuf) then
  884.             do; bufsize = (sblen - nsbuf) and 0ff80h;
  885.             call multsect(low(shr(bufsize,7)));
  886.             end;
  887.         /* SET DMA ADDRESS TO NEXT BUFFER POSIITION */
  888.         CALL SETDMA(.SBUFF(nsbuf));
  889.         extsave = source.fcb(12);  /* save extent field */
  890.         call diskrd(.source);
  891.         IF dcnt <> 0 THEN
  892.             DO; IF dcnt <> 1 THEN
  893.                 call xerror(13,.source);  /* DISK READ ERROR */
  894.             /* END - OF - FILE */
  895. /** $if mpm **/
  896.             if fastcopy then   /* add no. sectors copied */
  897.                 nsbuf = nsbuf + shl(double(exten),7);
  898.              /* nsbuf = nsbuf + shl(double(exten and 0f0h),3); */
  899. /** $endif **/
  900.             /* check boundry condition for bug in bdos and correct */
  901.             if (source.fcb(12) <> extsave) and (source.fcb(32) = 80h) then
  902.                 source.fcb(32) = 0;  /* zero current record */
  903.             call set$random(.source);
  904.             if (insparc := not maxsize) then
  905.                 do;
  906.                 if concat or (not fastcopy) then
  907.                     /* invalid format with sparce file */
  908.                     call xerror(1,.source);
  909.                 end;
  910.             else
  911.                 do;
  912.                 call close(.source);
  913.                 opened = false;
  914.                 end;
  915.             endofsrc = true;  /* set end of source file */
  916.             SBUFF(nsbuf) = ENDFILE; return;
  917.             END;
  918.         ELSE
  919. /** $if mpm **/
  920.             nsbuf = nsbuf + bufsize;
  921. /** $else **/
  922. /** $endif **/
  923.         END;
  924.     END FILLSOURCE;
  925.  
  926. PUTDCHAR: PROCEDURE(B);
  927.     DECLARE B BYTE;
  928.     /* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY ODEST.TYPE */
  929.     IF B >= ' ' THEN
  930.         DO; COLUMN = COLUMN + 1;
  931.         IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */
  932.             DO; IF COLUMN > DELET THEN RETURN;
  933.             END;
  934.         END;
  935.     if echo then call mon1(2,b);  /* echo to console */
  936.     do case odest.type;
  937.         /* CASE 0 IS OUT */
  938.             CALL OUTD(B);
  939.         /* CASE 1 IS PRN, TABS EXPANDED, LINES LISTED */
  940.             call mon1(5,b);
  941.         /* CASE 2 IS LST */
  942.             CALL MON1(5,B);
  943.         /* CASE 3 IS axo */
  944. axocase:
  945. /** $if not mpm **/
  946.             CALL MON1(4,B);
  947. /** $else **/
  948. /** $endif **/
  949.         /* CASE 4 IS DESTINATION FILE */
  950.             DO;
  951.             IF NDEST >= DBLEN THEN CALL WRITEDEST;
  952.             DBUFF(NDEST) = B;
  953.             NDEST = NDEST+1;
  954.             END;
  955.         /* CASE 5 IS AUX */
  956.            goto axocase;
  957.         /* CASE 6 IS CON */
  958.             CALL MON1(2,B);
  959.         END; /* of case */
  960.     END PUTDCHAR;
  961.  
  962. PUTDESTC: PROCEDURE(B);
  963.     DECLARE (B,I) BYTE;
  964.     /* WRITE DESTINATION CHARACTER, TAB EXPANSION */
  965.     IF B <> TAB THEN CALL PUTDCHAR(B);
  966.     ELSE IF TABS = 0 THEN CALL PUTDCHAR(B);
  967.     ELSE  /* B IS TAB CHAR, TABS > 0 */
  968.         DO; I = COLUMN;
  969.             DO WHILE I >= TABS;
  970.             I = I - TABS;
  971.             END;
  972.         I = TABS - I;
  973.             DO WHILE I > 0;
  974.             I = I - 1;
  975.             CALL PUTDCHAR(' ');
  976.             END;
  977.         END;
  978.     IF B = CR THEN COLUMN = 0;
  979.     END PUTDESTC;
  980.  
  981. PRINT1: PROCEDURE(B);
  982.     DECLARE B BYTE;
  983.     IF (ZEROSUP := ZEROSUP AND B = 0) THEN
  984.         CALL PUTDESTC(' ');
  985.     ELSE
  986.         CALL PUTDESTC('0'+B);
  987.     END PRINT1;
  988.  
  989. PRINTDIG: PROCEDURE(D);
  990.     DECLARE D BYTE;
  991.     CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B);
  992.     END PRINTDIG;
  993.  
  994. NEWLINE: PROCEDURE;
  995.     DECLARE ONE BYTE;
  996.     ONE = 1;
  997.     ZEROSUP = (NUMB = 1);
  998.     C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0);
  999.     CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1);
  1000.     IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */
  1001.         DO; CALL PUTDESTC(':'); CALL PUTDESTC(' ');
  1002.         END;
  1003.     ELSE
  1004.         CALL PUTDESTC(TAB);
  1005.     END NEWLINE;
  1006.  
  1007. PUTDEST: PROCEDURE(B);
  1008.     DECLARE (I,B) BYTE;
  1009.     /* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */
  1010.     IF FORMF THEN /* SKIP FORM FEEDS */
  1011.         DO; IF B = FF THEN RETURN;
  1012.         END;
  1013.     IF PUTNUM THEN /* END OF LINE OR START OF FILE */
  1014.         DO;
  1015.         IF (B <> FF) and (b <> endfile) THEN
  1016.             DO;    /* NOT FORM FEED or end of file */
  1017.             IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */
  1018.                 DO; IF I=1 THEN I=LPP;
  1019.                 IF (LINENO := LINENO + 1) >= I THEN
  1020.                     DO; LINENO = 0; /* NEW PAGE */
  1021.                     CALL PUTDESTC(FF);
  1022.                     END;
  1023.                 END;
  1024.             IF NUMB > 0 THEN
  1025.                 CALL NEWLINE;
  1026.             PUTNUM = FALSE;
  1027.             END;
  1028.         END;
  1029.     IF B = FF THEN LINENO = 0;
  1030.     CALL PUTDESTC(B);
  1031.     IF B = LF THEN PUTNUM = TRUE;
  1032.     END PUTDEST;
  1033.  
  1034.  
  1035. UTRAN: PROCEDURE(B) BYTE;
  1036.     DECLARE B BYTE;
  1037.     /* TRANSLATE ALPHA TO UPPER CASE */
  1038.     IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */
  1039.         B = B AND 101$1111B; /* TO UPPER CASE */
  1040.     RETURN B;
  1041.     END UTRAN;
  1042.  
  1043. LTRAN: PROCEDURE(B) BYTE;
  1044.     DECLARE B BYTE;
  1045.     /* TRANSLATE TO LOWER CASE ALPHA */
  1046.     IF B >= 'A' AND B <= 'Z' THEN
  1047.         B = B OR 10$0000B; /* TO LOWER */
  1048.     RETURN B;
  1049.     END LTRAN;
  1050.  
  1051. GETSOURCEC: PROCEDURE BYTE;
  1052.     /* READ NEXT SOURCE CHARACTER */
  1053.     DECLARE (B,CONCHK) BYTE;
  1054.  
  1055.     CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */
  1056.         DO CASE source.type;
  1057.         /* CASE 0 IS out */
  1058.             go to notsource;
  1059.         /* CASE 1 IS prn */
  1060.             go to notsource;
  1061.         /* CASE 2 IS lst */
  1062.             notsource:
  1063.                   call error(4);  /* INVALID SOURCE */
  1064.         /* CASE 3 IS axo */
  1065.             go to notsource;
  1066.         /* CASE 4 IS SOURCE FILE */
  1067.             DO;
  1068.             IF NSOURCE >= SBLEN THEN
  1069.                 do; if dblbuf or (not dfile) then
  1070.                     nsbuf = 0;
  1071.                 else if (nsource <> 0ffffh) then
  1072.                     do; call writedest;
  1073.                     nsbuf = ndest;
  1074.                     end;
  1075.                 CALL FILLSOURCE;
  1076.                 end;
  1077.             B = SBUFF(NSOURCE);
  1078.             NSOURCE = NSOURCE + 1;
  1079.             END;
  1080.         /* CASE 5 IS AUX */
  1081.            goto axicase;
  1082.         /* CASE 6 IS CON */
  1083.             DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
  1084.             B = MON2(1,0);
  1085.             END;
  1086.         /* CASE 7 IS axi */
  1087. axicase:
  1088. /** $if not mpm **/
  1089.             B = MON2(3,0) AND 7FH;
  1090. /** $else **/
  1091. /** $endif **/
  1092.         /* CASE 7 IS INP */
  1093.             B = INPD;
  1094.         END; /* OF CASES */
  1095.  
  1096.     IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */
  1097.         DO;
  1098.         IF obj THEN /* SOURCE IS AN OBJECT FILE */
  1099.             CONCHK = ((CONCNT := CONCNT + 1) = 0);
  1100.         ELSE /* ASCII */
  1101.             CONCHK = (B = LF);
  1102.         IF CONCHK THEN
  1103.             DO;
  1104.             call CONBRK;
  1105.             END;
  1106.         END;
  1107.     IF ZEROP THEN B = B AND 7FH;
  1108.     IF UPPER THEN RETURN UTRAN(B);
  1109.     IF LOWER THEN RETURN LTRAN(B);
  1110.     RETURN B;
  1111.     END GETSOURCEC;
  1112.  
  1113. GETSOURCE: PROCEDURE BYTE;
  1114.     /* GET NEXT SOURCE CHARACTER */
  1115.     DECLARE CHAR BYTE;
  1116.     MATCH: PROCEDURE(B) BYTE;
  1117.         /* MATCH START AND QUIT STRINGS */
  1118.         DECLARE (B,C) BYTE;
  1119.         IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */
  1120.             DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */
  1121.             RETURN TRUE;
  1122.             END;
  1123.         IF C = CHAR THEN MATCHLEN = MATCHLEN + 1;
  1124.         ELSE
  1125.             MATCHLEN = 0; /* NO MATCH */
  1126.         RETURN FALSE;
  1127.         END MATCH;
  1128.  
  1129.     IF QUITLEN > 0 THEN
  1130.         DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF;
  1131.         RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */
  1132.         END;
  1133.     DO FOREVER; /* LOOKING FOR START */
  1134.     IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */
  1135.         DO; FEEDLEN = FEEDLEN - 1;
  1136.         CHAR = COMBUFF(FEEDBASE);
  1137.         FEEDBASE = FEEDBASE + 1;
  1138.         RETURN CHAR;
  1139.         END;
  1140.     IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE;
  1141.     IF STARTS > 0 THEN /* LOOKING FOR START STRING */
  1142.         DO; IF MATCH(STARTS) THEN
  1143.             DO; FEEDBASE = STARTS; STARTS = 0;
  1144.             FEEDLEN = MATCHLEN + 1;
  1145.             matchlen = 0;
  1146.             END; /* OTHERWISE NO MATCH, SKIP CHARACTER */
  1147.         END;
  1148.     ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */
  1149.         DO; IF MATCH(QUITS) THEN
  1150.             DO; QUITS = 0; QUITLEN = 2;
  1151.             /* SUBSEQUENTLY RETURN CR, LF, ENDFILE */
  1152.             RETURN CR;
  1153.             END;
  1154.         RETURN CHAR;
  1155.         END;
  1156.     ELSE
  1157.         RETURN CHAR;
  1158.     END; /* OF DO FOREVER */
  1159.     END GETSOURCE;
  1160.  
  1161. RD$EOF: PROCEDURE BYTE;
  1162.     /* RETURN TRUE IF END OF FILE */
  1163.     CHAR = GETSOURCE;
  1164.     IF obj THEN RETURN (endofsrc and (nsource > nsbuf));
  1165.     RETURN (CHAR = ENDFILE);
  1166.     END RD$EOF;
  1167.  
  1168.  
  1169. HEXRECORD: PROCEDURE;
  1170.     DECLARE (h, hbuf, RL, CS, RT) BYTE,
  1171.         zerorec byte,  /* true if last record had length of zero */
  1172.         LDA ADDRESS;  /* LOAD ADDRESS WHICH FOLLOWS : */
  1173.  
  1174.     ckhex: procedure byte;
  1175.         IF H - '0' <= 9 THEN
  1176.             RETURN H-'0';
  1177.         IF H - 'A' > 5 THEN
  1178.             CALL xerror(2,.source);  /* invalid hex digit */
  1179.         RETURN H - 'A' + 10;
  1180.         end ckhex;
  1181.  
  1182.     rdhex: procedure byte;
  1183.         call putdest(h := getsource);
  1184.         return ckhex;
  1185.         end rdhex;
  1186.  
  1187.     RDCS: PROCEDURE BYTE;
  1188.         /* READ BYTE WITH CHECKSUM */
  1189.         RETURN CS := CS + (SHL(RDHEX,4) OR RDHEX);
  1190.         END RDCS;
  1191.  
  1192.     RDADDR: PROCEDURE ADDRESS;
  1193.         /* READ DOUBLE BYTE WITH CHECKSUM */
  1194.         RETURN SHL(DOUBLE(RDCS),8) OR RDCS;
  1195.         END RDADDR;
  1196.  
  1197.     /* READ HEX FILE AND CHECK EACH RECORD
  1198.     FOR VALID DIGITS, AND PROPER CHECKSUM */
  1199.     zerorec = false;
  1200.     /* READ NEXT RECORD */
  1201.     h = getsource;
  1202.         do forever;
  1203.         /* SCAN FOR THE ':' */
  1204.             DO WHILE h <> ':';
  1205.             IF (h = ENDFILE) THEN
  1206.                 do; if zerorec then return;
  1207.                 CALL xerror(3,.source);  /* unexpected end of hex file */
  1208.                 end;
  1209.             call putdest(h);
  1210.             h = getsource;
  1211.             END;
  1212.  
  1213.         /* ':' FOUND */
  1214.         /* check for end of hex record */
  1215.         h = getsource;
  1216.         rl = shl(ckhex,4);
  1217.         hbuf = h; h = getsource;
  1218.         rl = rl or ckhex;
  1219.         if (rl = 0) then zerorec = true;
  1220.         else zerorec = false;
  1221.         if (zerorec and ignor) then
  1222.             do while (h <> ':') and (h <> endfile);
  1223.             h = getsource;
  1224.             end;
  1225.         else do; call putdest(':');
  1226.             call putdest(hbuf);
  1227.             call putdest(h);
  1228.             cs = rl;
  1229.             LDA = RDADDR; /* LOAD ADDRESS */
  1230.  
  1231.             /* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */
  1232.             RT = RDCS; /* RECORD TYPE */
  1233.                 DO WHILE RL <> 0; RL = RL - 1;
  1234.                 hbuf = RDCS;
  1235.                 /* INCREMENT LA HERE FOR EXACT ADDRESS */
  1236.                 END;
  1237.  
  1238.             /* CHECK SUM */
  1239.             IF rdcs <> 0 THEN
  1240.                 CALL xerror(4,.source);  /* hex record checksum */
  1241.             h = getsource;
  1242.             end;
  1243.         end; /* do forever */
  1244.     END HEXRECORD;
  1245.  
  1246. CK$STRINGS: PROCEDURE;
  1247.     IF STARTS > 0 THEN
  1248.         call error(11);  /* START NOT FOUND */
  1249.     IF QUITS  > 0 THEN
  1250.         call error(12);  /* QUIT NOT FOUND */
  1251.     END CK$STRINGS;
  1252.  
  1253. CLOSEDEST: PROCEDURE;
  1254.         DO WHILE (LOW(NDEST) AND 7FH) <> 0;
  1255.         CALL PUTDEST(ENDFILE);
  1256.         END;
  1257.     CALL CK$STRINGS;
  1258.     CALL WRITEDEST;
  1259.     call setduser;  /* destination user */
  1260.     CALL CLOSE(.DEST);
  1261.     IF DCNT = 255 THEN
  1262. /** $if mpm **/
  1263.         call xerror(8,.dest);  /* CLOSE FILE */
  1264.     IF odcnt <> 255 THEN /* FILE EXISTS */
  1265.         do;
  1266. /** $else **/
  1267. /** $endif **/
  1268.         IF ROL(odest.fcb(9),1) THEN /* READ ONLY */
  1269.             DO;
  1270.             IF NOT WRROF THEN
  1271.                 DO;
  1272.                     do while ((dcnt <> 'Y') and (dcnt <> 'N'));
  1273.                     CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)? $'));
  1274.                     dcnt = utran(rdchar);
  1275.                     end;
  1276.                 IF dcnt <> 'Y' THEN
  1277.                     DO; CALL PRINT(.('**NOT DELETED**$'));
  1278.                     CALL CRLF;
  1279.                     CALL DELETE(.DEST);
  1280.                     RETURN;
  1281.                     END;
  1282.                 CALL CRLF;
  1283.                 END;
  1284.             END;
  1285.         /* reset r/o and sys attributes */
  1286.         odest.fcb(9) = odest.fcb(9) and 7fh;
  1287.         odest.fcb(10) = odest.fcb(10) AND 7FH;
  1288.         CALL SETIND(.odest);
  1289.         CALL DELETE(.odest);
  1290.         END;
  1291.     CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */
  1292.     CALL RENAME(.DEST);
  1293.     /* set destination attributes same as source */
  1294.     odest.fcb(1) = (odest.fcb(1) and 07fh) or f1;
  1295.     odest.fcb(2) = (odest.fcb(2) and 07fh) or f2;
  1296.     odest.fcb(3) = (odest.fcb(3) and 07fh) or f3;
  1297.     odest.fcb(4) = (odest.fcb(4) and 07fh) or f4;
  1298.     odest.fcb(8) = (odest.fcb(8) and 07fh);
  1299.     odest.fcb(9) = (odest.fcb(9) and 07fh) or ro;
  1300.     odest.fcb(10) = (odest.fcb(10) and 07fh) or sys;
  1301.     odest.fcb(11) = (odest.fcb(11) and 07fh);
  1302.     call setind(.odest);
  1303.     if archiv then   /* set archive bit */
  1304.         do; call setsuser;
  1305.         source.fcb(11) = source.fcb(11) or 080h;
  1306.         source.fcb(12) = 0;
  1307.         call setind(.source);
  1308.         end;
  1309.     END CLOSEDEST;
  1310.  
  1311. SIZE$MEMORY: PROCEDURE;
  1312.     /* SET UP SOURCE AND DESTINATION BUFFERS */
  1313.     if not dblbuf then
  1314.         do;  /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
  1315.         sbase = .memory;
  1316.         sblen,dblen = ((maxb - .memory) and 0ff80h) - 128;
  1317.         end;
  1318.     else do;  /* may need to write destination buffer */
  1319.         sblen,dblen = (shr((maxb - .memory),1) and 0ff80h) - 128;
  1320.         sbase = .memory + dblen + 128;
  1321.         if ndest >= dblen then call writedest;
  1322.         nsbuf = 0;
  1323.         end;
  1324.     END SIZE$MEMORY;
  1325.  
  1326. setupeob: procedure;
  1327.     /* sets nsbuf to end of source buffer */
  1328.     declare i byte;
  1329.     if (not obj) and (nsbuf <> 0) then
  1330.         do; tblen = nsbuf - 128;
  1331.             do i = 0 to 128;
  1332.             if (sbuff(tblen + i)) = endfile then
  1333.                 do; nsbuf = tblen + i;
  1334.                 return;
  1335.                 end;
  1336.             end;
  1337.         end;
  1338.     end setupeob;
  1339.  
  1340. SIMPLECOPY: PROCEDURE;
  1341.     DECLARE I BYTE;
  1342.     declare
  1343.         fast lit '0',  /* fast file to file copy */
  1344.         chrt lit '1',  /* character transfer option */
  1345.         dubl lit '2';  /* double buffer required for file copy */
  1346.     declare optype(26) byte data (
  1347.     /* option type for each option character */
  1348.         fast,  /* for A option */
  1349.         fast,  /* for B option */
  1350.         fast,  /* for C option */
  1351.         dubl,  /* for D option */
  1352.         chrt,  /* for E option */
  1353.         dubl,  /* for F option */
  1354.         fast,  /* for G option */
  1355.         chrt,  /* for H option */
  1356.         dubl,  /* for I option */
  1357.         fast,  /* for J option */
  1358.         fast,  /* for K option */
  1359.         chrt,  /* for L option */
  1360.         fast,  /* for M option */
  1361.         dubl,  /* for N option */
  1362.         fast,  /* for O option */
  1363.         dubl,  /* for P option */
  1364.         dubl,  /* for Q option */
  1365.         fast,  /* for R option */
  1366.         dubl,  /* for S option */
  1367.         dubl,  /* for T option */
  1368.         chrt,  /* for U option */
  1369.         fast,  /* for V option */
  1370.         fast,  /* for W option */
  1371.         fast,  /* for X option */
  1372.         fast,  /* for Y option */
  1373.         chrt); /* for Z option */
  1374.  
  1375.     chkrandom: procedure;
  1376.         call setsuser;
  1377.         call set$random(.source);
  1378. /** $if mpm **/
  1379.         call multsect(1);
  1380. /** $endif **/
  1381.         call setdma(.buff);
  1382.             do forever;
  1383.             if (((dcnt := rd$random(.source)) = 0) or maxsize) then
  1384.                 do; destr = sourcer;
  1385.                 destr2 = sourcer2;
  1386.                 endofsrc = false;
  1387.                 return;
  1388.                 end;
  1389.             if dcnt = 1 then
  1390.                 do; if (sourcer := sourcer + 1) = 0 then
  1391.                     sourcer2 = sourcer2 + 1;
  1392.                 end;
  1393.             else if dcnt = 4 then
  1394.                 do;
  1395.                 if (sourcer := (sourcer + 128) and 0ff80h) = 0 then
  1396.                     sourcer2 = sourcer2 + 1;
  1397.                 end;
  1398.             else
  1399.                 call xerror(15,.source);
  1400.             end;
  1401.         end chkrandom;
  1402.  
  1403.     fastcopy = (sfile and dfile);
  1404.     endofsrc = false;
  1405.     dblbuf = false;
  1406.     sparfil = false;
  1407.     insparc = false;
  1408.         /* LOOK FOR PARAMETERS */
  1409.         DO I = 0 TO 25;
  1410.         IF CONT(I) <> 0 THEN
  1411.             DO;
  1412.             IF optype(i) = chrt THEN
  1413.                 FASTCOPY = FALSE;
  1414.             else
  1415.             if optype(i) = dubl then
  1416.                 do; dblbuf = (sfile and dfile);
  1417.                 fastcopy = false;
  1418.                 end;
  1419.             END;
  1420.         END;
  1421.  
  1422.     CALL SIZE$MEMORY;
  1423.     if sfile then 
  1424.         CALL SETUPSOURCE;
  1425.         /* FILES READY FOR COPY */
  1426.  
  1427.     if fastcopy then
  1428.         do while not endofsrc;
  1429.         CALL FILLSOURCE;
  1430.         if endofsrc and concat then
  1431.             do; call setupeob;
  1432.             ndest = nsbuf;
  1433.             if nendcmd then return;
  1434.             end;
  1435.         ndest = nsbuf;
  1436.         CALL WRITEDEST;
  1437.         nsbuf = ndest;
  1438.         if (endofsrc and insparc) then
  1439.             call chkrandom;
  1440.         end;
  1441.  
  1442.     else do;
  1443.         /* PERFORM THE ACTUAL COPY FUNCTION */
  1444.         IF HEXT OR IGNOR THEN /* HEX FILE */
  1445.             call hexrecord;
  1446.         ELSE
  1447.             DO WHILE NOT RD$EOF;
  1448.             CALL PUTDEST(CHAR);
  1449.             END;
  1450.         if concat and nendcmd then
  1451.             do; nsbuf = ndest;
  1452.             return;
  1453.             end;
  1454.         end;
  1455.  
  1456.     if dfile then
  1457.         CALL CLOSEDEST;
  1458.     END SIMPLECOPY;
  1459.  
  1460. MULTCOPY: PROCEDURE;
  1461.     DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS;
  1462.  
  1463.     PRNAME: PROCEDURE;
  1464.         /* PRINT CURRENT FILE NAME */
  1465.         DECLARE (I,C) BYTE;
  1466.         CALL CRLF;
  1467.             DO I = 1 TO FNSIZE;
  1468.             IF (C := odest.fcb(I)) <> ' ' THEN
  1469.                 DO; IF I = FEXT THEN CALL PRINTCHAR('.');
  1470.                 CALL PRINTCHAR(C);
  1471.                 END;
  1472.             END;
  1473.         END PRNAME;
  1474.  
  1475.     archck: procedure byte;
  1476.         /* check if archive bit is set in any extent of source file */
  1477.         if not archiv then
  1478.             return 1;
  1479.         call setsuser;
  1480.         source.fcb(12) = what;
  1481.         call search(.source);
  1482.             do while dcnt <> 255;
  1483.             call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),15);
  1484.             if not rol(source.fcb(11),1) then
  1485.                 return 1;
  1486.             call searchn;
  1487.             end;
  1488.         return 0;
  1489.         end archck; 
  1490.  
  1491. /** $if mpm **/
  1492.     /* initialize counters if not error retry */
  1493.     if eretry = 0 then NEXTDIR, NCOPIED = 0;
  1494. /** $else **/
  1495. /** $endif **/
  1496.  
  1497.         DO FOREVER;
  1498.         /* FIND A MATCHING ENTRY */
  1499.         CALL SETSUSER; /* SOURCE USER */
  1500.         CALL SETDMA(.BUFF);
  1501.         searfcb(12) = 0;
  1502.         CALL SEARCH(.SEARFCB);
  1503.         NDCNT = 0;
  1504.             DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR;
  1505.             NDCNT = NDCNT + 1;
  1506.             CALL SEARCHN;
  1507.             END;
  1508.         /* FILE CONTROL BLOCK IN BUFFER */
  1509.         IF DCNT = 255 THEN
  1510.             DO; IF NCOPIED = 0 THEN
  1511.                 call xerror(9,.searfcb);  /* file not found */
  1512.             if not kilds then
  1513.                 CALL CRLF;
  1514.             RETURN;
  1515.             END;
  1516.         NEXTDIR = NDCNT + 1;
  1517.         /* GET THE FILE CONTROL BLOCK NAME TO DEST */
  1518.         CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15);
  1519.         CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */
  1520.         if archck then
  1521.             do; odest.fcb(12) = 0;
  1522.             source.fcb(12) = 0;
  1523.             IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */
  1524.                 DO; if not kilds then    /* kill display option */
  1525.                     do; IF NCOPIED = 0 THEN
  1526.                         CALL PRINT(.('COPYING -$'));
  1527.                     dcnt = false;
  1528.                         do while ((dcnt <> 'Y') and (dcnt <> 'N'));
  1529.                         call prname;
  1530.                         if confrm then
  1531.                             do; call printx(.(' (Y/N)? $'));
  1532.                             dcnt = utran(rdchar);
  1533.                             end;
  1534.                         else
  1535.                             dcnt = 'Y';
  1536.                         end;
  1537.                     end;
  1538.                 ncopied = ncopied + 1;
  1539.                 made = false;  /* destination file not made */
  1540.                 if (dcnt = 'Y') or (kilds) then
  1541.                     CALL SIMPLECOPY;
  1542.                 END;
  1543.             end;
  1544.         END;
  1545.     END MULTCOPY;
  1546.  
  1547. CK$DISK: PROCEDURE;
  1548.     /* error if same user and same disk */
  1549.     IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN
  1550.         CALL FORMERR;
  1551.     END CK$DISK;
  1552.  
  1553. GNC: PROCEDURE BYTE;
  1554.     IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR;
  1555.     RETURN UTRAN(COMBUFF(CBP));
  1556.     END GNC;
  1557.  
  1558. DEBLANK: PROCEDURE;
  1559.         DO WHILE (CHAR := GNC) = ' ';
  1560.         END;
  1561.     END DEBLANK;
  1562.  
  1563. CK$EOL: PROCEDURE;
  1564.     CALL DEBLANK;
  1565.     IF CHAR <> CR THEN CALL FORMERR;
  1566.     END CK$EOL;
  1567.  
  1568. SCAN: PROCEDURE(FCBA);
  1569.     DECLARE FCBA ADDRESS,         /* ADDRESS OF FCB TO FILL */
  1570.     fcbs based fcba structure (    /* FCB STRUCTURE */
  1571.         fcb(frsize) byte,
  1572. /** $if mpm **/
  1573.         pwnam(nsize) byte,
  1574.         pwmode byte,
  1575. /** $endif **/
  1576.         user byte,
  1577.         type byte );
  1578.     DECLARE (I,K) BYTE;  /* TEMP COUNTERS */
  1579.  
  1580.     /* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME.
  1581.     THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */
  1582.  
  1583.     DELIMITER: PROCEDURE(C) BYTE;
  1584.         DECLARE (I,C) BYTE;
  1585.         DECLARE DEL(*) BYTE DATA
  1586.         (' =.:;,<>',CR,LA,LB,RB);
  1587.             DO I = 0 TO LAST(DEL);
  1588.             IF C = DEL(I) THEN RETURN TRUE;
  1589.             END;
  1590.         RETURN FALSE;
  1591.         END DELIMITER;
  1592.  
  1593.     PUTCHAR: PROCEDURE;
  1594.         FCBS.FCB(FLEN:=FLEN+1) = CHAR;
  1595.         IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */
  1596.         END PUTCHAR;
  1597.  
  1598.     FILLQ: PROCEDURE(LEN);
  1599.         /* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */
  1600.         DECLARE LEN BYTE;
  1601.         CHAR = WHAT; /* QUESTION MARK */
  1602.             DO WHILE FLEN < LEN; 
  1603.             CALL PUTCHAR;
  1604.             END;
  1605.         END FILLQ;
  1606.  
  1607.     SCANPAR: PROCEDURE;
  1608.         DECLARE (I,J) BYTE;
  1609.         /* SCAN OPTIONAL PARAMETERS */
  1610.         CHAR = GNC; /* SCAN PAST BRACKET */
  1611.             DO WHILE NOT(CHAR = CR OR CHAR = RB);
  1612.             IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */
  1613.                 DO; IF CHAR = ' ' THEN
  1614.                     CHAR = GNC;
  1615.                 ELSE
  1616.                     call error(6);  /* BAD PARAMETER */
  1617.                 END;
  1618.             ELSE
  1619.                 DO; /* SCAN PARAMETER VALUE */
  1620.                 IF CHAR = 'S' OR CHAR = 'Q' THEN
  1621.                     DO; /* START OR QUIT COMMAND */
  1622.                     J = CBP + 1; /* START OF STRING */
  1623.                         DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR);
  1624.                         END;
  1625.                      CHAR=GNC;
  1626.                     END;
  1627.                 ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN
  1628.                     J = 1;
  1629.                 ELSE
  1630.                     DO WHILE (K := (CHAR := GNC) - '0') <= 9;
  1631.                     J = J * 10 + K;
  1632.                     END;
  1633.                 CONT(I) = J;
  1634.                 IF I = 6 THEN /* SET SOURCE USER */
  1635.                     DO;
  1636.                     IF J > 15 THEN
  1637.                         call error(7);  /* INVALID USER NUMBER */
  1638.                     fcbs.user = J;
  1639.                     END;
  1640.                 END;
  1641.             END;
  1642.         CHAR = GNC;
  1643.         END SCANPAR;
  1644.  
  1645.  
  1646.     /* scan procedure entry point */
  1647.  
  1648.     /* INITIALIZE FILE CONTROL BLOCK TO EMPTY */
  1649.     fcbs.type = ERR; CHAR = ' '; FLEN = 0;
  1650. /** $if mpm **/
  1651.         DO WHILE FLEN < (FRSIZE + NSIZE);
  1652.         IF FLEN = FNSIZE THEN CHAR = 0;
  1653.         ELSE IF FLEN = FRSIZE THEN CHAR = ' ';
  1654.         call putchar;
  1655.         END;
  1656.     fcbs.pwnam(0) = 0;
  1657.     fcbs.pwmode = 1;
  1658. /** $else **/
  1659. /** $endif **/
  1660.     fcbs.fcb(0) = cdisk +1;    /* initialize to current disk */
  1661.     fcbs.user = cuser;    /* and current user */
  1662.     /* CLEAR PARAMETERS */
  1663.         DO I = 0 TO 25; CONT(I) = 0;
  1664.         END;
  1665.     FEEDLEN,MATCHLEN,QUITLEN = 0;
  1666.  
  1667.     /* DEBLANK COMMAND BUFFER */
  1668.     CALL DEBLANK;
  1669.  
  1670.     /* CHECK PERIPHERALS AND DISK FILES */
  1671.     /* SCAN NEXT NAME */
  1672.         DO FOREVER;
  1673.         FLEN = 0;
  1674.             DO WHILE NOT DELIMITER(CHAR);
  1675.             IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */
  1676.                 RETURN;
  1677.             IF CHAR = '*' THEN CALL FILLQ(NSIZE);
  1678.             ELSE CALL PUTCHAR;
  1679.             CHAR = GNC;
  1680.             END;
  1681.  
  1682.         /* CHECK FOR DISK NAME OR DEVICE NAME */
  1683.         IF CHAR = ':' THEN
  1684.             DO; IF FLEN = 1 THEN
  1685.                 /* MAY BE DISK NAME A ... P */
  1686.                 DO;
  1687.                 IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 16 THEN
  1688.                     RETURN;  /* ERROR, INVALID DISK NAME */
  1689.                 CALL DEBLANK; /* MAY BE DISK NAME ONLY */
  1690.                 IF DELIMITER(CHAR) THEN
  1691.                     DO; IF CHAR = LB THEN
  1692.                         CALL SCANPAR;
  1693.                     CBP = CBP - 1;
  1694.                     fcbs.type = DISKNAME;
  1695.                     RETURN;
  1696.                     END;
  1697.                 END;
  1698.             ELSE
  1699.             /* MAY BE A THREE CHARACTER DEVICE NAME */
  1700.             IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */
  1701.                 RETURN;
  1702.             ELSE
  1703.                 /* LOOK FOR DEVICE NAME */
  1704.                 DO; DECLARE (I,J,K) BYTE, M LITERALLY '9',
  1705.                 IO(*) BYTE DATA
  1706.                 ('OUTPRNLSTAXO',
  1707.                   0,0,0,         /* fake area for file type */
  1708.                  'AUX',
  1709.                  'CONAXIINPNULEOF',0);
  1710.  
  1711.                 J = 255;
  1712.                     DO K = 0 TO M;
  1713.                     I = 0;
  1714.                         DO WHILE ((I:=I+1) <= 3) AND
  1715.                         IO(J+I) = fcbs.fcb(I);
  1716.                         END;
  1717.                     IF I = 4 THEN /* COMPLETE MATCH */
  1718.                         DO; fcbs.type = k;
  1719.                         /* SCAN PARAMETERS */
  1720.                         IF GNC = LB THEN CALL SCANPAR;
  1721.                         CBP = CBP - 1;
  1722.                         RETURN;
  1723.                         END;
  1724.                     J = J + 3;  /* OTHERWISE TRY NEXT DEVICE */
  1725.                     END;
  1726.                 RETURN;  /* ERROR, NO DEVICE NAME MATCH */
  1727.                 END;
  1728.             IF CHAR = LB THEN /* PARAMETERS FOLLOW */
  1729.                 CALL SCANPAR;
  1730.             END;
  1731.         ELSE
  1732.             /* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */
  1733.             DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */
  1734.                 RETURN;
  1735.             FLEN = NSIZE;
  1736.             IF CHAR = '.' THEN /* SCAN FILE TYPE */
  1737.                 DO WHILE NOT DELIMITER(CHAR := GNC);
  1738.                 IF FLEN >= FNSIZE THEN
  1739.                     RETURN;  /* ERROR, TYPE FIELD TOO LONG */
  1740.                 IF CHAR = '*' THEN CALL FILLQ(FNSIZE);
  1741.                 ELSE CALL PUTCHAR;
  1742.                 END;
  1743. /** $if mpm **/
  1744.             FLEN = 0;
  1745.             IF CHAR = ';' THEN  /* SCAN PASSWORD */
  1746.                 DO WHILE NOT DELIMITER(CHAR := GNC);
  1747.                 IF FLEN >= NSIZE THEN
  1748.                     /* ERROR, PW TOO LONG */ RETURN;
  1749.                 ELSE  /* SAVE PASSWORD */
  1750.                     FCBS.PWNAM(FLEN) = CHAR;
  1751.                     FLEN = FLEN + 1;
  1752.                 END;
  1753. /** $endif **/
  1754.             IF CHAR = LB THEN
  1755.                 CALL SCANPAR;
  1756.             /* RESCAN DELIMITER NEXT TIME AROUND */
  1757.             CBP = CBP - 1;
  1758.             fcbs.type = FILE;
  1759.             FCBS.FCB(32) = 0;
  1760.             RETURN;
  1761.             END;
  1762.         END;
  1763.     END SCAN;
  1764.  
  1765.  
  1766. /* PLM (PIP) ENTRY POINT */
  1767.     /* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED
  1768.     FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */
  1769.  
  1770.     if not retry then
  1771.         do; CALL MOVE(.BUFF,.COMLEN,80H);
  1772.         MULTCOM = (COMLEN = 0);
  1773.  
  1774.         /* GET CURRENT CP/M VERSION */
  1775.         IF low(CVERSION) < VERSION THEN
  1776.             DO;
  1777. /** $if cpm3 **/
  1778.             CALL PRINT(.('REQUIRES CP/M 3$'));
  1779. /** $else **/
  1780. /** $endif **/
  1781.             CALL BOOT;
  1782.             END;
  1783.  
  1784.         call mon1(45,255);  /* set return error mode */
  1785.  
  1786. /** $if cpm3 **/
  1787.         call mon1(109,1);  /* set CP/M 3 control-C status mode */
  1788. /** $endif **/
  1789.  
  1790.         if multcom then
  1791.             do;
  1792. /** $if cpm3 **/
  1793.             call printx(.('CP/M 3 PIP VERSION 3.0$'));
  1794. /** $else **/
  1795. /** $endif **/
  1796.             call crlf;
  1797.             end;
  1798.  
  1799.         cuser,last$user = getuser;  /* GET CURRENT USER */
  1800.         cdisk = getdisk;            /* GET CURRENT DISK */
  1801. /** $if mpm **/
  1802.         mseccnt = 1;
  1803. /** $endif **/
  1804.         eretry = false; /* need to initialize here for first time */
  1805.         end;
  1806.  
  1807.  
  1808.     /* START HERE ON RESET EXIT FROM THE PROCEDURE 'ERROR' */
  1809. /** $if mpm **/
  1810.     if eretry <> 0 then 
  1811.         do; call multcopy;
  1812.         comlen = multcom;
  1813.         end;
  1814. /** $endif **/
  1815.     /* MAIN PROCESSING LOOP.  PROCESS UNTIL CR ONLY */
  1816.         DO FOREVER;
  1817.         C1, C2, C3 = 0;     /* LINE COUNT = 000000 */
  1818.         CONCNT,COLUMN = 0;  /* PRINTER TABS */
  1819.         ndest,nsbuf = 0;
  1820.         ambig = false;
  1821.         made = false;       /* destination file not made */
  1822.         opened = false;     /* source file not opened */
  1823.         concat = false;
  1824.         eretry = false;
  1825.         PUTNUM = TRUE;      /* ACTS LIKE LF OCCURRED ON ASCII FILE */
  1826.         dfile,sfile = true;
  1827.         nendcmd = true;
  1828.         LINENO = 254;       /* INCREMENTED TO 255 > PAGCNT */
  1829.         /* READ FROM CONSOLE IF NOT A ONELINER */
  1830.         IF MULTCOM THEN
  1831.             DO; CALL PRINTCHAR('*'); CALL RDCOM;
  1832.             CALL CRLF;
  1833.             END;
  1834.         CBP = 255;
  1835.         IF COMLEN = 0 THEN      /* character = <CR> */
  1836.             do; call setcuser;  /* restore current user */
  1837.             CALL BOOT;          /* normal exit from pip here */
  1838.             end;
  1839.  
  1840.         /* LOOK FOR SPECIAL CASES FIRST */
  1841.  
  1842.         CALL SCAN(.odest);
  1843.         if ambig then
  1844.             call xerror(5,.odest);  /* invalid destination */
  1845.         call deblank;  /* check for equal sign or left arrow */
  1846.         if (char <> '=') and (char <> la) then call formerr;
  1847.         call scan(.source);
  1848.  
  1849.         IF odest.type = DISKNAME THEN
  1850.             DO;
  1851.             IF source.type <> file then call formerr;
  1852.             CALL CK$EOL;
  1853.             CALL CK$DISK;
  1854.             odest.type = file;  /* set for character transfer */
  1855.             /* MAY BE MULTI COPY */
  1856.             IF AMBIG THEN  /* FORM IS A:=B:AFN */
  1857.                 DO;
  1858.                 CALL MOVE(.source.fcb(0),.searfcb(0),frsize);
  1859.                 CALL MULTCOPY;
  1860.                 END;
  1861.             ELSE DO;  /* FORM IS A:=B:UFN */
  1862.                 CALL MOVE(.source.fcb(1),.odest.fcb(1),frsize - 1);
  1863.                 CALL SIMPLECOPY;
  1864.                 END;
  1865.             END;
  1866.  
  1867.         else IF (odest.type = FILE) and (source.type = DISKNAME) THEN
  1868.                 DO;
  1869.                 CALL CK$EOL;
  1870.                 CALL CK$DISK;
  1871.                 source.type = file;  /* set for character transfer */
  1872. /** $if mpm **/
  1873.                 call move(.odest.fcb(1),.source.fcb(1),(frsize+nsize));
  1874. /** $else **/
  1875. /** $endif **/
  1876.                 CALL SIMPLECOPY;
  1877.                 END;
  1878.  
  1879.         else if (odest.type > cons) then
  1880.             call error(3);  /* invalid destination */
  1881.         else do;
  1882.             IF odest.type <> FILE THEN dfile = false;
  1883. /** $if not mpm **/
  1884.             /* no conditional attach list device */
  1885. /** $else **/
  1886. /** $endif **/
  1887.             /* SCAN AND COPY UNTIL CR */
  1888.                 DO WHILE nendcmd;
  1889.                 sfile = true;
  1890.                 call deblank;
  1891.                 IF (CHAR <> ',' AND CHAR <> CR) THEN
  1892.                     call error(16);  /* invalid separator */
  1893.                 concat = concat or (nendcmd := (char = ','));
  1894.                 IF odest.type = PRNT THEN
  1895.                     DO; NUMB = 1;
  1896.                     IF TABS = 0 THEN TABS = 8;
  1897.                     IF PAGCNT = 0 THEN PAGCNT = 1;
  1898.                     END;
  1899.                 IF (source.type < file) or (source.type > eoft) or ambig THEN
  1900.                     call error(4);  /* invalid source */
  1901.                 IF source.type <> FILE THEN  /* NOT A SOURCE FILE */
  1902.                     sfile = false;
  1903.                 IF source.type = NULT THEN
  1904.                     /* SEND 40 NULLS TO OUTPUT DEVICE */
  1905.                     DO sfile = 0 TO 39; CALL PUTDEST(0);
  1906.                     END;
  1907.                 ELSE IF source.type = EOFT THEN
  1908.                     CALL PUTDEST(ENDFILE);
  1909.                 else call simplecopy;
  1910.  
  1911.                 CALL CK$STRINGS;
  1912.                 /* READ ENDFILE, GO TO NEXT SOURCE */
  1913.  
  1914.                 if nendcmd then call scan(.source);
  1915.                 END;
  1916.             end;
  1917.  
  1918.         /* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */
  1919.         COMLEN = MULTCOM;
  1920.  
  1921.         END; /* DO FOREVER */
  1922.     end plm;
  1923.     END;
  1924.  
  1925. EOF
  1926.