API tools faq
paste
Advertisement
Guest User

PIP.PLM - Peripheral Interchange Program - CP/M Kopierprog.

a guest
Nov 7th, 2017
236
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
PL/I 49.06 KB | None | 0 0
raw download clone embed print report
  1. PIPMOD:
  2. DO;
  3. /* 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
  4.  
  5.          COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980
  6.          DIGITAL RESEARCH
  7.          BOX 579
  8.          PACIFIC GROVE, CA
  9.          93950
  10.     */
  11.  
  12. DECLARE
  13.     CPMVERSION LITERALLY '0020H'; /* REQUIRED FOR OPERATION */
  14.  
  15. DECLARE
  16.     IOBYTE   BYTE EXTERNAL,     /* IOBYTE AT 0003H */
  17.     MAXB  ADDRESS EXTERNAL,     /* ADDR FIELD OF JMP BDOS */
  18.     FCB (33) BYTE EXTERNAL,     /* DEFAULT FILE CONTROL BLOCK */
  19.     BUFF(128)BYTE EXTERNAL;     /* DEFAULT BUFFER */
  20.  
  21. DECLARE
  22.     ENDFILE LITERALLY '1AH',    /* END OF FILE MARK */
  23.     JMP   LITERALLY '0C3H',     /* 8080 JUMP INSTRUCTION */
  24.     RET   LITERALLY '0C9H';     /* 8080 RETURN */
  25.  
  26. /* THE FIRST PORTION OF THE PIP PROGRAM 'FAKES' THE PAGE ONE
  27. (100H - 1FFH) SECTION OF PIP WHICH CONTAINS A JUMP TO PIPENTRY, AND
  28. SPACE FOR CUSTOM I/O DRIVERS (WHICH CAN BE 'PATCHED' USING DDT) IN THE
  29. REMAINING PAGE ONE AREA.  THE PIP PROGRAM ACTUALLY STARTS AT 200H */
  30.  
  31. DECLARE JUMP BYTE DATA(JMP); /* JMP INSTRUCTION TO */
  32. /* JMP .PIPENTRY-3 WHERE THE LXI SP,STACK ACTUALLY OCCURS */
  33. DECLARE JADR ADDRESS DATA(.PIPENTRY-3); /* START OF PIP */
  34. DECLARE INPSUB(3) BYTE DATA(RET,0,0);     /* INP: RET NOP NOP */
  35. DECLARE OUTSUB(3) BYTE DATA(RET,0,0);     /* OUT: RET NOP NOP */
  36. DECLARE INPDATA BYTE DATA(ENDFILE); /* RETURNED DATA */
  37.     /* NOTE:  PAGE 1 AT 100H CONTAINS THE FOLLOWING
  38.     100H:  JMP PIPENTRY    ;TO START THE PIP PROGRAM
  39.     103H:  RET             ;INP: DEFAULTS TO EMPTY INPUT (DATA 1AH AT 109H)
  40.     104H:  NOP
  41.     105H:  NOP
  42.     106H:  RET             ;OUT: DEFAULTS TO EMPTY OUTPUT
  43.     107H:  NOP
  44.     108H:  NOP
  45.     109H: 1AH=ENDFILE      ;DATA FROM INP: FUNCTION IS STORED HERE ON
  46.                            ;RETURN FROM THE INP: ENTRY POINT
  47.     10AH: - 1FFH           ;SPACE RESERVED FOR SPECIAL PURPOSE
  48.     ; DRIVERS - IF INCLUDED, THEN REPLACE 103H AND 106H BY JMP'S
  49.     ; TO THE PROPER LOCATIONS WITHIN THE RESERVED AREA.
  50.     ;  ALSO, RETURN DATA FROM INP: ENTRY POINT AT 109H.
  51.     ; THESE DRIVERS ARE MOST EASILY INSERTED WITH THE DDT PROGRAM
  52.     ; UNDER CP/M
  53.     */
  54.  
  55. DECLARE /* 16 BYTE MESSAGE */
  56.     FREEMEMORY LITERALLY '''(INP:/OUT:SPACE)''',
  57.     /* 256 BYTE AREA FOR INP: OUT: PATCHING */
  58.     RESERVED(*) BYTE DATA(0,0,0,0,0,0,
  59.     FREEMEMORY, FREEMEMORY, FREEMEMORY,
  60.     FREEMEMORY, FREEMEMORY, FREEMEMORY, FREEMEMORY,
  61.     FREEMEMORY, FREEMEMORY, FREEMEMORY, FREEMEMORY,
  62.     FREEMEMORY, FREEMEMORY, FREEMEMORY, FREEMEMORY);
  63.  
  64.  
  65.  
  66.  
  67.     DECLARE COPYRIGHT(*) BYTE DATA (
  68.     '   COPYRIGHT (C) 1979, DIGITAL RESEARCH,  PIP VERS 1.5');
  69.  
  70.     DECLARE INPLOC ADDRESS DATA (.INPSUB);  /* ADDRESS OF INP: DEVICE */
  71.     DECLARE OUTLOC ADDRESS DATA (.OUTSUB);  /* ADDRESS OF OUT: DEVICE */
  72.  
  73. OUT: PROCEDURE(B);
  74.     DECLARE B BYTE;
  75.     /* SEND B TO OUT: DEVICE */
  76.     CALL OUTLOC;
  77.     END OUT;
  78.  
  79. INP: PROCEDURE BYTE;
  80.     CALL INPLOC;
  81.     RETURN INPDATA;
  82.     END INP;
  83.  
  84.  
  85. TIMEOUT: PROCEDURE;
  86.     /* WAIT FOR 50 MSEC */
  87.     CALL TIME(250); CALL TIME(250);
  88.     END TIMEOUT;
  89.  
  90.   /* LITERAL DECLARATIONS */
  91.   DECLARE
  92.     LIT LITERALLY 'LITERALLY',
  93.     LPP LIT '60',     /* LINES PER PAGE */
  94.     TAB LIT '09H',    /* HORIZONTAL TAB */
  95.     FF  LIT '0CH',    /* FORM FEED */
  96.     LA  LIT '05FH',   /* LEFT ARROW */
  97.     LB  LIT '05BH',   /* LEFT BRACKET */
  98.     RB   LIT '05DH',  /* RIGHT BRACKET */
  99.     XOFF LIT '13H', /* TRANSMIT BUFFER FUNCTION */
  100.  
  101.     RDR LIT '5',
  102.     LST LIT '10',
  103.     PUNP LIT '15',                 /* POSITION OF 'PUN' + 1 */
  104.     CONP LIT '19',                 /* CONSOLE */
  105.     NULP LIT '19',                /* NUL: BEFORE INCREMENT */
  106.     EOFP LIT '20',                /* EOF: BEFORE INCREMENT */
  107.     HSRDR LIT 'RDR',              /* READER DEVICES */
  108.     PRNT  LIT '10',                /* PRINTER */
  109.  
  110.  
  111.     FSIZE LIT '33',
  112.     FRSIZE LIT '36', /* SIZE OF RANDOM FCB */
  113.     NSIZE LIT '8',
  114.     FNSIZE LIT '11',
  115.     MDISK LIT '1',
  116.     FNAM LIT '8',
  117.     FEXT LIT '9',
  118.     FEXTL LIT '3',
  119.     ROFILE  LITERALLY '9',  /* READ ONLY FILE FIELD */
  120.     SYSFILE LITERALLY '10', /* SYSTEM FILE FIELD */
  121.     FREEL LIT '12',  /* REEL NUMBER FIELD OF FCB */
  122.  
  123.     HBUFS LIT '80',               /* "HEX" BUFFER SIZE */
  124.  
  125.     ERR LIT '0',
  126.     SPECL LIT '1',
  127.     FILE LIT '2',
  128.     PERIPH LIT '3',
  129.     DISKNAME LIT '4';
  130.  
  131. DECLARE
  132.     COLUMN BYTE,     /* COLUMN COUNT FOR PRINTER TABS */
  133.     LINENO BYTE,     /* LINE WITHIN PAGE */
  134.     AMBIG BYTE,                   /* SET FOR AMBIGUOUS FILE REFS */
  135.     PARSET BYTE,                  /* TRUE IF PARAMETERS PRESENT */
  136.     FEEDBASE BYTE,                /* USED TO FEED SEARCH CHARACTERS */
  137.     FEEDLEN BYTE,                 /* LENGTH OF FEED STRING */
  138.     MATCHLEN BYTE,                /* USED IN MATCHING STRINGS */
  139.     QUITLEN BYTE,                 /* USED TO TERMINATE QUIT COMMAND */
  140.     NBUF BYTE,                    /* NUM BUFFERS-1 IN SBUFF AND DBUFF */
  141.     CDISK BYTE,                   /* CURRENT DISK */
  142.     BUFFER LITERALLY 'BUFF',      /* DEFAULT BUFFER */
  143.     SEARFCB LITERALLY 'FCB',      /* SEARCH FCB IN MULTI COPY */
  144.     MEMSIZE LITERALLY 'MAXB',     /* MEMORY SIZE */
  145.     SBLEN ADDRESS,                /* SOURCE BUFFER LENGTH */
  146.     DBLEN ADDRESS,                /* DEST BUFFER LENGTH */
  147.     SBASE ADDRESS,                /* SOURCE BUFFER BASE */
  148.     /* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION
  149.     1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */
  150.     DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */
  151.     SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */
  152.     SDISK BYTE,                   /* SOURCE DISK */
  153.     (SCOM, DHEX) BYTE,            /* SOURCE IS 'COM' FILE IF TRUE */
  154.                                   /* DEST IS 'HEX' FILE IF TRUE   */
  155.     SOURCE (FSIZE) BYTE,          /* SOURCE FCB */
  156.     SFUB BYTE AT(.SOURCE(13)),    /* UNFILLED BYTES FIELD */
  157.     DEST (FRSIZE) BYTE,           /* DESTINATION FCB */
  158.     DESTR ADDRESS AT(.DEST(33)),  /* RANDOM RECORD POSITION */
  159.     DESTO BYTE    AT(.DEST(35)),  /* RANDOM OVERFLOW BYTE */
  160.     DFUB BYTE AT (.DEST(13)),     /* UNFILLED BYTES FIELD */
  161.     DDISK BYTE,                   /* DESTINATION DISK */
  162.     HBUFF(HBUFS) BYTE,            /* HEX FILE BUFFER */
  163.     HSOURCE BYTE,                 /* NEXT HEX SOURCE CHARACTER */
  164.  
  165.     NSOURCE ADDRESS,              /* NEXT SOURCE CHARACTER */
  166.     HARDEOF ADDRESS,              /* SET TO NSOURCE ON REAL EOF */
  167.     NDEST ADDRESS;                /* NEXT DESTINATION CHARACTER */
  168.  
  169. DECLARE
  170.     /* SUBMIT FILE CONTROL BLOCK FOR ERROR DELETE */
  171.     SUBFCB (*) BYTE DATA (0,'$$$     SUB',0,0,0);
  172.  
  173.   DECLARE
  174.     PDEST BYTE,                   /* DESTINATION DEVICE */
  175.     PSOURCE BYTE;                 /* CURRENT SOURCE DEVICE */
  176.  
  177.   DECLARE
  178.     MULTCOM BYTE,                 /* FALSE IF PROCESSING ONE LINE */
  179.     PUTNUM BYTE,                  /* SET WHEN READY FOR NEXT LINE NUM */
  180.     CONCNT BYTE,                   /* COUNTER FOR CONSOLE READY CHECK */
  181.     CHAR BYTE,                    /* LAST CHARACTER SCANNED */
  182.     TYPE BYTE,                    /* TYPE OF CHARACTER SCANNED */
  183.     FLEN BYTE;                    /* FILE NAME LENGTH */
  184.  
  185. MON1: PROCEDURE(F,A) EXTERNAL;
  186.     DECLARE F BYTE,
  187.     A ADDRESS;
  188.     END MON1;
  189.  
  190. MON2: PROCEDURE(F,A) BYTE EXTERNAL;
  191.     DECLARE F BYTE,
  192.     A ADDRESS;
  193.     END MON2;
  194.  
  195. MON3: PROCEDURE(F,A) ADDRESS EXTERNAL;
  196.     DECLARE F BYTE,
  197.     A ADDRESS;
  198.     END MON3;
  199.  
  200. BOOT: PROCEDURE EXTERNAL;
  201.     /* SYSTEM REBOOT */
  202.     END BOOT;
  203.  
  204. READRDR: PROCEDURE BYTE;
  205.     /* READ CURRENT READER DEVICE */
  206.     RETURN MON2(3,0);
  207.     END READRDR;
  208.  
  209. READCHAR: PROCEDURE BYTE;
  210.     /* READ CONSOLE CHARACTER */
  211.     RETURN MON2(1,0);
  212.     END READCHAR;
  213.  
  214. DECLARE
  215.     TRUE LITERALLY '1',
  216.     FALSE LITERALLY '0',
  217.     FOREVER LITERALLY 'WHILE TRUE',
  218.     CR LITERALLY '13',
  219.     LF LITERALLY '10',
  220.     WHAT LITERALLY '63';
  221.  
  222. PRINTCHAR: PROCEDURE(CHAR);
  223.     DECLARE CHAR BYTE;
  224.     CALL MON1(2,CHAR AND 7FH);
  225.     END PRINTCHAR;
  226.  
  227. CRLF: PROCEDURE;
  228.     CALL PRINTCHAR(CR);
  229.     CALL PRINTCHAR(LF);
  230.     END CRLF;
  231.  
  232. PRINT: PROCEDURE(A);
  233.     DECLARE A ADDRESS;
  234.     /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
  235.     NEXT DOLLAR SIGN IS ENCOUNTERED */
  236.     CALL CRLF;
  237.     CALL MON1(9,A);
  238.     END PRINT;
  239.  
  240. DECLARE DCNT BYTE;
  241.  
  242. VERSION: PROCEDURE ADDRESS;
  243.     RETURN MON3(12,0); /* VERSION NUMBER */
  244.     END VERSION;
  245.  
  246. INITIALIZE: PROCEDURE;
  247.     CALL MON1(13,0);
  248.     END INITIALIZE;
  249.  
  250. SELECT: PROCEDURE(D);
  251.     DECLARE D BYTE;
  252.     CALL MON1(14,D);
  253.     END SELECT;
  254.  
  255. OPEN: PROCEDURE(FCB);
  256.     DECLARE FCB ADDRESS;
  257.     DCNT = MON2(15,FCB);
  258.     END OPEN;
  259.  
  260. CLOSE: PROCEDURE(FCB);
  261.     DECLARE FCB ADDRESS;
  262.     DCNT = MON2(16,FCB);
  263.     END CLOSE;
  264.  
  265. SEARCH: PROCEDURE(FCB);
  266.     DECLARE FCB ADDRESS;
  267.     DCNT = MON2(17,FCB);
  268.     END SEARCH;
  269.  
  270. SEARCHN: PROCEDURE;
  271.     DCNT = MON2(18,0);
  272.     END SEARCHN;
  273.  
  274. DELETE: PROCEDURE(FCB);
  275.     DECLARE FCB ADDRESS;
  276.     CALL MON1(19,FCB);
  277.     END DELETE;
  278.  
  279. DISKREAD: PROCEDURE(FCB) BYTE;
  280.     DECLARE FCB ADDRESS;
  281.     RETURN MON2(20,FCB);
  282.     END DISKREAD;
  283.  
  284. DISKWRITE: PROCEDURE(FCB) BYTE;
  285.     DECLARE FCB ADDRESS;
  286.     RETURN MON2(21,FCB);
  287.     END DISKWRITE;
  288.  
  289. MAKE: PROCEDURE(FCB);
  290.     DECLARE FCB ADDRESS;
  291.     DCNT = MON2(22,FCB);
  292.     END MAKE;
  293.  
  294. RENAME: PROCEDURE(FCB);
  295.     DECLARE FCB ADDRESS;
  296.     CALL MON1(23,FCB);
  297.     END RENAME;
  298.  
  299. DECLARE
  300.     CUSER BYTE, /* CURRENT USER NUMBER */
  301.     SUSER BYTE; /* SOURCE USER NUMBER ('G' PARAMETER) */
  302.  
  303. SETIND: PROCEDURE(FCB);
  304.     DECLARE FCB ADDRESS;
  305.     CALL MON1(30,FCB);
  306.     END SETIND;
  307.  
  308. GETUSER: PROCEDURE BYTE;
  309.     RETURN MON2(32,0FFH);
  310.     END GETUSER;
  311.  
  312. SETUSER: PROCEDURE(USER);
  313.     DECLARE USER BYTE;
  314.     CALL MON1(32,USER);
  315.     END SETUSER;
  316.  
  317. SETCUSER: PROCEDURE;
  318.     CALL SETUSER(CUSER);
  319.     END SETCUSER;
  320.  
  321. SETSUSER: PROCEDURE;
  322.     CALL SETUSER(SUSER);
  323.     END SETSUSER;
  324.  
  325. READ$RANDOM: PROCEDURE(FCB) BYTE;
  326.     DECLARE FCB ADDRESS;
  327.     RETURN MON2(33,FCB);
  328.     END READ$RANDOM;
  329.  
  330. WRITE$RANDOM: PROCEDURE(FCB) BYTE;
  331.     DECLARE FCB ADDRESS;
  332.     RETURN MON2(34,FCB);
  333.     END WRITE$RANDOM;
  334.  
  335. SET$RANDOM: PROCEDURE(FCB);
  336.     DECLARE FCB ADDRESS;
  337.     /* SET RANDOM RECORD POSITION */
  338.     CALL MON1(36,FCB);
  339.     END SET$RANDOM;
  340.  
  341. DECLARE CBUFF(130) BYTE,   /* COMMAND BUFFER */
  342.     MAXLEN BYTE AT (.CBUFF(0)),  /* MAX BUFFER LENGTH */
  343.     COMLEN BYTE AT (.CBUFF(1)),  /* CURRENT LENGTH */
  344.     COMBUFF (128) BYTE AT (.CBUFF(2)); /* COMMAND BUFFER CONTENTS */
  345. DECLARE (TCBP,CBP) BYTE;   /* TEMP CBP, COMMAND BUFFER POINTER */
  346.  
  347. READCOM: PROCEDURE;
  348.     /* READ INTO COMMAND BUFFER */
  349.     MAXLEN = 128;
  350.     CALL MON1(10,.MAXLEN);
  351.     END READCOM;
  352.  
  353. DECLARE MCBP BYTE;
  354.  
  355. CONBRK: PROCEDURE BYTE;
  356.     /* CHECK CONSOLE CHARACTER READY */
  357.     RETURN MON2(11,0);
  358.     END CONBRK;
  359.  
  360. DECLARE /* CONTROL TOGGLE VECTOR */
  361.     CONT(26) BYTE,   /* ONE FOR EACH ALPHABETIC */
  362.     /* 00 01 02 03 04 05 06 07 08 09 10 11 12 13
  363.         A  B  C  D  E  F  G  H  I  J  K  L  M  N
  364.        14 15 16 17 18 19 20 21 22 23 24 25
  365.         O  P  Q  R  S  T  U  V  W  X  Y  Z   */
  366.     BLOCK  BYTE  AT(.CONT(1)),     /* BLOCK MODE TRANSFER */
  367.     DELET  BYTE  AT(.CONT(3)),     /* DELETE CHARACTERS */
  368.     ECHO   BYTE  AT(.CONT(4)),     /* ECHO CONSOLE CHARACTERS */
  369.     FORMF  BYTE  AT(.CONT(5)),     /* FORM FILTER */
  370.     GETU   BYTE  AT(.CONT(6)),     /* GET FILE, USER # */
  371.     HEXT   BYTE  AT(.CONT(7)),     /* HEX FILE TRANSFER */
  372.     IGNOR  BYTE  AT(.CONT(8)),     /* IGNORE :00 RECORD ON FILE */
  373.     LOWER  BYTE  AT(.CONT(11)),    /* TRANSLATE TO LOWER CASE */
  374.     NUMB   BYTE  AT(.CONT(13)),    /* NUMBER OUTPUT LINES */
  375.     OBJ    BYTE  AT(.CONT(14)),    /* OBJECT FILE TRANSFER */
  376.     PAGCNT BYTE  AT(.CONT(15)),    /* PAGE LENGTH */
  377.     QUITS  BYTE  AT(.CONT(16)),    /* QUIT COPY */
  378.     RSYS   BYTE  AT(.CONT(17)),    /* READ SYSTEM FILES */
  379.     STARTS BYTE  AT(.CONT(18)),    /* START COPY */
  380.     TABS   BYTE  AT(.CONT(19)),    /* TAB SET */
  381.     UPPER  BYTE  AT(.CONT(20)),    /* UPPER CASE TRANSLATE */
  382.     VERIF  BYTE  AT(.CONT(21)),    /* VERIFY EQUAL FILES ONLY */
  383.     WRROF  BYTE  AT(.CONT(22)),    /* WRITE TO R/O FILE */
  384.     ZEROP  BYTE  AT(.CONT(25));    /* ZERO PARITY ON INPUT */
  385.  
  386.   SETDMA: PROCEDURE(A);
  387.        DECLARE A ADDRESS;
  388.        CALL MON1(26,A);
  389.        END SETDMA;
  390.  
  391.   /* INTELLEC 8 INTEL/ICOM READER INPUT */
  392.  
  393. INTIN: PROCEDURE BYTE;
  394.     /* READ THE INTEL / ICOM READER */
  395.     DECLARE PTRI LITERALLY '3',  /* DATA */
  396.             PTRS LITERALLY '1',  /* STATUS */
  397.             PTRC LITERALLY '1',  /* COMMAND */
  398.             PTRG LITERALLY '0CH', /* GO */
  399.             PTRN LITERALLY '08H'; /* STOP */
  400.  
  401.     /* STROBE THE READER */
  402.     OUTPUT(PTRC) = PTRG;
  403.     OUTPUT(PTRC) = PTRN;
  404.         DO WHILE NOT ROL(INPUT(PTRS),3); /* NOT READY */
  405.         END;
  406.     /* DATA READY */
  407.     RETURN INPUT(PTRI) AND 7FH;
  408.     END INTIN;
  409.  
  410.  
  411. DECLARE ZEROSUP BYTE,  /* ZERO SUPPRESSION */
  412.     (C3,C2,C1) BYTE;     /* LINE COUNT ON PRINTER  */
  413.  
  414.   ERROR: PROCEDURE(A);
  415.     DECLARE A ADDRESS, I BYTE;
  416.     CALL SETCUSER;
  417.     CALL PRINT(A); CALL PRINTCHAR(':'); CALL PRINTCHAR(' ');
  418.         DO I = TCBP TO CBP;
  419.         IF I < COMLEN THEN CALL PRINTCHAR(COMBUFF(I));
  420.         END;
  421.     /* ZERO THE COMLEN IN CASE THIS IS A SINGLE COMMAND */
  422.     COMLEN = 0;
  423.     /* DELETE ANY $$$.SUB FILES IN CASE BATCH PROCESSING */
  424.     /* DELETE SUB FILE ONLY IF PRESENT (MAY BE R/O DISK) */
  425.     CALL SEARCH(.SUBFCB);
  426.     IF DCNT <> 255 THEN CALL DELETE(.SUBFCB);
  427.     CALL CRLF;
  428.     GO TO RETRY;
  429.     END ERROR;
  430.  
  431.   MOVE: PROCEDURE(S,D,N);
  432.     DECLARE (S,D) ADDRESS, N BYTE;
  433.     DECLARE A BASED S BYTE, B BASED D BYTE;
  434.         DO WHILE (N:=N-1) <> 255;
  435.         B = A; S = S+1; D = D+1;
  436.         END;
  437.     END MOVE;
  438.  
  439.  
  440.   FILLSOURCE: PROCEDURE;
  441.     /* FILL THE SOURCE BUFFERS */
  442.     DECLARE (I,J) BYTE;
  443.     NSOURCE = 0;
  444.     CALL SELECT(SDISK);
  445.     CALL SETSUSER; /* SOURCE USER NUMBER SET */
  446.         DO I = 0 TO NBUF;
  447.         /* SET DMA ADDRESS TO NEXT BUFFER POSIITION */
  448.         CALL SETDMA(.SBUFF(NSOURCE));
  449.         IF (J := DISKREAD(.SOURCE)) <> 0 THEN
  450.             DO; IF J <> 1 THEN
  451.                 CALL ERROR(.('DISK READ ERROR$'));
  452.             /* END - OF - FILE */
  453.             HARDEOF = NSOURCE; /* SET HARD END-OF-FILE */
  454.             SBUFF(NSOURCE) = ENDFILE; I = NBUF;
  455.             END; ELSE
  456.         NSOURCE = NSOURCE + 128;
  457.         END;
  458.     NSOURCE = 0;
  459.     CALL SETCUSER; /* BACK TO CURRENT USER NUMBER */
  460.     END FILLSOURCE;
  461.  
  462.  
  463.   WRITEDEST: PROCEDURE;
  464.     /* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION
  465.     NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */
  466.     DECLARE (I, J, N) BYTE;
  467.     DECLARE DMA ADDRESS;
  468.     DECLARE DATAOK BYTE;
  469.     IF (N := LOW(SHR(NDEST,7)) - 1) = 255 THEN RETURN ;
  470.     NDEST = 0;
  471.     CALL SELECT(DDISK);
  472.     CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */
  473.         DO I = 0 TO N;
  474.         /* SET DMA ADDRESS TO NEXT BUFFER */
  475.         DMA = .DBUFF(NDEST);
  476.         CALL SETDMA(DMA);
  477.         IF DISKWRITE(.DEST) <> 0 THEN
  478.             CALL ERROR(.('DISK WRITE ERROR$'));
  479.         NDEST = NDEST + 128;
  480.         END;
  481.     IF VERIF THEN /* VERIFY DATA WRITTEN OK */
  482.         DO;
  483.         NDEST = 0;
  484.         CALL SETDMA(.BUFF); /* FOR COMPARE */
  485.             DO I = 0 TO N;
  486.             DATAOK = READRANDOM(.DEST) = 0;
  487.             DESTR = DESTR + 1; /* NEXT RANDOM READ */
  488.             J = 0;
  489.                 /* PERFORM COMPARISON */
  490.                 DO WHILE DATAOK AND J < 80H;
  491.                 DATAOK = BUFFER(J) = DBUFF(NDEST+J);
  492.                 J = J + 1;
  493.                 END;
  494.             NDEST = NDEST + 128;
  495.             IF NOT DATAOK THEN
  496.                 CALL ERROR(.('VERIFY ERROR$'));
  497.             END;
  498.         DATAOK = DISKWRITE(.DEST);
  499.         /* NOW READY TO CONTINUE THE WRITE OPERATION */
  500.         END;
  501.     NDEST = 0;
  502.     END WRITEDEST;
  503.  
  504.   PUTDCHAR: PROCEDURE(B);
  505.     DECLARE (B,IOB) BYTE;
  506.     /* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY PDEST */
  507.     IF B >= ' ' THEN
  508.         DO; COLUMN = COLUMN + 1;
  509.         IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */
  510.             DO; IF COLUMN > DELET THEN RETURN;
  511.             END;
  512.         END;
  513.     IOB = IOBYTE; /* IN CASE IT IS ALTERED */
  514.         DO CASE PDEST;
  515.         /* CASE 0 IS THE DESTINATION FILE */
  516.             DO;
  517.             IF NDEST >= DBLEN THEN CALL WRITEDEST;
  518.             DBUFF(NDEST) = B;
  519.             NDEST = NDEST+1;
  520.             END;
  521.         /* CASE 1 IS ARD (ADDMASTER) */
  522.             GO TO NOTDEST;
  523.        /* CASE 2 IS IRD (INTEL/ICOM) */
  524.             GO TO NOTDEST;
  525.         /* CASE 3 IS PTR */
  526.             GO TO NOTDEST;
  527.         /* CASE 4 IS UR1 */
  528.             GO TO NOTDEST;
  529.         /* CASE 5 IS UR2 */
  530.             GO TO NOTDEST;
  531.         /* CASE 6 IS RDR */
  532.             NOTDEST:
  533.                 CALL ERROR(.('NOT A CHARACTER SINK$'));
  534.         /* CASE 7 IS OUT */
  535.             CALL OUT(B);
  536.         /* CASE 8 IS LPT */
  537.                 DO; IOBYTE = 1000$0000B; GO TO LSTL;
  538.                 END;
  539.         /* CASE 9 IS UL1 */
  540.                 DO; IOBYTE = 1100$0000B; GO TO LSTL;
  541.                 END;
  542.         /* CASE 10 IS PRN (TABS EXPANDED, LINES LISTED, CHANGED TO LST) */
  543.                 DO; IOBYTE = 1000$0000B; GO TO LSTL;
  544.                 END;
  545.         /* CASE 11 IS LST */
  546.             LSTL:
  547.                 CALL MON1(5,B);
  548.         /* CASE 12 IS PTP */
  549.             DO; IOBYTE = 0001$0000B; GO TO PUNL;
  550.             END;
  551.         /* CASE 13 IS UP1 */
  552.             DO; IOBYTE = 0010$0000B; GO TO PUNL;
  553.             END;
  554.         /* CASE 14 IS UP2 */
  555.             DO; IOBYTE = 0011$0000B; GO TO PUNL;
  556.             END;
  557.         /* CASE 15 IS PUN */
  558.             PUNL:
  559.                 CALL MON1(4,B);
  560.           /* CASE 16 IS TTY */
  561.               DO; IOBYTE = 0; GO TO CONL;
  562.               END;
  563.           /* CASE 17 IS CRT */
  564.               DO; IOBYTE = 1; GO TO CONL;
  565.               END;
  566.           /* CASE 18 IS UC1 */
  567.               DO; IOBYTE = 11B; GO TO CONL;
  568.               END;
  569.           /* CASE 19 IS CON */
  570.               CONL:
  571.                   CALL MON1(2,B);
  572.           END;
  573.     IOBYTE = IOB;
  574.     END PUTDCHAR;
  575.  
  576. PUTDESTC: PROCEDURE(B);
  577.     DECLARE (B,I) BYTE;
  578.     /* WRITE DESTINATION CHARACTER, TAB EXPANSION */
  579.     IF B <> TAB THEN CALL PUTDCHAR(B); ELSE
  580.     IF TABS = 0 THEN CALL PUTDCHAR(B); ELSE
  581.         /* B IS TAB CHAR, TABS > 0 */
  582.         DO; I = COLUMN;
  583.             DO WHILE I >= TABS;
  584.             I = I - TABS;
  585.             END;
  586.         I = TABS - I;
  587.             DO WHILE I > 0;
  588.             I = I - 1;
  589.             CALL PUTDCHAR(' ');
  590.             END;
  591.         END;
  592.     IF B = CR THEN COLUMN = 0;
  593.     END PUTDESTC;
  594.  
  595. PRINT1: PROCEDURE(B);
  596.     DECLARE B BYTE;
  597.     IF (ZEROSUP := ZEROSUP AND B = 0) THEN CALL PUTDESTC(' '); ELSE
  598.         CALL PUTDESTC('0'+B);
  599.     END PRINT1;
  600.  
  601. PRINTDIG: PROCEDURE(D);
  602.     DECLARE D BYTE;
  603.     CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B);
  604.     END PRINTDIG;
  605.  
  606. NEWLINE: PROCEDURE;
  607.     DECLARE ONE BYTE;
  608.     ONE = 1;
  609.     ZEROSUP = NUMB = 1;
  610.     C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0);
  611.     CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1);
  612.     IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */
  613.         DO; CALL PUTDESTC(':'); CALL PUTDESTC(' ');
  614.         END; ELSE
  615.         CALL PUTDESTC(TAB);
  616.     END NEWLINE;
  617.  
  618. CLEARBUFF: PROCEDURE;
  619.     /* CLEAR OUTPUT BUFFER IN BLOCK MODE TRANSMISION */
  620.     DECLARE NA ADDRESS;
  621.     DECLARE I BYTE;
  622.     I = LOW(NDEST) AND 7FH;  /* REMAINING PARTIAL BUFFER LENGTH */
  623.     NA = NDEST AND 0FF80H;   /* START OF SEGMENT NOT WRITTEN */
  624.     CALL WRITEDEST;          /* CLEARS BUFFERS */
  625.     CALL MOVE(.DBUFF(NA),.DBUFF,I);
  626.     /* DATA MOVED TO BEGINNING OF BUFFER */
  627.     NDEST = I;
  628.     END CLEARBUFF;
  629.  
  630. PUTDEST: PROCEDURE(B);
  631.     DECLARE (I,B) BYTE;
  632.     /* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */
  633.     IF FORMF THEN /* SKIP FORM FEEDS */
  634.         DO; IF B = FF THEN RETURN;
  635.         END;
  636.     IF PUTNUM THEN /* END OF LINE OR START OF FILE */
  637.         DO;
  638.         IF B <> FF THEN /* NOT FORM FEED */
  639.             DO;
  640.             IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */
  641.                 DO; IF I=1 THEN I=LPP;
  642.                 IF (LINENO := LINENO + 1) >= I THEN
  643.                     DO; LINENO = 0; /* NEW PAGE */
  644.                     CALL PUTDESTC(FF);
  645.                     END;
  646.                 END;
  647.             IF NUMB > 0 THEN
  648.                 CALL NEWLINE;
  649.             PUTNUM = FALSE;
  650.             END;
  651.         END;
  652.     IF BLOCK THEN /* BLOCK MODE TRANSFER */
  653.         DO;
  654.         IF B = XOFF AND PDEST = 0 THEN
  655.             DO; CALL CLEARBUFF; /* BUFFERS WRITTEN */
  656.             RETURN; /* DON'T PASS THE X-OFF */
  657.             END;
  658.         END;
  659.     IF B = FF THEN LINENO = 0;
  660.     CALL PUTDESTC(B);
  661.     IF B = LF THEN PUTNUM = TRUE;
  662.     END PUTDEST;
  663.  
  664.  
  665. UTRAN: PROCEDURE(B) BYTE;
  666.     DECLARE B BYTE;
  667.     /* TRANSLATE ALPHA TO UPPER CASE */
  668.     IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */
  669.         B = B AND 101$1111B; /* TO UPPER CASE */
  670.     RETURN B;
  671.     END UTRAN;
  672.  
  673. LTRAN: PROCEDURE(B) BYTE;
  674.     DECLARE B BYTE;
  675.     /* TRANSLATE TO LOWER CASE ALPHA */
  676.     IF B >= 'A' AND B <= 'Z' THEN B = B OR 10$0000B; /* TO LOWER */
  677.     RETURN B;
  678.     END LTRAN;
  679.  
  680. GETSOURCEC: PROCEDURE BYTE;
  681.     /* READ NEXT SOURCE CHARACTER */
  682.     DECLARE (IOB,B,CONCHK) BYTE;
  683.  
  684.     IF PSOURCE - 1 <= RDR THEN /* 1 ... RDR+1 */
  685.         DO; IF (BLOCK OR HEXT) AND CONBRK THEN
  686.             DO;
  687.             IF READCHAR = ENDFILE THEN RETURN ENDFILE;
  688.             CALL PRINT(.('READER STOPPING',CR,LF,'$'));
  689.             RETURN XOFF;
  690.             END;
  691.         END;
  692.     CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */
  693.     IOB = IOBYTE; /* SAVE IT IN CASE IT IS ALTERED */
  694.         DO CASE PSOURCE;
  695.         /* CASE 0 IS SOURCE FILE */
  696.             DO; IF NSOURCE >= SBLEN THEN CALL FILLSOURCE;
  697.             B = SBUFF(NSOURCE);
  698.             NSOURCE = NSOURCE + 1;
  699.             END;
  700.         /* CASE 1 IS INP */
  701.             B = INP;
  702.         /* CASE 2 IS IRD (INTEL/ICOM) */
  703.             B = INTIN;
  704.         /* CASE 3 IS PTR */
  705.                DO; IOBYTE = 0000$0100B; GO TO RDRL;
  706.                END;
  707.         /* CASE 4 IS UR1 */
  708.                DO; IOBYTE = 0000$1000B; GO TO RDRL;
  709.                END;
  710.         /* CASE 5 IS UR2 */
  711.                DO; IOBYTE = 0000$1100B; GO TO RDRL;
  712.                END;
  713.         /* CASE 6 IS RDR */
  714.             RDRL:
  715.                 B = MON2(3,0) AND 7FH;
  716.         /* CASE 7 IS OUT */
  717.             GO TO NOTSOURCE;
  718.         /* CASE 8 IS LPT */
  719.             GO TO NOTSOURCE;
  720.         /* CASE 9 IS UL1 */
  721.             GO TO NOTSOURCE;
  722.         /* CASE 10 IS PRN */
  723.             GO TO NOTSOURCE;
  724.         /* CASE 11 IS LST */
  725.             GO TO NOTSOURCE;
  726.         /* CASE 12 IS PTP */
  727.             GO TO NOTSOURCE;
  728.         /* CASE 13 IS UP1 */
  729.             GO TO NOTSOURCE;
  730.         /* CASE 14 IS UP2 */
  731.             GO TO NOTSOURCE;
  732.         /* CASE 15 IS PUN */
  733.             NOTSOURCE:
  734.                 DO; CALL ERROR(.('NOT A CHARACTER SOURCE$'));
  735.                 END;
  736.         /* CASE 16 IS TTY */
  737.                 DO; IOBYTE = 0; GO TO CONL;
  738.                 END;
  739.         /* CASE 17 IS CRT */
  740.                 DO; IOBYTE = 01B; GO TO CONL;
  741.                 END;
  742.         /* CASE 18 IS UC1 */
  743.                 DO; IOBYTE = 11B; GO TO CONL;
  744.                 END;
  745.         /* CASE 19 IS CON */
  746.             CONL:
  747.                 DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
  748.                 B = MON2(1,0);
  749.                 END;
  750.         END; /* OF CASES */
  751.     IOBYTE = IOB; /* RESTORE IOBYTE */
  752.     IF ECHO THEN /* COPY TO CONSOLE DEVICE */
  753.         DO; IOB = PDEST; PDEST = CONP; CALL PUTDEST(B);
  754.         PDEST = IOB;
  755.         END;
  756.     IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */
  757.         DO;
  758.         IF SCOM THEN /* SOURCE IS A COM FILE */
  759.             CONCHK = (CONCNT := CONCNT + 1) = 0; ELSE /* ASCII */
  760.             CONCHK = B = LF;
  761.         IF CONCHK THEN
  762.             DO; IF CONBRK THEN
  763.                 DO;
  764.                 IF READCHAR = ENDFILE THEN RETURN ENDFILE;
  765.                 CALL ERROR(.('ABORTED$'));
  766.                 END;
  767.             END;
  768.         END;
  769.     IF ZEROP THEN B = B AND 7FH;
  770.     IF UPPER THEN RETURN UTRAN(B);
  771.     IF LOWER THEN RETURN LTRAN(B);
  772.     RETURN B;
  773.     END GETSOURCEC;
  774.  
  775. GETSOURCE: PROCEDURE BYTE;
  776.     /* GET NEXT SOURCE CHARACTER */
  777.     DECLARE CHAR BYTE;
  778.     MATCH: PROCEDURE(B) BYTE;
  779.         /* MATCH START AND QUIT STRINGS */
  780.         DECLARE (B,C) BYTE;
  781.         IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */
  782.             DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */
  783.             RETURN TRUE;
  784.             END;
  785.         IF C = CHAR THEN MATCHLEN = MATCHLEN + 1; ELSE
  786.             MATCHLEN = 0; /* NO MATCH */
  787.         RETURN FALSE;
  788.         END MATCH;
  789.     IF QUITLEN > 0 THEN
  790.         DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF;
  791.         RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */
  792.         END;
  793.     DO FOREVER; /* LOOKING FOR START */
  794.     IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */
  795.         DO; FEEDLEN = FEEDLEN - 1;
  796.         CHAR = COMBUFF(FEEDBASE);
  797.         FEEDBASE = FEEDBASE + 1;
  798.         RETURN CHAR;
  799.         END;
  800.     IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE;
  801.     IF STARTS > 0 THEN /* LOOKING FOR START STRING */
  802.         DO; IF MATCH(STARTS) THEN
  803.             DO; FEEDBASE = STARTS; STARTS = 0;
  804.             FEEDLEN = MATCHLEN + 1;
  805.             END; /* OTHERWISE NO MATCH, SKIP CHARACTER */
  806.         END; ELSE
  807.     IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */
  808.         DO; IF MATCH(QUITS) THEN
  809.             DO; QUITS = 0; QUITLEN = 2;
  810.             /* SUBSEQUENTLY RETURN CR, LF, ENDFILE */
  811.             RETURN CR;
  812.             END;
  813.         RETURN CHAR;
  814.         END; ELSE
  815.     RETURN CHAR;
  816.     END; /* OF DO FOREVER */
  817.     END GETSOURCE;
  818.  
  819. DECLARE DISK BYTE;            /* SELECTED DISK */
  820.  
  821.   GNC: PROCEDURE BYTE;
  822.     IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR;
  823.     RETURN UTRAN(COMBUFF(CBP));
  824.     END GNC;
  825.  
  826.   DEBLANK: PROCEDURE;
  827.         DO WHILE (CHAR := GNC) = ' ';
  828.         END;
  829.     END DEBLANK;
  830.  
  831.   SCAN: PROCEDURE(FCBA);
  832.     DECLARE FCBA ADDRESS,         /* ADDRESS OF FCB TO FILL */
  833.     FCB BASED FCBA (FSIZE) BYTE;  /* FCB TEMPLATE */
  834.     DECLARE (I,J,K) BYTE; /* TEMP COUNTERS */
  835.  
  836.   /* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME.
  837.      THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */
  838.  
  839.     DELIMITER: PROCEDURE(C) BYTE;
  840.         DECLARE (I,C) BYTE;
  841.         DECLARE DEL(*) BYTE DATA
  842.         (' =.:,<>',CR,LA,LB,RB);
  843.             DO I = 0 TO LAST(DEL);
  844.             IF C = DEL(I) THEN RETURN TRUE;
  845.             END;
  846.         RETURN FALSE;
  847.         END DELIMITER;
  848.  
  849.     PUTCHAR: PROCEDURE;
  850.         FCB(FLEN:=FLEN+1) = CHAR;
  851.         IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */
  852.         END PUTCHAR;
  853.  
  854.     FILLQ: PROCEDURE(LEN);
  855.         /* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */
  856.         DECLARE LEN BYTE;
  857.         CHAR = WHAT; /* QUESTION MARK */
  858.             DO WHILE FLEN < LEN;
  859.             CALL PUTCHAR;
  860.             END;
  861.         END FILLQ;
  862.  
  863.     GETFCB: PROCEDURE(I) BYTE;
  864.         DECLARE I BYTE;
  865.         RETURN FCB(I);
  866.         END GETFCB;
  867.  
  868.     SCANPAR: PROCEDURE;
  869.         DECLARE (I,J) BYTE;
  870.         /* SCAN OPTIONAL PARAMETERS */
  871.         PARSET = TRUE;
  872.         SUSER = CUSER; /* SOURCE USER := CURRENT USER */
  873.         CHAR = GNC; /* SCAN PAST BRACKET */
  874.             DO WHILE NOT(CHAR = CR OR CHAR = RB);
  875.             IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */
  876.                 DO; IF CHAR = ' ' THEN CHAR = GNC; ELSE
  877.                 CALL ERROR(.('BAD PARAMETER$'));
  878.                 END; ELSE
  879.                 DO; /* SCAN PARAMETER VALUE */
  880.                 IF CHAR = 'S' OR CHAR = 'Q' THEN
  881.                     DO; /* START OR QUIT COMMAND */
  882.                     J = CBP + 1; /* START OF STRING */
  883.                         DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR);
  884.                         END;
  885.                      CHAR=GNC;
  886.                     END; ELSE
  887.                 IF (J := (CHAR := GNC) - '0') > 9 THEN J = 1;
  888.                 ELSE
  889.                     DO WHILE (K := (CHAR := GNC) - '0') <= 9;
  890.                     J = J * 10 + K;
  891.                     END;
  892.                 CONT(I) = J;
  893.                 IF I = 6 THEN /* SET SOURCE USER */
  894.                     DO;
  895.                     IF J > 31 THEN
  896.                         CALL ERROR(.('INVALID USER NUMBER$'));
  897.                     SUSER = J;
  898.                     END;
  899.                 END;
  900.             END;
  901.         CHAR = GNC;
  902.         END SCANPAR;
  903.  
  904.     CHKSET: PROCEDURE;
  905.         IF CHAR = LA THEN CHAR = '=';
  906.         END CHKSET;
  907.  
  908.     /* INITIALIZE FILE CONTROL BLOCK TO EMPTY */
  909.     AMBIG = FALSE; TYPE = ERR; CHAR = ' '; FLEN = 0;
  910.         DO WHILE FLEN < FSIZE-1;
  911.         IF FLEN = FNSIZE THEN CHAR = 0;
  912.         CALL PUTCHAR;
  913.         END;
  914.  
  915.     /* DEBLANK COMMAND BUFFER */
  916.         CALL DEBLANK;
  917.  
  918.     /* SAVE STARTING POSITION OF SCAN FOR DIAGNOSTICS */
  919.     TCBP = CBP;
  920.  
  921.     /* MAY BE A SEPARATOR */
  922.     IF DELIMITER(CHAR) THEN
  923.         DO; CALL CHKSET;
  924.         TYPE = SPECL; RETURN;
  925.         END;
  926.  
  927.     /* CHECK PERIPHERALS AND DISK FILES */
  928.     DISK = 0;
  929.     /* CLEAR PARAMETERS */
  930.         DO I = 0 TO 25; CONT(I) = 0;
  931.         END;
  932.     PARSET = FALSE;
  933.     FEEDLEN,MATCHLEN,QUITLEN = 0;
  934.     /* SCAN NEXT NAME */
  935.         DO FOREVER;
  936.         FLEN = 0;
  937.             DO WHILE NOT DELIMITER(CHAR);
  938.             IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */
  939.                 RETURN;
  940.             IF CHAR = '*' THEN CALL FILLQ(NSIZE); ELSE CALL PUTCHAR;
  941.             CHAR = GNC;
  942.             END;
  943.  
  944.         /* CHECK FOR DISK NAME OR DEVICE NAME */
  945.         IF CHAR = ':' THEN
  946.             DO; IF DISK <> 0 THEN RETURN; /* ALREADY SET */
  947.             IF FLEN = 1 THEN
  948.                 /* MAY BE DISK NAME A ... Z */
  949.                 DO;
  950.                 IF (DISK := GETFCB(1) - 'A' + 1) > 26 THEN
  951.                 /* ERROR, INVALID DISK NAME */ RETURN;
  952.                 CALL DEBLANK; /* MAY BE DISK NAME ONLY */
  953.                 IF DELIMITER(CHAR) THEN
  954.                     DO; IF CHAR = LB THEN
  955.                         CALL SCANPAR;
  956.                     CBP = CBP - 1;
  957.                     TYPE = DISKNAME;
  958.                     RETURN;
  959.                     END;
  960.                 END; ELSE
  961.  
  962.             /* MAY BE A THREE CHARACTER DEVICE NAME */
  963.             IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */
  964.                 RETURN; ELSE
  965.  
  966.                 /* LOOK FOR DEVICE NAME */
  967.                 DO; DECLARE (I,J,K) BYTE, M LITERALLY '20',
  968.                 IO(*) BYTE DATA
  969.                 ('INPIRDPTRUR1UR2RDROUTLPTUL1PRNLST',
  970.                  'PTPUP1UP2PUNTTYCRTUC1CONNULEOF',0);
  971.                 /* NOTE THAT ALL READER-LIKE DEVICES MUST BE
  972.                 PLACED BEFORE 'RDR', AND ALL LISTING-LIKE DEVICES
  973.                 MUST APPEAR BELOW LST, BUT ABOVE RDR.  THE LITERAL
  974.                 DECLARATIONS FOR RDR, LST, AND PUNP MUST INDICATE
  975.                 THE POSITIONS OF THESE DEVICES IN THE LIST */
  976.                 J = 255;
  977.                     DO K = 0 TO M;
  978.                     I = 0;
  979.                         DO WHILE ((I:=I+1) <= 3) AND
  980.                         IO(J+I) = GETFCB(I);
  981.                         END;
  982.                     IF I = 4 THEN /* COMPLETE MATCH */
  983.                         DO; TYPE = PERIPH;
  984.                         /* SCAN PARAMETERS */
  985.                         IF GNC = LB THEN CALL SCANPAR;
  986.                         CBP = CBP - 1; CHAR = K;
  987.                         RETURN;
  988.                         END;
  989.                     /* OTHERWISE TRY NEXT DEVICE */ J = J + 3;
  990.                     END;
  991.  
  992.                 /* ERROR, NO DEVICE NAME MATCH */ RETURN;
  993.                 END;
  994.             IF CHAR = LB THEN /* PARAMETERS FOLLOW */
  995.                 CALL SCANPAR;
  996.             END; ELSE
  997.  
  998.         /* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */
  999.             DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */
  1000.                 RETURN;
  1001.             FLEN = FNAM;
  1002.             IF CHAR = '.' THEN /* SCAN FILE TYPE */
  1003.                 DO WHILE NOT DELIMITER(CHAR := GNC);
  1004.                 IF FLEN >= FNSIZE THEN
  1005.                 /* ERROR, TYPE FIELD TOO LONG */ RETURN;
  1006.                 IF CHAR = '*' THEN CALL FILLQ(FNSIZE);
  1007.                     ELSE CALL PUTCHAR;
  1008.                 END;
  1009.  
  1010.             IF CHAR = LB THEN
  1011.                 CALL SCANPAR;
  1012.             /* RESCAN DELIMITER NEXT TIME AROUND */
  1013.             CBP = CBP - 1;
  1014.             TYPE = FILE;
  1015.             /* DISK IS THE SELECTED DISK (1 2 3 ... ) */
  1016.             IF DISK = 0 THEN DISK = CDISK + 1; /* DEFAULT */
  1017.             FCB(0),FCB(32) = 0;
  1018.             RETURN;
  1019.             END;
  1020.         END;
  1021.     END SCAN;
  1022.  
  1023.   NULLS: PROCEDURE;
  1024.     /* SEND 40 NULLS TO OUTPUT DEVICE */
  1025.     DECLARE I BYTE;
  1026.         DO I = 0 TO 39; CALL PUTDEST(0);
  1027.         END;
  1028.     END NULLS;
  1029.  
  1030.  
  1031.   DECLARE FEXTH(FEXTL) BYTE,      /* HOLDS DESTINATION FILE TYPE */
  1032.     COPYING BYTE;                 /* TRUE WHILE COPYING TO DEST FILE */
  1033.  
  1034.   MOVEXT: PROCEDURE(A);
  1035.     DECLARE A ADDRESS;
  1036.     /* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
  1037.     CALL MOVE(A,.DEST(FEXT),FEXTL);
  1038.     END MOVEXT;
  1039.  
  1040. EQUAL: PROCEDURE(A,B) BYTE;
  1041.     /* COMPARE THE STRINGS AT A AND B UNTIL EITHER A MISMATCH OR
  1042.     A '$' IS ENCOUNTERED IN STRING B */
  1043.     DECLARE (A,B) ADDRESS,
  1044.     (SA BASED A, SB BASED B) BYTE;
  1045.         DO WHILE SB <> '$';
  1046.         IF (SB AND 7FH) <> (SA AND 7FH) THEN RETURN FALSE;
  1047.         A = A + 1; B = B + 1;
  1048.         END;
  1049.     RETURN TRUE;
  1050.     END EQUAL;
  1051.  
  1052. READ$EOF: PROCEDURE BYTE;
  1053.     /* RETURN TRUE IF END OF FILE */
  1054.     CHAR = GETSOURCE;
  1055.    IF SCOM THEN RETURN HARDEOF < NSOURCE;
  1056.     RETURN CHAR = ENDFILE;
  1057.     END READ$EOF;
  1058.  
  1059.  
  1060. HEXRECORD: PROCEDURE BYTE;
  1061.     /* READ ONE RECORD INTO SBUFF AND CHECK FOR PROPER FORM
  1062.         RETURNS 0 IF RECORD OK
  1063.         RETURNS 1 IF END OF TAPE (:00000)
  1064.         RETURNS 2 IF ERROR IN RECORD       */
  1065.  
  1066.  
  1067.     DECLARE XOFFSET BYTE; /* TRUE IF XOFF RECVD */
  1068.     DECLARE NOERRS BYTE; /* TRUE IF NO ERRORS IN THIS RECORD */
  1069.  
  1070.     PRINTERR: PROCEDURE(A);
  1071.         /* PRINT ERROR MESSAGE IF NOERRS TRUE */
  1072.         DECLARE A ADDRESS;
  1073.         IF NOERRS THEN
  1074.             DO; NOERRS = FALSE;
  1075.             CALL PRINT(A);
  1076.             END;
  1077.         END PRINTERR;
  1078.  
  1079.     CHECKXOFF: PROCEDURE;
  1080.         IF XOFFSET THEN
  1081.             DO; XOFFSET = FALSE;
  1082.             CALL CLEARBUFF;
  1083.             END;
  1084.         END CHECKXOFF;
  1085.  
  1086.     SAVECHAR: PROCEDURE BYTE;
  1087.         /* READ CHARACTER AND SAVE IN BUFFER */
  1088.         DECLARE I BYTE;
  1089.         IF NOERRS THEN
  1090.             DO;
  1091.                 DO WHILE (I := GETSOURCE) = XOFF; XOFFSET = TRUE;
  1092.                 END;
  1093.             HBUFF(HSOURCE) = I;
  1094.             IF (HSOURCE := HSOURCE + 1) >= LAST(HBUFF) THEN
  1095.                 CALL PRINTERR(.('RECORD TOO LONG$'));
  1096.             RETURN I;
  1097.             END;
  1098.         RETURN ENDFILE; /* ON ERROR FLAG */
  1099.         END SAVECHAR;
  1100.  
  1101.     DECLARE (M, RL, CS, RT) BYTE,
  1102.         LDA ADDRESS;  /* LOAD ADDRESS WHICH FOLLOWS : */
  1103.  
  1104.    READHEX: PROCEDURE BYTE;
  1105.         DECLARE H BYTE;
  1106.         IF (H := SAVECHAR) - '0' <= 9 THEN RETURN H-'0';
  1107.         IF H - 'A' > 5 THEN
  1108.             CALL PRINTERR(.('INVALID DIGIT$'));
  1109.         RETURN H - 'A' + 10;
  1110.         END READHEX;
  1111.  
  1112.     READBYTE: PROCEDURE BYTE;
  1113.         /* READ TWO HEX DIGITS */
  1114.         RETURN SHL(READHEX,4) OR READHEX;
  1115.         END READBYTE;
  1116.  
  1117.     READCS: PROCEDURE BYTE;
  1118.         /* READ BYTE WITH CHECKSUM */
  1119.         RETURN CS := CS + READBYTE;
  1120.         END READCS;
  1121.  
  1122.     READADDR: PROCEDURE ADDRESS;
  1123.         /* READ DOUBLE BYTE WITH CHECKSUM */
  1124.         RETURN SHL(DOUBLE(READCS),8) OR READCS;
  1125.         END READADDR;
  1126.  
  1127.     NOERRS = TRUE; /* NO ERRORS DETECTED IN THIS RECORD */
  1128.  
  1129.     /* READ NEXT RECORD */
  1130.         /* SCAN FOR THE ':' */
  1131.         HSOURCE = 0;
  1132.             DO WHILE (CS := SAVECHAR) <> ':';
  1133.             HSOURCE = 0;
  1134.             IF CS = ENDFILE THEN
  1135.                 DO; CALL PRINT(.('END OF FILE, CTL-Z',WHAT,'$'));
  1136.                 IF READCHAR = ENDFILE THEN RETURN 1;
  1137.                     ELSE HSOURCE = 0;
  1138.                 END;
  1139.             CALL CHECKXOFF;
  1140.             END;
  1141.  
  1142.         /* ':' FOUND */
  1143.         CS = 0;
  1144.         IF (RL := READCS) = 0 THEN /* END OF TAPE */
  1145.             DO; DO WHILE (RL := SAVECHAR) <> ENDFILE;
  1146.                 CALL CHECKXOFF;
  1147.                 END;
  1148.             IF NOERRS THEN RETURN 1;
  1149.             RETURN 2;
  1150.             END;
  1151.  
  1152.     /* RECORD LENGTH IS NOT ZERO */
  1153.         LDA = READADDR; /* LOAD ADDRESS */
  1154.  
  1155.     /* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */
  1156.         RT = READCS; /* RECORD TYPE */
  1157.            DO WHILE RL <> 0 AND NOERRS; RL = RL - 1;
  1158.            M = READCS;
  1159.           /* INCREMENT LA HERE FOR EXACT ADDRESS */
  1160.            END;
  1161.  
  1162.     /* CHECK SUM */
  1163.         IF CS + READBYTE <> 0 THEN
  1164.             CALL PRINTERR(.('CHECKSUM ERROR$'));
  1165.  
  1166.     CALL CHECKXOFF;
  1167.     IF NOERRS THEN RETURN 0;
  1168.     RETURN 2;
  1169.     END HEXRECORD;
  1170.  
  1171. READTAPE: PROCEDURE;
  1172.     /* READ HEX FILE FROM HIGH SPEED READER TO 'HEX' FILE,
  1173.     CHECK EACH RECORD FOR VALID DIGITS, AND PROPER CHECKSUM */
  1174.     DECLARE (I,A) BYTE;
  1175.         DO FOREVER;
  1176.             DO WHILE (I := HEXRECORD) <= 1;
  1177.             IF NOT (I = 1 AND IGNOR) THEN
  1178.                 DO A = 1 TO HSOURCE;
  1179.                 CALL PUTDEST(HBUFF(A-1));
  1180.                 END;
  1181.             CALL PUTDEST(CR); CALL PUTDEST(LF);
  1182.             IF I = 1 THEN /* END OF TAPE ENCOUNTERED */
  1183.                 RETURN;
  1184.             END;
  1185.         CALL CRLF; HBUFF(HSOURCE) = '$';
  1186.         CALL PRINT(.HBUFF);
  1187.         CALL PRINT(.('CORRECT ERROR, TYPE RETURN OR CTL-Z$'));
  1188.         CALL CRLF;
  1189.         IF READCHAR = ENDFILE THEN RETURN;
  1190.         END;
  1191.     END READTAPE;
  1192.  
  1193. FORMERR: PROCEDURE;
  1194.     CALL ERROR(.('INVALID FORMAT$'));
  1195.     END FORMERR;
  1196.  
  1197. SETUPDEST: PROCEDURE;
  1198.     CALL SELECT(DDISK);
  1199.     DHEX = EQUAL(.DEST(FEXT),.('HEX$'));
  1200.     CALL MOVE(.DEST(FEXT),.FEXTH,FEXTL); /* SAVE TYPE */
  1201.     DEST(ROFILE) = DEST(ROFILE) AND 7FH;
  1202.     DEST(SYSFILE)= DEST(SYSFILE)AND 7FH;
  1203.     CALL MOVEXT(.('$$$'));
  1204.     CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */
  1205.     CALL MAKE(.DEST); /* CREATE A NEW ONE */
  1206.     IF DCNT = 255 THEN CALL ERROR(.('NO DIRECTORY SPACE$'));
  1207.     DEST(32),NDEST = 0;
  1208.     END SETUPDEST;
  1209.  
  1210. SETUPSOURCE: PROCEDURE;
  1211.     HARDEOF = 0FFFFH;
  1212.     CALL SETSUSER; /* SOURCE USER */
  1213.     CALL SELECT(SDISK);
  1214.     CALL OPEN(.SOURCE);
  1215.     CALL SETCUSER; /* BACK TO CURRENT USER */
  1216.     IF (NOT RSYS) AND ROL(SOURCE(SYSFILE),1) THEN
  1217.         DCNT = 255;
  1218.     IF DCNT = 255 THEN CALL ERROR(.('NO FILE$'));
  1219.     SOURCE(32) = 0;
  1220.     /* CAUSE IMMEDIATE READ */
  1221.     SCOM = EQUAL(.SOURCE(FEXT),.('COM$'));
  1222.     NSOURCE = SBLEN;
  1223.     END SETUPSOURCE;
  1224.  
  1225. CHECK$STRINGS: PROCEDURE;
  1226.     IF STARTS > 0 THEN
  1227.         CALL ERROR(.('START NOT FOUND$'));
  1228.     IF QUITS  > 0 THEN
  1229.         CALL ERROR(.('QUIT NOT FOUND$'));
  1230.     END CHECK$STRINGS;
  1231.  
  1232. CLOSEDEST: PROCEDURE(DIRECT);
  1233.     DECLARE DIRECT BYTE;
  1234.     /* DIRECT IS TRUE IF SECTOR-BY-SECTOR COPY */
  1235.     IF DIRECT THEN
  1236.         /* GET UNFILLED BYTES FROM SOURCE BUFFER */
  1237.         DFUB = SFUB; ELSE DFUB = 0;
  1238.         DO WHILE (LOW(NDEST) AND 7FH) <> 0;
  1239.         DFUB = DFUB + 1;
  1240.         CALL PUTDEST(ENDFILE);
  1241.         END;
  1242.     CALL CHECK$STRINGS;
  1243.     CALL WRITEDEST;
  1244.     CALL SELECT(DDISK);
  1245.     CALL CLOSE(.DEST);
  1246.     IF DCNT = 255 THEN
  1247.         CALL ERROR(.('CANNOT CLOSE DESTINATION FILE$'));
  1248.     CALL MOVEXT(.FEXTH); /* RECALL ORIGINAL TYPTE */
  1249.   DEST(12) = 0;
  1250.     CALL OPEN(.DEST);
  1251.     IF DCNT <> 255 THEN /* FILE EXISTS */
  1252.         DO;
  1253.         IF ROL(DEST(ROFILE),1) THEN /* READ ONLY */
  1254.             DO;
  1255.             IF NOT WRROF THEN
  1256.                 DO;
  1257.                 CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)?$'));
  1258.                 IF UTRAN(READCHAR) <> 'Y' THEN
  1259.                     DO; CALL PRINT(.('**NOT DELETED**$'));
  1260.                     CALL CRLF;
  1261.                     CALL MOVEXT(.('$$$'));
  1262.                     CALL DELETE(.DEST);
  1263.                     RETURN;
  1264.                     END;
  1265.                 CALL CRLF;
  1266.                 END;
  1267.             DEST(ROFILE) = DEST(ROFILE) AND 7FH;
  1268.             CALL SETIND(.DEST);
  1269.             END;
  1270.         CALL DELETE(.DEST);
  1271.         END;
  1272.     CALL MOVE(.DEST,.DEST(16),16); /* READY FOR RENAME */
  1273.     CALL MOVEXT(.('$$$'));
  1274.     CALL RENAME(.DEST);
  1275.     END CLOSEDEST;
  1276.  
  1277. SIZE$NBUF: PROCEDURE;
  1278.     /* COMPUTE NUMBER OF BUFFERS - 1 FROM DBLEN */
  1279.     NBUF = (SHR(DBLEN,7) AND 0FFH) - 1;
  1280.     /* COMPUTED AS DBLEN/128-1, WHERE DBLEN <= 32K (AND THUS
  1281.     NBUF RESULTS IN A VALUE <= 2**15/2**7-1 = 2**8-1 = 255) */
  1282.     END SIZE$NBUF;
  1283.  
  1284. SET$DBLEN: PROCEDURE;
  1285.     /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
  1286.     SBASE = .MEMORY;
  1287.     IF DBLEN >= 4000H THEN DBLEN = 7F80H; ELSE
  1288.        DBLEN = DBLEN + SBLEN;
  1289.     CALL SIZE$NBUF;
  1290.     END SET$DBLEN;
  1291.  
  1292. SIZE$MEMORY: PROCEDURE;
  1293.     /* SET UP SOURCE AND DESTINATION BUFFERS */
  1294.     SBASE = .MEMORY + SHR(MEMSIZE - .MEMORY,1);
  1295.     SBLEN, DBLEN = SHR((MEMSIZE - .MEMORY) AND 0FF00H,1);
  1296.     CALL SIZE$NBUF;
  1297.     END SIZE$MEMORY;
  1298.  
  1299. COPYCHAR: PROCEDURE;
  1300.     /* PERFORM THE ACTUAL COPY FUNCTION */
  1301.     DECLARE RESIZED BYTE; /* TRUE IF SBUFF AND DBUFF COMBINED */
  1302.     IF (RESIZED := (BLOCK AND PSOURCE <> 0)) THEN /* BLOCK MODE */
  1303.         CALL SET$DBLEN; /* ABSORB SOURCE BUFFER */
  1304.     IF HEXT OR IGNOR THEN /* HEX FILE */
  1305.         CALL READTAPE; ELSE
  1306.         DO WHILE NOT READ$EOF;
  1307.         CALL PUTDEST(CHAR);
  1308.         END;
  1309.     IF RESIZED THEN
  1310.         DO; CALL CLEARBUFF;
  1311.         CALL SIZE$MEMORY;
  1312.         END;
  1313.     END COPYCHAR;
  1314.  
  1315. SIMPLECOPY: PROCEDURE;
  1316.     DECLARE (FASTCOPY,I) BYTE;
  1317.     REAL$EOF: PROCEDURE BYTE;
  1318.         RETURN HARDEOF <> 0FFFFH;
  1319.         END REALEOF;
  1320.     CALL SIZE$MEMORY;
  1321.     TCBP = MCBP; /* FOR ERROR TRACING */
  1322.     CALL SETUPDEST;
  1323.     CALL SETUPSOURCE;
  1324.     /* FILES READY FOR DIRECT COPY */
  1325.     FASTCOPY = TRUE;
  1326.         /* LOOK FOR PARAMETERS */
  1327.         DO I = 0 TO 25;
  1328.         IF CONT(I) <> 0 THEN
  1329.             DO;
  1330.             IF NOT(I=6 OR I=14 OR I=17 OR I=21 OR I=22) THEN
  1331.             /* NOT OBJ OR VERIFY */
  1332.             FASTCOPY = FALSE;
  1333.             END;
  1334.         END;
  1335.     IF FASTCOPY THEN /* COPY DIRECTLY TO DBUFF */
  1336.         DO; CALL SET$DBLEN; /* EXTEND DBUFF */
  1337.             DO WHILE NOT REAL$EOF;
  1338.             CALL FILLSOURCE;
  1339.             IF REAL$EOF THEN
  1340.                 NDEST = HARDEOF; ELSE NDEST = DBLEN;
  1341.             CALL WRITEDEST;
  1342.             END;
  1343.         CALL SIZE$MEMORY; /* RESET TO TWO BUFFERS */
  1344.         END; ELSE
  1345.     CALL COPYCHAR;
  1346.     CALL CLOSEDEST(FASTCOPY);
  1347.     END SIMPLECOPY;
  1348.  
  1349. MULTCOPY: PROCEDURE;
  1350.     DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS;
  1351.     PRNAME: PROCEDURE;
  1352.         /* PRINT CURRENT FILE NAME */
  1353.         DECLARE (I,C) BYTE;
  1354.         CALL CRLF;
  1355.             DO I = 1 TO FNSIZE;
  1356.             IF (C := DEST(I)) <> ' ' THEN
  1357.                   DO; IF I = FEXT THEN CALL PRINTCHAR('.');
  1358.                   CALL PRINTCHAR(C);
  1359.                   END;
  1360.             END;
  1361.         END PRNAME;
  1362.  
  1363.     NEXTDIR,NCOPIED = 0;
  1364.         DO FOREVER;
  1365.         /* FIND A MATCHING ENTRY */
  1366.         CALL SETSUSER; /* SOURCE USER */
  1367.         CALL SELECT(SDISK);
  1368.         CALL SETDMA(.BUFFER);
  1369.         CALL SEARCH(.SEARFCB);
  1370.         NDCNT = 0;
  1371.             DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR;
  1372.             NDCNT = NDCNT + 1;
  1373.             CALL SEARCHN;
  1374.             END;
  1375.         CALL SETCUSER;
  1376.         /* FILE CONTROL BLOCK IN BUFFER */
  1377.         IF DCNT = 255 THEN
  1378.             DO; IF NCOPIED = 0 THEN
  1379.             CALL ERROR(.('NOT FOUND$')); CALL CRLF;
  1380.             RETURN;
  1381.             END;
  1382.         NEXTDIR = NDCNT + 1;
  1383.         /* GET THE FILE CONTROL BLOCK NAME TO DEST */
  1384.         CALL MOVE(.BUFFER+SHL(DCNT AND 11B,5),.DEST,16);
  1385.     DEST(0) = 0;
  1386.     DEST(12) = 0;
  1387.         CALL MOVE(.DEST,.SOURCE,16); /* FILL BOTH FCB'S */
  1388.         IF RSYS OR NOT ROL(DEST(SYSFILE),1) THEN /* OK TO READ */
  1389.             DO;
  1390.             IF (NCOPIED := NCOPIED + 1) = 1 THEN
  1391.             CALL PRINT(.('COPYING -$'));
  1392.             CALL PRNAME;
  1393.             CALL SIMPLECOPY;
  1394.             END;
  1395.         END;
  1396.     END MULTCOPY;
  1397.  
  1398. SET$SDISK: PROCEDURE;
  1399.     IF DISK > 0 THEN SDISK = DISK - 1; ELSE SDISK = CDISK;
  1400.     END SET$SDISK;
  1401.  
  1402. SET$DDISK: PROCEDURE;
  1403.     IF PARSET THEN /* PARAMETERS PRESENT */ CALL FORMERR;
  1404.     IF DISK > 0 THEN DDISK = DISK - 1; ELSE DDISK = CDISK;
  1405.     END SET$DDISK;
  1406.  
  1407. CHECK$DISK: PROCEDURE;
  1408.     IF SUSER <> CUSER THEN /* DIFFERENT DISKS */
  1409.         RETURN;
  1410.     IF DDISK = SDISK THEN CALL FORMERR;
  1411.     END CHECK$DISK;
  1412.  
  1413. CHECK$EOL: PROCEDURE;
  1414.     CALL DEBLANK;
  1415.     IF CHAR <> CR THEN CALL FORMERR;
  1416.     END CHECK$EOL;
  1417.  
  1418. SCANDEST: PROCEDURE(COPYFCB);
  1419.     DECLARE COPYFCB ADDRESS;
  1420.     CALL SET$SDISK;
  1421.     CALL CHECK$EOL;
  1422.     CALL MOVE(.SOURCE,COPYFCB,33);
  1423.     CALL CHECK$DISK;
  1424.     END SCANDEST;
  1425.  
  1426. SCANEQL: PROCEDURE;
  1427.     CALL SCAN(.SOURCE);
  1428.     IF NOT (TYPE = SPECL AND CHAR = '=') THEN CALL FORMERR;
  1429.     MCBP = CBP; /* FOR ERROR PRINTING */
  1430.     END SCANEQL;
  1431.  
  1432.  
  1433. PIPENTRY:
  1434.   /* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED
  1435.   FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */
  1436.   CALL MOVE(.BUFF,.COMLEN,80H);
  1437.   MULTCOM = COMLEN = 0;
  1438.  
  1439.   /* GET CURRENT CP/M VERSION */
  1440.   IF VERSION < CPMVERSION THEN
  1441.      DO;
  1442.      CALL PRINT(.('REQUIRES CP/M 2.0 OR NEWER FOR OPERATION.$'));
  1443.      CALL BOOT;
  1444.      END;
  1445.   /* GET CURRENT USER */
  1446.   CUSER = GETUSER;
  1447.   /* GET CURRENT DISK */
  1448.   CDISK = MON2(25,0);
  1449.  
  1450.   RETRY:
  1451.   /* ENTER HERE ON ERROR EXIT FROM THE PROCEDURE 'ERROR' */
  1452.     CALL SIZE$MEMORY;
  1453.     /* MAIN PROCESSING LOOP.  PROCESS UNTIL CR ONLY */
  1454.     DO FOREVER;
  1455.     SUSER = CUSER;
  1456.     C1, C2, C3 = 0; /* LINE COUNT = 000000 */
  1457.     PUTNUM = TRUE; /* ACTS LIKE LF OCCURRED ON ASCII FILE */
  1458.     CONCNT,COLUMN = 0; /* PRINTER TABS */
  1459.     LINENO = 254; /* INCREMENTED TO 255 > PAGCNT */
  1460.     /* READ FROM CONSOLE IF NOT A ONELINER */
  1461.     IF MULTCOM THEN
  1462.         DO; CALL PRINTCHAR('*'); CALL READCOM;
  1463.         CALL CRLF;
  1464.         END;
  1465.     CBP = 255;
  1466.     IF COMLEN = 0 THEN /* SINGLE CARRIAGE RETURN */
  1467.         DO; CALL SELECT(CDISK);
  1468.         CALL BOOT;
  1469.         END;
  1470.  
  1471.   /* LOOK FOR SPECIAL CASES FIRST */
  1472.   DDISK,SDISK,PSOURCE,PDEST = 0;
  1473.     CALL SCAN(.DEST);
  1474.     IF TYPE = PERIPH THEN GO TO SIMPLECOM;
  1475.     IF TYPE = DISKNAME THEN
  1476.         DO; DDISK = DISK - 1;
  1477.         CALL SCANEQL;
  1478.         CALL SCAN(.SOURCE);
  1479.         /* MAY BE MULTI COPY */
  1480.         IF TYPE <> FILE THEN CALL FORMERR;
  1481.         IF AMBIG THEN
  1482.             DO; CALL SCANDEST(.SEARFCB);
  1483.             CALL MULTCOPY;
  1484.             END; ELSE
  1485.             DO; CALL SCANDEST(.DEST);
  1486.             /* FORM IS A:=B:UFN */
  1487.             CALL SIMPLECOPY;
  1488.             END;
  1489.         GO TO ENDCOM;
  1490.         END;
  1491.  
  1492.  
  1493.   IF TYPE <> FILE OR AMBIG THEN CALL FORMERR;
  1494.     CALL SET$DDISK;
  1495.     CALL SCANEQL;
  1496.     CALL SCAN(.SOURCE);
  1497.     IF TYPE = DISKNAME THEN
  1498.         DO;
  1499.         CALL SET$SDISK; CALL CHECK$DISK;
  1500.         CALL MOVE(.DEST,.SOURCE,33);
  1501.         CALL CHECK$EOL;
  1502.         CALL SIMPLECOPY;
  1503.         GO TO ENDCOM;
  1504.         END;
  1505.     /* MAY BE POSSIBLE TO DO A FAST DISK COPY */
  1506.     IF TYPE = FILE THEN /* FILE TO FILE */
  1507.         DO; CALL DEBLANK; IF CHAR <> CR THEN GO TO SIMPLECOM;
  1508.         /* FILE TO FILE */
  1509.         CALL SET$SDISK;
  1510.         CALL SIMPLECOPY;
  1511.         GO TO ENDCOM;
  1512.         END;
  1513.  
  1514. SIMPLECOM:
  1515.     CBP = 255; /* READY FOR RESCAN */
  1516.  
  1517.     /* OTHERWISE PROCESS SIMPLE REQUEST */
  1518.     CALL SCAN(.DEST);
  1519.     IF (TYPE < FILE) OR AMBIG THEN /* DELIMITER OR ERROR */
  1520.         CALL ERROR(.('UNRECOGNIZED DESTINATION$'));
  1521.  
  1522.     DHEX = FALSE;
  1523.     IF TYPE = FILE THEN
  1524.         DO; /* DESTINATION IS A FILE, SAVE EXTENT NAME */
  1525.         CALL SET$DDISK;
  1526.         CALL SETUPDEST;
  1527.         CHAR = 255;
  1528.         END; ELSE
  1529.     /* PERIPHERAL NAME */
  1530.     IF CHAR >= NULP OR CHAR <= RDR THEN CALL ERROR(.('CANNOT WRITE$'));
  1531.  
  1532.     IF (PDEST := CHAR + 1) = PUNP THEN CALL NULLS;
  1533.  
  1534.     /* NOW SCAN THE DELIMITER */
  1535.     CALL SCAN(.SOURCE);
  1536.     IF TYPE <> SPECL OR CHAR <> '=' THEN
  1537.         CALL ERROR(.('INVALID PIP FORMAT$'));
  1538.  
  1539.     /* OTHERWISE SCAN AND COPY UNTIL CR */
  1540.     COPYING = TRUE;
  1541.         DO WHILE COPYING;
  1542.         SUSER = CUSER;
  1543.         CALL SCAN(.SOURCE);
  1544.         /* SUSER MAY HAVE BEEN RESET */
  1545.         SCOM = FALSE;
  1546.         IF TYPE = FILE AND NOT AMBIG THEN /* A SOURCE FILE */
  1547.             DO;
  1548.             CALL SET$SDISK;
  1549.             CALL SETUPSOURCE;
  1550.             CHAR = 255;
  1551.             END; ELSE
  1552.  
  1553.         IF TYPE <> PERIPH OR (CHAR <= LST AND CHAR > RDR) THEN
  1554.             CALL ERROR(.('CANNOT READ$'));
  1555.  
  1556.  
  1557.       SCOM = SCOM OR OBJ; /* MAY BE ABSOLUTE COPY */
  1558.       PSOURCE = CHAR + 1;
  1559.       IF CHAR = NULP THEN CALL NULLS; ELSE
  1560.       IF CHAR = EOFP THEN CALL PUTDEST(ENDFILE); ELSE
  1561.           DO; /* DISK COPY */
  1562.           IF (CHAR < HSRDR AND DHEX) THEN HEXT = 1;
  1563.           /* HEX FILE SET IF SOURCE IS RDR AND DEST IS HEX FILE */
  1564.           IF PDEST = PRNT THEN
  1565.               DO; NUMB = 1;
  1566.               IF TABS = 0 THEN TABS = 8;
  1567.               IF PAGCNT = 0 THEN PAGCNT = 1;
  1568.               END;
  1569.           CALL COPYCHAR;
  1570.           END;
  1571.  
  1572.         CALL CHECK$STRINGS;
  1573.         /* READ ENDFILE, GO TO NEXT SOURCE */
  1574.         CALL SCAN(.SOURCE);
  1575.         IF TYPE <> SPECL OR (CHAR <> ',' AND CHAR <> CR) THEN
  1576.             CALL ERROR(.('INVALID SEPARATOR$'));
  1577.  
  1578.         COPYING = CHAR <> CR;
  1579.         END;
  1580.  
  1581.     /* IF NECESSARY, CLOSE FILE OR PUNCH TRAILER */
  1582.     IF PDEST = PUNP THEN
  1583.         DO; CALL PUTDEST(ENDFILE); CALL NULLS;
  1584.         END;
  1585.     IF PDEST = 0 THEN /* FILE HAS TO BE CLOSED AND RENAMED */
  1586.         CALL CLOSEDEST(FALSE);
  1587.  
  1588.     /* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */
  1589. ENDCOM:
  1590.     COMLEN = MULTCOM;
  1591.  
  1592.     END; /* DO FOREVER */
  1593. END;
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!