mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-24 17:04:19 +00:00
1812 lines
54 KiB
Plaintext
1812 lines
54 KiB
Plaintext
PIPMOD:
|
||
DO;
|
||
/* P E R I P H E R A L I N T E R C H A N G E P R O G R A M
|
||
|
||
COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981
|
||
DIGITAL RESEARCH
|
||
BOX 579
|
||
PACIFIC GROVE, CA
|
||
93950
|
||
|
||
Revised:
|
||
17 Jan 80 by Thomas Rolander
|
||
14 Sept 81 by Ray Pedrizetti
|
||
|
||
*/
|
||
|
||
DECLARE
|
||
VERSION LITERALLY '0130H'; /* REQUIRED FOR OPERATION */
|
||
|
||
DECLARE
|
||
MAXB ADDRESS EXTERNAL, /* ADDR FIELD OF JMP BDOS */
|
||
FCB (33) BYTE EXTERNAL, /* DEFAULT FILE CONTROL BLOCK */
|
||
BUFF(128)BYTE EXTERNAL; /* DEFAULT BUFFER */
|
||
|
||
DECLARE
|
||
ENDFILE LITERALLY '1AH', /* END OF FILE MARK */
|
||
JMP LITERALLY '0C3H'; /* 8080 JUMP INSTRUCTION */
|
||
|
||
DECLARE JUMP BYTE DATA(JMP); /* JMP INSTRUCTION TO */
|
||
/* JMP .PIPENTRY-3 WHERE THE LXI SP,STACK ACTUALLY OCCURS */
|
||
DECLARE JADR ADDRESS DATA(.PIPENTRY-3); /* START OF PIP */
|
||
/* NOTE: PAGE 1 AT 100H CONTAINS THE FOLLOWING
|
||
100H: JMP PIPENTRY ;TO START THE PIP PROGRAM */
|
||
|
||
|
||
DECLARE COPYRIGHT(*) BYTE DATA (
|
||
' COPYRIGHT (C) 1980, DIGITAL RESEARCH,',
|
||
' (09/11/81) MP/M-II PIP VERS 2.0');
|
||
|
||
|
||
/* LITERAL DECLARATIONS */
|
||
DECLARE
|
||
LIT LITERALLY 'LITERALLY',
|
||
LPP LIT '60', /* LINES PER PAGE */
|
||
TAB LIT '09H', /* HORIZONTAL TAB */
|
||
FF LIT '0CH', /* FORM FEED */
|
||
LA LIT '05FH', /* LEFT ARROW */
|
||
LB LIT '05BH', /* LEFT BRACKET */
|
||
RB LIT '05DH', /* RIGHT BRACKET */
|
||
XOFF LIT '13H', /* TRANSMIT BUFFER FUNCTION */
|
||
|
||
RDR LIT '5',
|
||
LST LIT '10',
|
||
PUNP LIT '15', /* POSITION OF 'PUN' + 1 */
|
||
CONP LIT '19', /* CONSOLE */
|
||
NULP LIT '19', /* NUL: BEFORE INCREMENT */
|
||
EOFP LIT '20', /* EOF: BEFORE INCREMENT */
|
||
HSRDR LIT 'RDR', /* READER DEVICES */
|
||
PRNT LIT '10', /* PRINTER */
|
||
|
||
|
||
FSIZE LIT '33',
|
||
FRSIZE LIT '36', /* SIZE OF RANDOM FCB */
|
||
NSIZE LIT '8',
|
||
FNSIZE LIT '11',
|
||
FEXT LIT '9',
|
||
FEXTL LIT '3',
|
||
HBUFS LIT '80', /* "HEX" BUFFER SIZE */
|
||
|
||
/* scanner return type code */
|
||
ERR LIT '0',
|
||
SPECL LIT '1',
|
||
FILE LIT '2',
|
||
PERIPH LIT '3',
|
||
DISKNAME LIT '4';
|
||
|
||
DECLARE
|
||
SEARFCB LITERALLY 'FCB', /* SEARCH FCB IN MULTI COPY */
|
||
MEMSIZE LITERALLY 'MAXB'; /* MEMORY SIZE */
|
||
|
||
DECLARE
|
||
TRUE LITERALLY '1',
|
||
FALSE LITERALLY '0',
|
||
FOREVER LITERALLY 'WHILE TRUE',
|
||
CR LITERALLY '13',
|
||
LF LITERALLY '10',
|
||
WHAT LITERALLY '63';
|
||
|
||
DECLARE
|
||
COLUMN BYTE, /* COLUMN COUNT FOR PRINTER TABS */
|
||
LINENO BYTE, /* LINE WITHIN PAGE */
|
||
AMBIG BYTE, /* SET FOR AMBIGUOUS FILE REFS */
|
||
FEEDBASE BYTE, /* USED TO FEED SEARCH CHARACTERS */
|
||
FEEDLEN BYTE, /* LENGTH OF FEED STRING */
|
||
MATCHLEN BYTE, /* USED IN MATCHING STRINGS */
|
||
QUITLEN BYTE, /* USED TO TERMINATE QUIT COMMAND */
|
||
NBUF BYTE, /* NUM BUFFERS-1 IN SBUFF AND DBUFF */
|
||
CDISK BYTE, /* CURRENT DISK */
|
||
SBLEN ADDRESS, /* SOURCE BUFFER LENGTH */
|
||
DBLEN ADDRESS, /* DEST BUFFER LENGTH */
|
||
tblen address, /* temp buffer length */
|
||
SBASE ADDRESS, /* SOURCE BUFFER BASE */
|
||
|
||
/* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION
|
||
1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */
|
||
DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */
|
||
SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */
|
||
(SCOM, DHEX) BYTE, /* SOURCE IS 'COM' FILE IF TRUE */
|
||
/* DEST IS 'HEX' FILE IF TRUE */
|
||
/* source fcb, password and password mode */
|
||
source structure (
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte,
|
||
pwmode byte,
|
||
user byte ),
|
||
|
||
/* temporary destination fcb, password and password mode */
|
||
dest structure (
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte,
|
||
pwmode byte,
|
||
user byte ),
|
||
|
||
/* original destination fcb, password and password mode */
|
||
odest structure (
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte,
|
||
pwmode byte,
|
||
user byte ),
|
||
|
||
HSOURCE BYTE, /* NEXT HEX SOURCE CHARACTER */
|
||
HBUFF(HBUFS) BYTE, /* HEX FILE BUFFER */
|
||
dxfcb(fsize) byte, /* destination xfcb */
|
||
DESTR ADDRESS AT(.DEST.FCB(33)), /* RANDOM RECORD POSITION */
|
||
DESTO BYTE AT(.DEST.FCB(35)), /* RANDOM OVERFLOW BYTE */
|
||
|
||
bufsize address, /* multsect buffer size */
|
||
NSOURCE ADDRESS, /* NEXT SOURCE CHARACTER */
|
||
HARDEOF ADDRESS, /* SET TO NSOURCE ON REAL EOF */
|
||
NDEST ADDRESS; /* NEXT DESTINATION CHARACTER */
|
||
|
||
DECLARE
|
||
PDEST BYTE, /* DESTINATION DEVICE */
|
||
PSOURCE BYTE; /* CURRENT SOURCE DEVICE */
|
||
|
||
DECLARE
|
||
getpw byte, /* false if password in dest file name */
|
||
fastcopy byte, /* true if copy directly to dbuf */
|
||
MULTCOM BYTE, /* FALSE IF PROCESSING ONE LINE */
|
||
PUTNUM BYTE, /* SET WHEN READY FOR NEXT LINE NUM */
|
||
CONCNT BYTE, /* COUNTER FOR CONSOLE READY CHECK */
|
||
CHAR BYTE, /* LAST CHARACTER SCANNED */
|
||
TYPE BYTE, /* TYPE OF CHARACTER SCANNED */
|
||
FLEN BYTE; /* FILE NAME LENGTH */
|
||
|
||
declare
|
||
f1 byte, /* f1 user attribute flag */
|
||
f2 byte, /* f2 user attribute flag */
|
||
f3 byte, /* f3 user attribute flag */
|
||
f4 byte, /* f4 user attribute flag */
|
||
ro byte, /* read only attribute flag */
|
||
sys byte, /* system attribute flag */
|
||
dcnt byte, /* error code or directory code */
|
||
exten byte, /* extention error code */
|
||
odcnt byte, /* saves dcnt for open dest file */
|
||
eretry byte; /* error return flag */
|
||
|
||
declare
|
||
subflgadr address,
|
||
submflg based subflgadr byte;
|
||
|
||
retcodes: procedure(a);
|
||
declare a address;
|
||
dcnt = low(a);
|
||
exten = high(a);
|
||
end retcodes;
|
||
|
||
MON1: PROCEDURE(F,A) EXTERNAL;
|
||
DECLARE F BYTE,
|
||
A ADDRESS;
|
||
END MON1;
|
||
|
||
MON2: PROCEDURE(F,A) BYTE EXTERNAL;
|
||
DECLARE F BYTE,
|
||
A ADDRESS;
|
||
END MON2;
|
||
|
||
MON3: PROCEDURE(F,A) ADDRESS EXTERNAL;
|
||
DECLARE F BYTE,
|
||
A ADDRESS;
|
||
END MON3;
|
||
|
||
BOOT: PROCEDURE EXTERNAL;
|
||
/* SYSTEM REBOOT */
|
||
END BOOT;
|
||
|
||
|
||
RDCHAR: PROCEDURE BYTE;
|
||
/* READ CONSOLE CHARACTER */
|
||
RETURN MON2(1,0);
|
||
END RDCHAR;
|
||
|
||
PRINTCHAR: PROCEDURE(CHAR);
|
||
DECLARE CHAR BYTE;
|
||
CALL MON1(2,CHAR AND 7FH);
|
||
END PRINTCHAR;
|
||
|
||
CRLF: PROCEDURE;
|
||
CALL PRINTCHAR(CR);
|
||
CALL PRINTCHAR(LF);
|
||
END CRLF;
|
||
|
||
printx: procedure(a);
|
||
declare a address;
|
||
call mon1(9,a);
|
||
end printx;
|
||
|
||
PRINT: PROCEDURE(A);
|
||
DECLARE A ADDRESS;
|
||
/* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
|
||
NEXT DOLLAR SIGN IS ENCOUNTERED */
|
||
CALL CRLF;
|
||
CALL printx(A);
|
||
END PRINT;
|
||
|
||
DECLARE CBUFF(130) BYTE, /* COMMAND BUFFER */
|
||
MAXLEN BYTE AT (.CBUFF(0)), /* MAX BUFFER LENGTH */
|
||
COMLEN BYTE AT (.CBUFF(1)), /* CURRENT LENGTH */
|
||
COMBUFF(128) BYTE AT (.CBUFF(2)); /* COMMAND BUFFER CONTENTS */
|
||
|
||
DECLARE
|
||
CBP BYTE; /* COMMAND BUFFER POINTER */
|
||
|
||
RDCOM: PROCEDURE;
|
||
/* READ INTO COMMAND BUFFER */
|
||
MAXLEN = 128;
|
||
CALL MON1(10,.MAXLEN);
|
||
END RDCOM;
|
||
|
||
CONBRK: PROCEDURE BYTE;
|
||
/* CHECK CONSOLE CHARACTER READY */
|
||
RETURN MON2(11,0);
|
||
END CONBRK;
|
||
|
||
CVERSION: PROCEDURE ADDRESS;
|
||
RETURN MON3(12,0); /* VERSION NUMBER */
|
||
END CVERSION;
|
||
|
||
SETDMA: PROCEDURE(A);
|
||
DECLARE A ADDRESS;
|
||
CALL MON1(26,A);
|
||
END SETDMA;
|
||
|
||
setpw: procedure(fcba);
|
||
declare fcba address;
|
||
declare fcbs based fcba structure (
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte );
|
||
call setdma(.fcbs.pwnam(0));
|
||
end setpw;
|
||
|
||
OPEN: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
CALL SETPW(FCB);
|
||
call retcodes(mon3(15,FCB));
|
||
END OPEN;
|
||
|
||
CLOSE: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
call retcodes(MON3(16,FCB));
|
||
END CLOSE;
|
||
|
||
DECLARE
|
||
CUSER BYTE; /* CURRENT USER NUMBER */
|
||
|
||
declare (anything,last$user) byte;
|
||
|
||
ck$user: procedure;
|
||
do forever;
|
||
if anything then return;
|
||
if dcnt = 0ffh then return;
|
||
if last$user = buff(ror (dcnt,3) and 110$0000b)
|
||
then return;
|
||
call retcodes(mon3(18,0));
|
||
end;
|
||
end ck$user;
|
||
|
||
SEARCH: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
declare fcb0 based fcb byte;
|
||
anything = (fcb0 = '?');
|
||
call retcodes(MON3(17,FCB));
|
||
call ck$user;
|
||
END SEARCH;
|
||
|
||
SEARCHN: PROCEDURE;
|
||
call retcodes(MON3(18,0));
|
||
call ck$user;
|
||
END SEARCHN;
|
||
|
||
DELETE: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
CALL SETPW(FCB);
|
||
call retcodes(MON3(19,FCB));
|
||
END DELETE;
|
||
|
||
DISKRD: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
call retcodes(MON3(20,FCB));
|
||
END DISKRD;
|
||
|
||
DISKWRITE: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
call retcodes(MON3(21,FCB));
|
||
END DISKWRITE;
|
||
|
||
MAKE: procedure(fcba);
|
||
declare fcba address;
|
||
declare fcbs based fcba structure (
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte );
|
||
if fcbs.pwnam(0) = 0 then /* zero if no password */
|
||
fcbs.fcb(6) = fcbs.fcb(6) and 7fh; /* reset password attribute */
|
||
else do;
|
||
fcbs.fcb(6) = fcbs.fcb(6) or 80h; /* set password attribute */
|
||
call setdma(.fcbs.pwnam(0)); /* set password dma */
|
||
end;
|
||
call retcodes(mon3(22,fcba));
|
||
END MAKE;
|
||
|
||
RENAME: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
CALL SETPW(FCB);
|
||
call retcodes(MON3(23,FCB)) ;
|
||
END RENAME;
|
||
|
||
getdisk: procedure byte;
|
||
return mon2(25,0);
|
||
end getdisk;
|
||
|
||
SETIND: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
call retcodes(MON3(30,FCB));
|
||
END SETIND;
|
||
|
||
GETUSER: PROCEDURE BYTE;
|
||
RETURN MON2(32,0FFH);
|
||
END GETUSER;
|
||
|
||
SETUSER: PROCEDURE(USER);
|
||
DECLARE USER BYTE;
|
||
CALL MON1(32,(last$user:=USER));
|
||
END SETUSER;
|
||
|
||
SETCUSER: PROCEDURE;
|
||
CALL SETUSER(CUSER);
|
||
END SETCUSER;
|
||
|
||
setduser: procedure;
|
||
call setuser(odest.user);
|
||
end setduser;
|
||
|
||
SETSUSER: PROCEDURE;
|
||
CALL SETUSER(source.user);
|
||
END SETSUSER;
|
||
|
||
RD$RANDOM: PROCEDURE(FCB) BYTE;
|
||
DECLARE FCB ADDRESS;
|
||
RETURN MON2(33,FCB);
|
||
END RD$RANDOM;
|
||
|
||
SET$RANDOM: PROCEDURE(FCB);
|
||
DECLARE FCB ADDRESS;
|
||
/* SET RANDOM RECORD POSITION */
|
||
CALL MON1(36,FCB);
|
||
END SET$RANDOM;
|
||
|
||
multsect: procedure(a);
|
||
declare a address;
|
||
call mon1(44,a);
|
||
end multsect;
|
||
|
||
errmode: procedure(a);
|
||
declare a address;
|
||
call mon1(45,a);
|
||
end errmode;
|
||
|
||
rdxfcb: procedure(xfcb);
|
||
declare xfcb address;
|
||
call retcodes(mon3(102,xfcb));
|
||
end rdxfcb;
|
||
|
||
who$con: procedure byte;
|
||
return mon2(153,0);
|
||
end who$con;
|
||
|
||
sysdatadr: procedure address;
|
||
return mon3(154,0);
|
||
end sysdatadr;
|
||
|
||
conatlst: procedure byte;
|
||
return mon2(161,0);
|
||
end conatlst;
|
||
|
||
DECLARE /* CONTROL TOGGLE VECTOR */
|
||
CONT(26) BYTE, /* ONE FOR EACH ALPHABETIC */
|
||
/* 00 01 02 03 04 05 06 07 08 09 10 11 12 13
|
||
A B C D E F G H I J K L M N
|
||
14 15 16 17 18 19 20 21 22 23 24 25
|
||
O P Q R S T U V W X Y Z */
|
||
archiv byte at(.cont(0)), /* file archive */
|
||
BLOCK BYTE AT(.CONT(1)), /* BLOCK MODE TRANSFER */
|
||
DELET BYTE AT(.CONT(3)), /* DELETE CHARACTERS */
|
||
ECHO BYTE AT(.CONT(4)), /* ECHO CONSOLE CHARACTERS */
|
||
FORMF BYTE AT(.CONT(5)), /* FORM FILTER */
|
||
GETU BYTE AT(.CONT(6)), /* GET FILE, USER # */
|
||
HEXT BYTE AT(.CONT(7)), /* HEX FILE TRANSFER */
|
||
IGNOR BYTE AT(.CONT(8)), /* IGNORE :00 RECORD ON FILE */
|
||
kilds byte at(.cont(10)), /* kill filename display */
|
||
LOWER BYTE AT(.CONT(11)), /* TRANSLATE TO LOWER CASE */
|
||
NUMB BYTE AT(.CONT(13)), /* NUMBER OUTPUT LINES */
|
||
OBJ BYTE AT(.CONT(14)), /* OBJECT FILE TRANSFER */
|
||
PAGCNT BYTE AT(.CONT(15)), /* PAGE LENGTH */
|
||
QUITS BYTE AT(.CONT(16)), /* QUIT COPY */
|
||
RSYS BYTE AT(.CONT(17)), /* READ SYSTEM FILES */
|
||
STARTS BYTE AT(.CONT(18)), /* START COPY */
|
||
TABS BYTE AT(.CONT(19)), /* TAB SET */
|
||
UPPER BYTE AT(.CONT(20)), /* UPPER CASE TRANSLATE */
|
||
VERIF BYTE AT(.CONT(21)), /* VERIFY EQUAL FILES ONLY */
|
||
WRROF BYTE AT(.CONT(22)), /* WRITE TO R/O FILE */
|
||
ZEROP BYTE AT(.CONT(25)); /* ZERO PARITY ON INPUT */
|
||
|
||
DECLARE ZEROSUP BYTE, /* ZERO SUPPRESSION */
|
||
(C3,C2,C1) BYTE; /* LINE COUNT ON PRINTER */
|
||
|
||
MOVE: PROCEDURE(S,D,N);
|
||
DECLARE (S,D) ADDRESS, N BYTE;
|
||
DECLARE A BASED S BYTE, B BASED D BYTE;
|
||
DO WHILE (N:=N-1) <> 255;
|
||
B = A; S = S+1; D = D+1;
|
||
END;
|
||
END MOVE;
|
||
|
||
MOVEXT: PROCEDURE(A);
|
||
DECLARE A ADDRESS;
|
||
/* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
|
||
CALL MOVE(A,.DEST.FCB(FEXT),FEXTL);
|
||
END MOVEXT;
|
||
|
||
ERROR: PROCEDURE(errtype,extention,retflag,fileadr);
|
||
DECLARE I BYTE,
|
||
temp byte,
|
||
errtype byte,
|
||
extention byte,
|
||
retflag byte,
|
||
fileadr address,
|
||
fcb based fileadr (fsize) byte;
|
||
|
||
/* errtype error messages */
|
||
declare er00(*) byte data ('DISK READ$');
|
||
declare er01(*) byte data ('DISK WRITE$');
|
||
declare er02(*) byte data ('VERIFY$');
|
||
declare er03(*) byte data ('INVALID DESTINATION$');
|
||
declare er04(*) byte data ('INVALID SOURCE$');
|
||
declare er05(*) byte data ('USER ABORTED$');
|
||
declare er06(*) byte data ('BAD PARAMETER$');
|
||
declare er07(*) byte data ('INVALID USER NUMBER$');
|
||
declare er08(*) byte data ('INVALID FORMAT$');
|
||
declare er09(*) byte data ('MAKE FILE$');
|
||
declare er10(*) byte data ('FILE NOT FOUND$');
|
||
declare er11(*) byte data ('START NOT FOUND$');
|
||
declare er12(*) byte data ('QUIT NOT FOUND$');
|
||
declare er13(*) byte data ('OPEN FILE$');
|
||
declare er14(*) byte data ('CLOSE FILE$');
|
||
declare er15(*) byte data ('PRINTER BUSY$');
|
||
declare er16(*) byte data ('INVALID SEPARATOR$');
|
||
declare er17(*) byte data ('NO DIRECTORY SPACE$');
|
||
declare er18(*) byte data ('CAN''T DELETE TEMP FILE$');
|
||
|
||
declare errmsg(*) address data(
|
||
.er00,.er01,.er02,.er03,.er04,
|
||
.er05,.er06,.er07,.er08,.er09,
|
||
.er10,.er11,.er12,.er13,.er14,
|
||
.er15,.er16,.er17,.er18);
|
||
|
||
/* extended error messages */
|
||
declare ex00(*) byte data ('$'); /* NO MESSAGE */
|
||
declare ex01(*) byte data ('NONRECOVERABLE$');
|
||
declare ex02(*) byte data ('R/O DISK$');
|
||
declare ex03(*) byte data ('R/O FILE$');
|
||
declare ex04(*) byte data ('INVALID DISK SELECT$');
|
||
declare ex05(*) byte data ('INCOMPATIBLE MODE$');
|
||
declare ex06(*) byte data ('FCB CHECKSUM$');
|
||
declare ex07(*) byte data ('INVALID PASSWORD$');
|
||
declare ex08(*) byte data ('ALREADY EXISTS$');
|
||
declare ex09(*) byte data ('INVALID FILENAME$');
|
||
declare ex10(*) byte data ('LIMIT EXCEEDED$');
|
||
declare ex11(*) byte data ('INTERNAL LOCK LIMIT EXCEEDED$');
|
||
|
||
declare nummsgs lit '12'; /* number of extended messages */
|
||
declare extmsg(nummsgs) address data(
|
||
.ex00,.ex01,.ex02,.ex03,.ex04,
|
||
.ex05,.ex06,.ex07,.ex08,.ex09,
|
||
.ex10,.ex11);
|
||
|
||
eretry = retflag; /* error retry = retry flag */
|
||
call multsect(1);
|
||
call setduser;
|
||
call close(.dest);
|
||
call delete(.dest); /* delete destination scratch file */
|
||
call close(.odest); /* try to close original destination */
|
||
CALL SETCUSER;
|
||
|
||
/* print out error message */
|
||
call print(.('ERROR - $'));
|
||
call printx(errmsg(errtype));
|
||
if (extention := extention and 0fh) <= nummsgs then
|
||
do; call printchar(' ');
|
||
call printx(extmsg(extention));
|
||
end;
|
||
call printx(.(' - $'));
|
||
if fileadr <> 0 then
|
||
do; call printchar('A' + fcb(0) - 1);
|
||
call printchar(':');
|
||
do i = 1 to fnsize;
|
||
if (temp := fcb(i) and 07fh) <> ' ' then
|
||
do; if i = fext then call printchar('.');
|
||
call printchar(temp);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
/* ZERO THE COMLEN IN CASE THIS IS A SINGLE COMMAND */
|
||
COMLEN = 0;
|
||
/* DELETE ANY $$$.SUB FILES IN CASE BATCH PROCESSING */
|
||
subflgadr = sysdatadr + 128 + who$con;
|
||
submflg = 0;
|
||
CALL CRLF;
|
||
GO TO RETRY;
|
||
END ERROR;
|
||
|
||
FORMERR: PROCEDURE;
|
||
call error(8,0,0,0); /* invalid format */
|
||
END FORMERR;
|
||
|
||
FILLSOURCE: PROCEDURE;
|
||
/* FILL THE SOURCE BUFFERS */
|
||
DECLARE (I,n) BYTE;
|
||
NSOURCE = 0;
|
||
CALL SETSUSER; /* SOURCE USER NUMBER SET */
|
||
if fastcopy then
|
||
do; n = shr(nbuf,3) - 1;
|
||
bufsize = 1024;
|
||
call multsect(8);
|
||
end;
|
||
else do;
|
||
bufsize = 128;
|
||
call multsect(1);
|
||
n = nbuf;
|
||
end;
|
||
|
||
DO I = 0 TO N;
|
||
/* SET DMA ADDRESS TO NEXT BUFFER POSIITION */
|
||
CALL SETDMA(.SBUFF(NSOURCE));
|
||
call diskrd(.source);
|
||
IF dcnt <> 0 THEN
|
||
DO; IF dcnt <> 1 THEN
|
||
call error(0,exten,0,.source); /* DISK READ ERROR */
|
||
/* END - OF - FILE */
|
||
if fastcopy then /* add no. sectors copied */
|
||
nsource = nsource + (128 * shr(exten,4));
|
||
HARDEOF = NSOURCE; /* SET HARD END-OF-FILE */
|
||
SBUFF(NSOURCE) = ENDFILE; I = N;
|
||
END;
|
||
ELSE
|
||
NSOURCE = NSOURCE + bufsize;
|
||
END;
|
||
tblen = nsource;
|
||
NSOURCE = 0;
|
||
CALL SETCUSER; /* BACK TO CURRENT USER NUMBER */
|
||
END FILLSOURCE;
|
||
|
||
|
||
WRITEDEST: PROCEDURE;
|
||
/* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION
|
||
NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */
|
||
DECLARE (I, J, N) BYTE,
|
||
DATAOK BYTE;
|
||
IF (N := LOW(SHR(NDEST,7)) - 1) = 255 THEN RETURN ;
|
||
if fastcopy then
|
||
do; bufsize = 1024;
|
||
call multsect(8);
|
||
end;
|
||
else
|
||
do; bufsize = 128;
|
||
call multsect(1);
|
||
end;
|
||
NDEST = 0;
|
||
call setduser; /* destination user */
|
||
CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */
|
||
DO I = 0 TO N;
|
||
if fastcopy then
|
||
do; if (n - i < 7) then
|
||
do; bufsize = 128;
|
||
call multsect(1);
|
||
end;
|
||
else i = i + 7;
|
||
end;
|
||
/* SET DMA ADDRESS TO NEXT BUFFER */
|
||
CALL SETDMA(.dbuff(ndest));
|
||
call diskwrite(.dest);
|
||
IF dcnt <> 0 THEN
|
||
call error(1,exten,0,.dest); /* DISK WRITE ERROR */
|
||
NDEST = NDEST + bufsize;
|
||
END;
|
||
call multsect(1);
|
||
IF VERIF THEN /* VERIFY DATA WRITTEN OK */
|
||
DO;
|
||
NDEST = 0;
|
||
CALL SETDMA(.BUFF); /* FOR COMPARE */
|
||
DO I = 0 TO N;
|
||
DATAOK = RDRANDOM(.DEST) = 0;
|
||
DESTR = DESTR + 1; /* NEXT RANDOM READ */
|
||
J = 0;
|
||
/* PERFORM COMPARISON */
|
||
DO WHILE DATAOK AND J < 80H;
|
||
DATAOK = BUFF(J) = DBUFF(NDEST+J);
|
||
J = J + 1;
|
||
END;
|
||
NDEST = NDEST + 128;
|
||
IF NOT DATAOK THEN
|
||
call error(2,0,0,.dest); /* VERIFY ERROR */
|
||
END;
|
||
call diskwrite(.dest);
|
||
DATAOK = dcnt;
|
||
/* NOW READY TO CONTINUE THE WRITE OPERATION */
|
||
END;
|
||
NDEST = 0;
|
||
call setcuser; /* back to current user */
|
||
END WRITEDEST;
|
||
|
||
PUTDCHAR: PROCEDURE(B);
|
||
DECLARE B BYTE;
|
||
/* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY PDEST */
|
||
IF B >= ' ' THEN
|
||
DO; COLUMN = COLUMN + 1;
|
||
IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */
|
||
DO; IF COLUMN > DELET THEN RETURN;
|
||
END;
|
||
END;
|
||
DO CASE PDEST;
|
||
/* CASE 0 IS THE DESTINATION FILE */
|
||
DO;
|
||
IF NDEST >= DBLEN THEN CALL WRITEDEST;
|
||
DBUFF(NDEST) = B;
|
||
NDEST = NDEST+1;
|
||
END;
|
||
/* CASE 1 IS ARD (ADDMASTER) */
|
||
GO TO NOTDEST;
|
||
/* CASE 2 IS IRD (INTEL/ICOM) */
|
||
GO TO NOTDEST;
|
||
/* CASE 3 IS PTR */
|
||
GO TO NOTDEST;
|
||
/* CASE 4 IS UR1 */
|
||
GO TO NOTDEST;
|
||
/* CASE 5 IS UR2 */
|
||
GO TO NOTDEST;
|
||
/* CASE 6 IS RDR */
|
||
NOTDEST:
|
||
call error(3,0,0,0); /* invalid destination */
|
||
/* CASE 7 IS OUT */
|
||
go to notdest;
|
||
/* CASE 8 IS LPT */
|
||
go to notdest;
|
||
/* CASE 9 IS UL1 */
|
||
GO TO NOTDEST;
|
||
/* CASE 10 IS PRN (TABS EXPANDED, LINES LISTED, CHANGED TO LST) */
|
||
GO TO LSTL;
|
||
/* CASE 11 IS LST */
|
||
LSTL:
|
||
CALL MON1(5,B);
|
||
/* CASE 12 IS PTP */
|
||
GO TO NOTDEST;
|
||
/* CASE 13 IS UP1 */
|
||
GO TO NOTDEST;
|
||
/* CASE 14 IS UP2 */
|
||
GO TO NOTDEST;
|
||
/* CASE 15 IS PUN */
|
||
GO TO NOTDEST;
|
||
/* CASE 16 IS TTY */
|
||
go to notdest;
|
||
/* CASE 17 IS CRT */
|
||
go to notdest;
|
||
/* CASE 18 IS UC1 */
|
||
go to notdest;
|
||
/* CASE 19 IS CON */
|
||
CONL:
|
||
CALL MON1(2,B);
|
||
END; /* of case */
|
||
END PUTDCHAR;
|
||
|
||
PUTDESTC: PROCEDURE(B);
|
||
DECLARE (B,I) BYTE;
|
||
/* WRITE DESTINATION CHARACTER, TAB EXPANSION */
|
||
IF B <> TAB THEN CALL PUTDCHAR(B);
|
||
ELSE IF TABS = 0 THEN CALL PUTDCHAR(B);
|
||
ELSE /* B IS TAB CHAR, TABS > 0 */
|
||
DO; I = COLUMN;
|
||
DO WHILE I >= TABS;
|
||
I = I - TABS;
|
||
END;
|
||
I = TABS - I;
|
||
DO WHILE I > 0;
|
||
I = I - 1;
|
||
CALL PUTDCHAR(' ');
|
||
END;
|
||
END;
|
||
IF B = CR THEN COLUMN = 0;
|
||
END PUTDESTC;
|
||
|
||
PRINT1: PROCEDURE(B);
|
||
DECLARE B BYTE;
|
||
IF (ZEROSUP := ZEROSUP AND B = 0) THEN
|
||
CALL PUTDESTC(' ');
|
||
ELSE
|
||
CALL PUTDESTC('0'+B);
|
||
END PRINT1;
|
||
|
||
PRINTDIG: PROCEDURE(D);
|
||
DECLARE D BYTE;
|
||
CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B);
|
||
END PRINTDIG;
|
||
|
||
NEWLINE: PROCEDURE;
|
||
DECLARE ONE BYTE;
|
||
ONE = 1;
|
||
ZEROSUP = NUMB = 1;
|
||
C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0);
|
||
CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1);
|
||
IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */
|
||
DO; CALL PUTDESTC(':'); CALL PUTDESTC(' ');
|
||
END;
|
||
ELSE
|
||
CALL PUTDESTC(TAB);
|
||
END NEWLINE;
|
||
|
||
CLEARBUFF: PROCEDURE;
|
||
/* CLEAR OUTPUT BUFFER IN BLOCK MODE TRANSMISION */
|
||
DECLARE NA ADDRESS;
|
||
DECLARE I BYTE;
|
||
I = LOW(NDEST) AND 7FH; /* REMAINING PARTIAL BUFFER LENGTH */
|
||
NA = NDEST AND 0FF80H; /* START OF SEGMENT NOT WRITTEN */
|
||
CALL WRITEDEST; /* CLEARS BUFFERS */
|
||
CALL MOVE(.DBUFF(NA),.DBUFF,I);
|
||
/* DATA MOVED TO BEGINNING OF BUFFER */
|
||
NDEST = I;
|
||
END CLEARBUFF;
|
||
|
||
PUTDEST: PROCEDURE(B);
|
||
DECLARE (I,B) BYTE;
|
||
/* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */
|
||
IF FORMF THEN /* SKIP FORM FEEDS */
|
||
DO; IF B = FF THEN RETURN;
|
||
END;
|
||
IF PUTNUM THEN /* END OF LINE OR START OF FILE */
|
||
DO;
|
||
IF B <> FF THEN /* NOT FORM FEED */
|
||
DO;
|
||
IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */
|
||
DO; IF I=1 THEN I=LPP;
|
||
IF (LINENO := LINENO + 1) >= I THEN
|
||
DO; LINENO = 0; /* NEW PAGE */
|
||
CALL PUTDESTC(FF);
|
||
END;
|
||
END;
|
||
IF NUMB > 0 THEN
|
||
CALL NEWLINE;
|
||
PUTNUM = FALSE;
|
||
END;
|
||
END;
|
||
IF BLOCK THEN /* BLOCK MODE TRANSFER */
|
||
DO;
|
||
IF B = XOFF AND PDEST = 0 THEN
|
||
DO; CALL CLEARBUFF; /* BUFFERS WRITTEN */
|
||
RETURN; /* DON'T PASS THE X-OFF */
|
||
END;
|
||
END;
|
||
IF B = FF THEN LINENO = 0;
|
||
CALL PUTDESTC(B);
|
||
IF B = LF THEN PUTNUM = TRUE;
|
||
END PUTDEST;
|
||
|
||
|
||
UTRAN: PROCEDURE(B) BYTE;
|
||
DECLARE B BYTE;
|
||
/* TRANSLATE ALPHA TO UPPER CASE */
|
||
IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */
|
||
B = B AND 101$1111B; /* TO UPPER CASE */
|
||
RETURN B;
|
||
END UTRAN;
|
||
|
||
LTRAN: PROCEDURE(B) BYTE;
|
||
DECLARE B BYTE;
|
||
/* TRANSLATE TO LOWER CASE ALPHA */
|
||
IF B >= 'A' AND B <= 'Z' THEN
|
||
B = B OR 10$0000B; /* TO LOWER */
|
||
RETURN B;
|
||
END LTRAN;
|
||
|
||
GETSOURCEC: PROCEDURE BYTE;
|
||
/* READ NEXT SOURCE CHARACTER */
|
||
DECLARE (TEMP,B,CONCHK) BYTE;
|
||
|
||
IF PSOURCE - 1 <= RDR THEN /* 1 ... RDR+1 */
|
||
DO; IF (BLOCK OR HEXT) AND CONBRK THEN
|
||
DO;
|
||
IF RDCHAR = ENDFILE THEN RETURN ENDFILE;
|
||
CALL PRINT(.('READER STOPPING',CR,LF,'$'));
|
||
RETURN XOFF;
|
||
END;
|
||
END;
|
||
CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */
|
||
DO CASE PSOURCE;
|
||
/* CASE 0 IS SOURCE FILE */
|
||
DO; IF NSOURCE >= SBLEN THEN CALL FILLSOURCE;
|
||
B = SBUFF(NSOURCE);
|
||
NSOURCE = NSOURCE + 1;
|
||
END;
|
||
/* CASE 1 IS INP */
|
||
go to notsource;
|
||
/* CASE 2 IS IRD (INTEL/ICOM) */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 3 IS PTR */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 4 IS UR1 */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 5 IS UR2 */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 6 IS RDR */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 7 IS OUT */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 8 IS LPT */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 9 IS UL1 */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 10 IS PRN */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 11 IS LST */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 12 IS PTP */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 13 IS UP1 */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 14 IS UP2 */
|
||
GO TO NOTSOURCE;
|
||
/* CASE 15 IS PUN */
|
||
NOTSOURCE:
|
||
DO; call error(4,0,0,0); /* invalid source */
|
||
END;
|
||
/* CASE 16 IS TTY */
|
||
go to notsource;
|
||
/* CASE 17 IS CRT */
|
||
go to notsource;
|
||
/* CASE 18 IS UC1 */
|
||
go to notsource;
|
||
/* CASE 19 IS CON */
|
||
CONL:
|
||
DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
|
||
B = MON2(1,0);
|
||
END;
|
||
END; /* OF CASES */
|
||
IF ECHO THEN /* COPY TO CONSOLE DEVICE */
|
||
DO; TEMP = PDEST; PDEST = CONP; CALL PUTDEST(B);
|
||
PDEST = TEMP;
|
||
END;
|
||
IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */
|
||
DO;
|
||
IF SCOM THEN /* SOURCE IS A COM FILE */
|
||
CONCHK = (CONCNT := CONCNT + 1) = 0;
|
||
ELSE /* ASCII */
|
||
CONCHK = B = LF;
|
||
IF CONCHK THEN
|
||
DO; IF CONBRK THEN
|
||
DO;
|
||
IF RDCHAR = ENDFILE THEN RETURN ENDFILE;
|
||
call error(5,0,0,0); /* USER ABORTED */
|
||
END;
|
||
END;
|
||
END;
|
||
IF ZEROP THEN B = B AND 7FH;
|
||
IF UPPER THEN RETURN UTRAN(B);
|
||
IF LOWER THEN RETURN LTRAN(B);
|
||
RETURN B;
|
||
END GETSOURCEC;
|
||
|
||
GETSOURCE: PROCEDURE BYTE;
|
||
/* GET NEXT SOURCE CHARACTER */
|
||
DECLARE CHAR BYTE;
|
||
MATCH: PROCEDURE(B) BYTE;
|
||
/* MATCH START AND QUIT STRINGS */
|
||
DECLARE (B,C) BYTE;
|
||
IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */
|
||
DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */
|
||
RETURN TRUE;
|
||
END;
|
||
IF C = CHAR THEN MATCHLEN = MATCHLEN + 1;
|
||
ELSE
|
||
MATCHLEN = 0; /* NO MATCH */
|
||
RETURN FALSE;
|
||
END MATCH;
|
||
IF QUITLEN > 0 THEN
|
||
DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF;
|
||
RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */
|
||
END;
|
||
DO FOREVER; /* LOOKING FOR START */
|
||
IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */
|
||
DO; FEEDLEN = FEEDLEN - 1;
|
||
CHAR = COMBUFF(FEEDBASE);
|
||
FEEDBASE = FEEDBASE + 1;
|
||
RETURN CHAR;
|
||
END;
|
||
IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE;
|
||
IF STARTS > 0 THEN /* LOOKING FOR START STRING */
|
||
DO; IF MATCH(STARTS) THEN
|
||
DO; FEEDBASE = STARTS; STARTS = 0;
|
||
FEEDLEN = MATCHLEN + 1;
|
||
matchlen = 0;
|
||
END; /* OTHERWISE NO MATCH, SKIP CHARACTER */
|
||
END;
|
||
ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */
|
||
DO; IF MATCH(QUITS) THEN
|
||
DO; QUITS = 0; QUITLEN = 2;
|
||
/* SUBSEQUENTLY RETURN CR, LF, ENDFILE */
|
||
RETURN CR;
|
||
END;
|
||
RETURN CHAR;
|
||
END;
|
||
ELSE
|
||
RETURN CHAR;
|
||
END; /* OF DO FOREVER */
|
||
END GETSOURCE;
|
||
|
||
GNC: PROCEDURE BYTE;
|
||
IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR;
|
||
RETURN UTRAN(COMBUFF(CBP));
|
||
END GNC;
|
||
|
||
DEBLANK: PROCEDURE;
|
||
DO WHILE (CHAR := GNC) = ' ';
|
||
END;
|
||
END DEBLANK;
|
||
|
||
SCAN: PROCEDURE(FCBA);
|
||
DECLARE FCBA ADDRESS, /* ADDRESS OF FCB TO FILL */
|
||
fcbs based fcba structure ( /* FCB, PASSWORD AND MODE STRUCTURE */
|
||
fcb(frsize) byte,
|
||
pwnam(nsize) byte,
|
||
pwmode byte,
|
||
user byte );
|
||
DECLARE (I,K) BYTE; /* TEMP COUNTERS */
|
||
|
||
/* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME.
|
||
THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */
|
||
|
||
DELIMITER: PROCEDURE(C) BYTE;
|
||
DECLARE (I,C) BYTE;
|
||
DECLARE DEL(*) BYTE DATA
|
||
(' =.:;,<>',CR,LA,LB,RB);
|
||
DO I = 0 TO LAST(DEL);
|
||
IF C = DEL(I) THEN RETURN TRUE;
|
||
END;
|
||
RETURN FALSE;
|
||
END DELIMITER;
|
||
|
||
PUTCHAR: PROCEDURE;
|
||
FCBS.FCB(FLEN:=FLEN+1) = CHAR;
|
||
IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */
|
||
END PUTCHAR;
|
||
|
||
FILLQ: PROCEDURE(LEN);
|
||
/* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */
|
||
DECLARE LEN BYTE;
|
||
CHAR = WHAT; /* QUESTION MARK */
|
||
DO WHILE FLEN < LEN;
|
||
CALL PUTCHAR;
|
||
END;
|
||
END FILLQ;
|
||
|
||
SCANPAR: PROCEDURE;
|
||
DECLARE (I,J) BYTE;
|
||
/* SCAN OPTIONAL PARAMETERS */
|
||
CHAR = GNC; /* SCAN PAST BRACKET */
|
||
DO WHILE NOT(CHAR = CR OR CHAR = RB);
|
||
IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */
|
||
DO; IF CHAR = ' ' THEN
|
||
CHAR = GNC;
|
||
ELSE
|
||
call error(6,0,0,0); /* BAD PARAMETER */
|
||
END;
|
||
ELSE
|
||
DO; /* SCAN PARAMETER VALUE */
|
||
IF CHAR = 'S' OR CHAR = 'Q' THEN
|
||
DO; /* START OR QUIT COMMAND */
|
||
J = CBP + 1; /* START OF STRING */
|
||
DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR);
|
||
END;
|
||
CHAR=GNC;
|
||
END;
|
||
ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN
|
||
J = 1;
|
||
ELSE
|
||
DO WHILE (K := (CHAR := GNC) - '0') <= 9;
|
||
J = J * 10 + K;
|
||
END;
|
||
CONT(I) = J;
|
||
IF I = 6 THEN /* SET SOURCE USER */
|
||
DO;
|
||
IF J > 31 THEN
|
||
call error(7,0,0,0); /* INVALID USER NUMBER */
|
||
fcbs.user = J;
|
||
END;
|
||
END;
|
||
END;
|
||
CHAR = GNC;
|
||
END SCANPAR;
|
||
|
||
CHKSET: PROCEDURE;
|
||
IF CHAR = LA THEN CHAR = '=';
|
||
END CHKSET;
|
||
|
||
/* scan procedure entry point */
|
||
|
||
/* INITIALIZE FILE CONTROL BLOCK TO EMPTY */
|
||
AMBIG = FALSE; TYPE = ERR; CHAR = ' '; FLEN = 0;
|
||
DO WHILE FLEN < FRSIZE + NSIZE;
|
||
IF FLEN = FNSIZE THEN CHAR = 0;
|
||
ELSE IF FLEN = FRSIZE THEN CHAR = ' ';
|
||
FCBS.FCB(FLEN := FLEN + 1) = CHAR;
|
||
END;
|
||
fcbs.pwmode = 1;
|
||
|
||
/* DEBLANK COMMAND BUFFER */
|
||
CALL DEBLANK;
|
||
|
||
/* MAY BE A SEPARATOR */
|
||
IF DELIMITER(CHAR) THEN
|
||
DO; CALL CHKSET;
|
||
TYPE = SPECL; RETURN;
|
||
END;
|
||
|
||
/* CHECK PERIPHERALS AND DISK FILES */
|
||
fcbs.fcb(0) = cdisk +1; /* initialize to current disk */
|
||
fcbs.user = cuser; /* and current user */
|
||
/* CLEAR PARAMETERS */
|
||
DO I = 0 TO 25; CONT(I) = 0;
|
||
END;
|
||
FEEDLEN,MATCHLEN,QUITLEN = 0;
|
||
/* SCAN NEXT NAME */
|
||
DO FOREVER;
|
||
FLEN = 0;
|
||
DO WHILE NOT DELIMITER(CHAR);
|
||
IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */
|
||
RETURN;
|
||
IF CHAR = '*' THEN CALL FILLQ(NSIZE);
|
||
ELSE CALL PUTCHAR;
|
||
CHAR = GNC;
|
||
END;
|
||
|
||
/* CHECK FOR DISK NAME OR DEVICE NAME */
|
||
IF CHAR = ':' THEN
|
||
DO; IF FLEN = 1 THEN
|
||
/* MAY BE DISK NAME A ... P */
|
||
DO;
|
||
IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 17 THEN
|
||
RETURN; /* ERROR, INVALID DISK NAME */
|
||
CALL DEBLANK; /* MAY BE DISK NAME ONLY */
|
||
IF DELIMITER(CHAR) THEN
|
||
DO; IF CHAR = LB THEN
|
||
CALL SCANPAR;
|
||
CBP = CBP - 1;
|
||
TYPE = DISKNAME;
|
||
RETURN;
|
||
END;
|
||
END;
|
||
ELSE
|
||
/* MAY BE A THREE CHARACTER DEVICE NAME */
|
||
IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */
|
||
RETURN;
|
||
ELSE
|
||
/* LOOK FOR DEVICE NAME */
|
||
DO; DECLARE (I,J,K) BYTE, M LITERALLY '20',
|
||
IO(*) BYTE DATA
|
||
('INPIRDPTRUR1UR2RDROUTLPTUL1PRNLST',
|
||
'PTPUP1UP2PUNTTYCRTUC1CONNULEOF',0);
|
||
/* NOTE THAT ALL READER-LIKE DEVICES MUST BE
|
||
PLACED BEFORE 'RDR', AND ALL LISTING-LIKE DEVICES
|
||
MUST APPEAR BELOW LST, BUT ABOVE RDR. THE LITERAL
|
||
DECLARATIONS FOR RDR, LST, AND PUNP MUST INDICATE
|
||
THE POSITIONS OF THESE DEVICES IN THE LIST */
|
||
J = 255;
|
||
DO K = 0 TO M;
|
||
I = 0;
|
||
DO WHILE ((I:=I+1) <= 3) AND
|
||
IO(J+I) = fcbs.fcb(I);
|
||
END;
|
||
IF I = 4 THEN /* COMPLETE MATCH */
|
||
DO; TYPE = PERIPH;
|
||
/* SCAN PARAMETERS */
|
||
IF GNC = LB THEN CALL SCANPAR;
|
||
CBP = CBP - 1; CHAR = K;
|
||
RETURN;
|
||
END;
|
||
/* OTHERWISE TRY NEXT DEVICE */ J = J + 3;
|
||
END;
|
||
|
||
/* ERROR, NO DEVICE NAME MATCH */ RETURN;
|
||
END;
|
||
IF CHAR = LB THEN /* PARAMETERS FOLLOW */
|
||
CALL SCANPAR;
|
||
END;
|
||
ELSE
|
||
/* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */
|
||
DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */
|
||
RETURN;
|
||
FLEN = NSIZE;
|
||
IF CHAR = '.' THEN /* SCAN FILE TYPE */
|
||
DO WHILE NOT DELIMITER(CHAR := GNC);
|
||
IF FLEN >= FNSIZE THEN
|
||
/* ERROR, TYPE FIELD TOO LONG */ RETURN;
|
||
IF CHAR = '*' THEN CALL FILLQ(FNSIZE);
|
||
ELSE CALL PUTCHAR;
|
||
END;
|
||
|
||
FLEN = 0;
|
||
IF CHAR = ';' THEN /* SCAN PASSWORD */
|
||
DO WHILE NOT DELIMITER(CHAR := GNC);
|
||
IF FLEN >= NSIZE THEN
|
||
/* ERROR, PW TOO LONG */ RETURN;
|
||
ELSE /* SAVE PASSWORD */
|
||
FCBS.PWNAM(FLEN) = CHAR;
|
||
FLEN = FLEN + 1;
|
||
END;
|
||
if (.fcbs = .odest) then /* use dest password */
|
||
getpw = false;
|
||
|
||
IF CHAR = LB THEN
|
||
CALL SCANPAR;
|
||
/* RESCAN DELIMITER NEXT TIME AROUND */
|
||
CBP = CBP - 1;
|
||
TYPE = FILE;
|
||
FCBS.FCB(32) = 0;
|
||
RETURN;
|
||
END;
|
||
END;
|
||
END SCAN;
|
||
|
||
NULLS: PROCEDURE;
|
||
/* SEND 40 NULLS TO OUTPUT DEVICE */
|
||
DECLARE I BYTE;
|
||
DO I = 0 TO 39; CALL PUTDEST(0);
|
||
END;
|
||
END NULLS;
|
||
|
||
|
||
DECLARE COPYING BYTE; /* TRUE WHILE COPYING TO DEST FILE */
|
||
|
||
EQUAL: PROCEDURE(A,B) BYTE;
|
||
/* COMPARE THE STRINGS AT A AND B UNTIL EITHER A MISMATCH OR
|
||
A '$' IS ENCOUNTERED IN STRING B */
|
||
DECLARE (A,B) ADDRESS,
|
||
(SA BASED A, SB BASED B) BYTE;
|
||
DO WHILE SB <> '$';
|
||
IF (SB AND 7FH) <> (SA AND 7FH) THEN RETURN FALSE;
|
||
A = A + 1; B = B + 1;
|
||
END;
|
||
RETURN TRUE;
|
||
END EQUAL;
|
||
|
||
RD$EOF: PROCEDURE BYTE;
|
||
/* RETURN TRUE IF END OF FILE */
|
||
CHAR = GETSOURCE;
|
||
IF SCOM THEN RETURN HARDEOF < NSOURCE;
|
||
RETURN CHAR = ENDFILE;
|
||
END RD$EOF;
|
||
|
||
|
||
HEXRECORD: PROCEDURE BYTE;
|
||
/* READ ONE RECORD INTO SBUFF AND CHECK FOR PROPER FORM
|
||
RETURNS 0 IF RECORD OK
|
||
RETURNS 1 IF END OF TAPE (:00000)
|
||
RETURNS 2 IF ERROR IN RECORD */
|
||
|
||
|
||
DECLARE XOFFSET BYTE; /* TRUE IF XOFF RECVD */
|
||
DECLARE NOERRS BYTE; /* TRUE IF NO ERRORS IN THIS RECORD */
|
||
|
||
PRINTERR: PROCEDURE(A);
|
||
/* PRINT ERROR MESSAGE IF NOERRS TRUE */
|
||
DECLARE A ADDRESS;
|
||
IF NOERRS THEN
|
||
DO; NOERRS = FALSE;
|
||
CALL PRINT(A);
|
||
END;
|
||
END PRINTERR;
|
||
|
||
CKXOFF: PROCEDURE;
|
||
IF XOFFSET THEN
|
||
DO; XOFFSET = FALSE;
|
||
CALL CLEARBUFF;
|
||
END;
|
||
END CKXOFF;
|
||
|
||
SAVECHAR: PROCEDURE BYTE;
|
||
/* READ CHARACTER AND SAVE IN BUFFER */
|
||
DECLARE I BYTE;
|
||
IF NOERRS THEN
|
||
DO;
|
||
DO WHILE (I := GETSOURCE) = XOFF; XOFFSET = TRUE;
|
||
END;
|
||
HBUFF(HSOURCE) = I;
|
||
IF (HSOURCE := HSOURCE + 1) >= LAST(HBUFF) THEN
|
||
CALL PRINTERR(.('RECORD TOO LONG$'));
|
||
RETURN I;
|
||
END;
|
||
RETURN ENDFILE; /* ON ERROR FLAG */
|
||
END SAVECHAR;
|
||
|
||
DECLARE (M, RL, CS, RT) BYTE,
|
||
LDA ADDRESS; /* LOAD ADDRESS WHICH FOLLOWS : */
|
||
|
||
RDHEX: PROCEDURE BYTE;
|
||
DECLARE H BYTE;
|
||
IF (H := SAVECHAR) - '0' <= 9 THEN
|
||
RETURN H-'0';
|
||
IF H - 'A' > 5 THEN
|
||
CALL PRINTERR(.('INVALID DIGIT$'));
|
||
RETURN H - 'A' + 10;
|
||
END RDHEX;
|
||
|
||
RDBYTE: PROCEDURE BYTE;
|
||
/* READ TWO HEX DIGITS */
|
||
RETURN SHL(RDHEX,4) OR RDHEX;
|
||
END RDBYTE;
|
||
|
||
RDCS: PROCEDURE BYTE;
|
||
/* READ BYTE WITH CHECKSUM */
|
||
RETURN CS := CS + RDBYTE;
|
||
END RDCS;
|
||
|
||
RDADDR: PROCEDURE ADDRESS;
|
||
/* READ DOUBLE BYTE WITH CHECKSUM */
|
||
RETURN SHL(DOUBLE(RDCS),8) OR RDCS;
|
||
END RDADDR;
|
||
|
||
NOERRS = TRUE; /* NO ERRORS DETECTED IN THIS RECORD */
|
||
|
||
/* READ NEXT RECORD */
|
||
/* SCAN FOR THE ':' */
|
||
HSOURCE = 0;
|
||
DO WHILE (CS := SAVECHAR) <> ':';
|
||
HSOURCE = 0;
|
||
IF CS = ENDFILE THEN
|
||
DO; CALL PRINT(.('END OF FILE, CTL-Z',WHAT,'$'));
|
||
IF RDCHAR = ENDFILE THEN RETURN 1;
|
||
ELSE HSOURCE = 0;
|
||
END;
|
||
CALL CKXOFF;
|
||
END;
|
||
|
||
/* ':' FOUND */
|
||
CS = 0;
|
||
IF (RL := RDCS) = 0 THEN /* END OF TAPE */
|
||
DO; DO WHILE (RL := SAVECHAR) <> ENDFILE;
|
||
CALL CKXOFF;
|
||
END;
|
||
IF NOERRS THEN RETURN 1;
|
||
RETURN 2;
|
||
END;
|
||
|
||
/* RECORD LENGTH IS NOT ZERO */
|
||
LDA = RDADDR; /* LOAD ADDRESS */
|
||
|
||
/* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */
|
||
RT = RDCS; /* RECORD TYPE */
|
||
DO WHILE RL <> 0 AND NOERRS; RL = RL - 1;
|
||
M = RDCS;
|
||
/* INCREMENT LA HERE FOR EXACT ADDRESS */
|
||
END;
|
||
|
||
/* CHECK SUM */
|
||
IF CS + RDBYTE <> 0 THEN
|
||
CALL PRINTERR(.('CHECKSUM ERROR$'));
|
||
|
||
CALL CKXOFF;
|
||
IF NOERRS THEN RETURN 0;
|
||
RETURN 2;
|
||
END HEXRECORD;
|
||
|
||
RDTAPE: PROCEDURE;
|
||
/* READ HEX FILE FROM HIGH SPEED READER TO 'HEX' FILE,
|
||
CHECK EACH RECORD FOR VALID DIGITS, AND PROPER CHECKSUM */
|
||
DECLARE (I,A) BYTE;
|
||
DO FOREVER;
|
||
DO WHILE (I := HEXRECORD) <= 1;
|
||
IF NOT (I = 1 AND IGNOR) THEN
|
||
DO A = 1 TO HSOURCE;
|
||
CALL PUTDEST(HBUFF(A-1));
|
||
END;
|
||
CALL PUTDEST(CR); CALL PUTDEST(LF);
|
||
IF I = 1 THEN /* END OF TAPE ENCOUNTERED */
|
||
RETURN;
|
||
END;
|
||
CALL CRLF; HBUFF(HSOURCE) = '$';
|
||
CALL PRINT(.HBUFF);
|
||
CALL PRINT(.('CORRECT ERROR, TYPE RETURN OR CTL-Z$'));
|
||
CALL CRLF;
|
||
IF RDCHAR = ENDFILE THEN RETURN;
|
||
END;
|
||
END RDTAPE;
|
||
|
||
setpswd: procedure;
|
||
declare (i,j) byte;
|
||
j = 23;
|
||
do i = 0 to 7;
|
||
dest.pwnam(i) = dxfcb(j) xor dxfcb(13);
|
||
j = j - 1;
|
||
end;
|
||
dest.pwmode = dxfcb(12);
|
||
end setpswd;
|
||
|
||
SETUPDEST: PROCEDURE;
|
||
call setduser; /* destination user */
|
||
call move(.odest,.dest,(frsize + nsize + 1)); /* save original dest */
|
||
DHEX = EQUAL(.odest.fcb(fext),.('HEX$'));
|
||
CALL MOVEXT(.('$$$'));
|
||
odest.fcb(6) = odest.fcb(6) or 80h;
|
||
call open(.odest); /* try to open destination file */
|
||
if dcnt <> 255 and rol(odest.fcb(8),1) then
|
||
do; odcnt = 255;
|
||
call close(.odest);
|
||
end;
|
||
else
|
||
odcnt = dcnt; /* and save error code */
|
||
if (odcnt = 255) and ((exten and 0fh) <> 0) then /* file exists */
|
||
call error(13,exten,1,.odest); /* but cant open - error */
|
||
|
||
if getpw then /* setup destination password */
|
||
do; call setsuser;
|
||
call move(.source,.dxfcb,fsize);
|
||
call rdxfcb(.dxfcb);
|
||
if dcnt = 255 then dest.pwnam(0) = 0;
|
||
else call setpswd;
|
||
call setduser;
|
||
end;
|
||
|
||
CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */
|
||
if dcnt = 255 and exten <> 0 then
|
||
/* cant delete temp file */
|
||
call error(18,exten,1,.dest);
|
||
CALL MAKE(.DEST); /* CREATE A NEW ONE */
|
||
IF DCNT = 255 THEN
|
||
if (exten and 0fh) = 0 then
|
||
call error(17,0,1,.dest); /* no directory space */
|
||
else call error(9,exten,1,.dest); /* make file error */
|
||
call setcuser; /* back to current user */
|
||
DEST.FCB(32),NDEST = 0;
|
||
END SETUPDEST;
|
||
|
||
SETUPSOURCE: PROCEDURE;
|
||
HARDEOF = 0FFFFH;
|
||
f1,f2,f3,f4,ro,sys = 0;
|
||
CALL SETSUSER; /* SOURCE USER */
|
||
source.fcb(6) = source.fcb(6) or 80h;
|
||
CALL OPEN(.SOURCE); /* open source in r/o mode */
|
||
if rol(source.fcb(1),1) then f1 = 80h;
|
||
if rol(source.fcb(2),1) then f2 = 80h;
|
||
if rol(source.fcb(3),1) then f3 = 80h;
|
||
if rol(source.fcb(4),1) then f4 = 80h;
|
||
if rol(source.fcb(9),1) then ro = 80h;
|
||
if rol(source.fcb(10),1) then sys = 80h;
|
||
CALL SETCUSER; /* BACK TO CURRENT USER */
|
||
IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN
|
||
/* skip system file */
|
||
DCNT = 255;
|
||
IF DCNT = 255 THEN
|
||
if (exten and 0fh) = 0 then
|
||
call error(10,0,0,.source); /* file not found */
|
||
else call error(13,exten,1,.source); /* open file error */
|
||
SOURCE.FCB(32) = 0;
|
||
/* CAUSE IMMEDIATE READ */
|
||
SCOM = EQUAL(.SOURCE.FCB(FEXT),.('COM$'));
|
||
NSOURCE = SBLEN;
|
||
END SETUPSOURCE;
|
||
|
||
CK$STRINGS: PROCEDURE;
|
||
IF STARTS > 0 THEN
|
||
call error(11,0,0,0); /* START NOT FOUND */
|
||
IF QUITS > 0 THEN
|
||
call error(12,0,0,0); /* QUIT NOT FOUND */
|
||
END CK$STRINGS;
|
||
|
||
CLOSEDEST: PROCEDURE;
|
||
DO WHILE (LOW(NDEST) AND 7FH) <> 0;
|
||
CALL PUTDEST(ENDFILE);
|
||
END;
|
||
CALL CK$STRINGS;
|
||
CALL WRITEDEST;
|
||
call setduser; /* destination user */
|
||
CALL CLOSE(.DEST);
|
||
IF DCNT = 255 THEN
|
||
call error(14,exten,1,.dest); /* CLOSE FILE */
|
||
IF odcnt <> 255 THEN /* FILE EXISTS */
|
||
DO;
|
||
call close(.odest);
|
||
IF ROL(odest.fcb(9),1) THEN /* READ ONLY */
|
||
DO;
|
||
IF NOT WRROF THEN
|
||
DO;
|
||
CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)?$'));
|
||
IF UTRAN(RDCHAR) <> 'Y' THEN
|
||
DO; CALL PRINT(.('**NOT DELETED**$'));
|
||
CALL CRLF;
|
||
CALL DELETE(.DEST);
|
||
call setcuser; /* back to current user */
|
||
RETURN;
|
||
END;
|
||
CALL CRLF;
|
||
END;
|
||
END;
|
||
/* reset r/o and sys attributes */
|
||
odest.fcb(9) = odest.fcb(9) and 7fh;
|
||
odest.fcb(10) = odest.fcb(10) AND 7FH;
|
||
CALL SETIND(.odest);
|
||
CALL DELETE(.odest);
|
||
END;
|
||
CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */
|
||
CALL RENAME(.DEST);
|
||
/* set destination attributes same as source */
|
||
odest.fcb(1) = (odest.fcb(1) and 07fh) or f1;
|
||
odest.fcb(2) = (odest.fcb(2) and 07fh) or f2;
|
||
odest.fcb(3) = (odest.fcb(3) and 07fh) or f3;
|
||
odest.fcb(4) = (odest.fcb(4) and 07fh) or f4;
|
||
odest.fcb(8) = (odest.fcb(8) and 07fh);
|
||
odest.fcb(9) = (odest.fcb(9) and 07fh) or ro;
|
||
odest.fcb(10) = (odest.fcb(10) and 07fh) or sys;
|
||
odest.fcb(11) = (odest.fcb(11) and 07fh);
|
||
call setind(.odest);
|
||
if archiv then /* set archive bit */
|
||
do; call setsuser;
|
||
source.fcb(11) = source.fcb(11) or 080h;
|
||
source.fcb(12) = 0;
|
||
call setind(.source);
|
||
end;
|
||
call setcuser; /* back to current user */
|
||
END CLOSEDEST;
|
||
|
||
SIZE$NBUF: PROCEDURE;
|
||
/* COMPUTE NUMBER OF BUFFERS - 1 FROM DBLEN */
|
||
NBUF = (SHR(DBLEN,7) AND 0FFH) - 1;
|
||
/* COMPUTED AS DBLEN/128-1, WHERE DBLEN <= 32K (AND THUS
|
||
NBUF RESULTS IN A VALUE <= 2**15/2**7-1 = 2**8-1 = 255) */
|
||
END SIZE$NBUF;
|
||
|
||
SET$DBLEN: PROCEDURE;
|
||
/* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
|
||
SBASE = .MEMORY;
|
||
IF DBLEN >= 4000H THEN DBLEN = 7F80H;
|
||
ELSE DBLEN = DBLEN + SBLEN;
|
||
CALL SIZE$NBUF;
|
||
END SET$DBLEN;
|
||
|
||
SIZE$MEMORY: PROCEDURE;
|
||
/* SET UP SOURCE AND DESTINATION BUFFERS */
|
||
SBASE = .MEMORY + SHR(MEMSIZE - .MEMORY,1);
|
||
SBLEN, DBLEN = SHR((MEMSIZE - .MEMORY) AND 0FF00H,1);
|
||
CALL SIZE$NBUF;
|
||
END SIZE$MEMORY;
|
||
|
||
COPYCHAR: PROCEDURE;
|
||
/* PERFORM THE ACTUAL COPY FUNCTION */
|
||
DECLARE RESIZED BYTE; /* TRUE IF SBUFF AND DBUFF COMBINED */
|
||
IF (RESIZED := (BLOCK AND PSOURCE <> 0)) THEN /* BLOCK MODE */
|
||
CALL SET$DBLEN; /* ABSORB SOURCE BUFFER */
|
||
IF HEXT OR IGNOR THEN /* HEX FILE */
|
||
CALL RDTAPE;
|
||
ELSE
|
||
DO WHILE NOT RD$EOF;
|
||
CALL PUTDEST(CHAR);
|
||
END;
|
||
IF RESIZED THEN
|
||
DO; CALL CLEARBUFF;
|
||
CALL SIZE$MEMORY;
|
||
END;
|
||
END COPYCHAR;
|
||
|
||
SIMPLECOPY: PROCEDURE;
|
||
DECLARE I BYTE;
|
||
|
||
REAL$EOF: PROCEDURE BYTE;
|
||
RETURN HARDEOF <> 0FFFFH;
|
||
END REALEOF;
|
||
|
||
CALL SIZE$MEMORY;
|
||
CALL SETUPDEST;
|
||
CALL SETUPSOURCE;
|
||
/* FILES READY FOR DIRECT COPY */
|
||
FASTCOPY = TRUE;
|
||
/* LOOK FOR PARAMETERS */
|
||
DO I = 0 TO 25;
|
||
IF CONT(I) <> 0 THEN
|
||
DO;
|
||
IF NOT(I=6 OR I=10 OR I=14 OR I=17 OR I=21 OR I=22) THEN
|
||
/* NOT OBJ OR VERIFY */
|
||
FASTCOPY = FALSE;
|
||
END;
|
||
END;
|
||
IF FASTCOPY THEN /* COPY DIRECTLY TO DBUFF */
|
||
DO; CALL SET$DBLEN; /* EXTEND DBUFF */
|
||
DO WHILE NOT REAL$EOF;
|
||
CALL FILLSOURCE;
|
||
IF REAL$EOF THEN NDEST = HARDEOF;
|
||
ELSE NDEST = tblen;
|
||
CALL WRITEDEST;
|
||
END;
|
||
CALL SIZE$MEMORY; /* RESET TO TWO BUFFERS */
|
||
END;
|
||
ELSE
|
||
CALL COPYCHAR;
|
||
call setsuser;
|
||
CALL CLOSE(.SOURCE);
|
||
call setcuser;
|
||
CALL CLOSEDEST;
|
||
END SIMPLECOPY;
|
||
|
||
MULTCOPY: PROCEDURE;
|
||
DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS;
|
||
|
||
PRNAME: PROCEDURE;
|
||
/* PRINT CURRENT FILE NAME */
|
||
DECLARE (I,C) BYTE;
|
||
CALL CRLF;
|
||
DO I = 1 TO FNSIZE;
|
||
IF (C := odest.fcb(I)) <> ' ' THEN
|
||
DO; IF I = FEXT THEN CALL PRINTCHAR('.');
|
||
CALL PRINTCHAR(C);
|
||
END;
|
||
END;
|
||
END PRNAME;
|
||
|
||
archck: procedure byte;
|
||
/* check if archive bit is set in any extent of source file */
|
||
call setsuser;
|
||
source.fcb(12) = what;
|
||
call search(.source);
|
||
do while dcnt <> 255;
|
||
call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),15);
|
||
if not rol(source.fcb(11),1) then
|
||
do; source.fcb(12) = 0;
|
||
call setcuser;
|
||
return 1;
|
||
end;
|
||
call searchn;
|
||
end;
|
||
call setcuser;
|
||
return 0;
|
||
end archck;
|
||
|
||
/* initialize counters if not error retry */
|
||
if eretry = 0 then NEXTDIR, NCOPIED = 0;
|
||
|
||
DO FOREVER;
|
||
/* FIND A MATCHING ENTRY */
|
||
CALL SETSUSER; /* SOURCE USER */
|
||
CALL SETDMA(.BUFF);
|
||
searfcb(12) = 0;
|
||
CALL SEARCH(.SEARFCB);
|
||
NDCNT = 0;
|
||
DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR;
|
||
NDCNT = NDCNT + 1;
|
||
CALL SEARCHN;
|
||
END;
|
||
CALL SETCUSER;
|
||
/* FILE CONTROL BLOCK IN BUFFER */
|
||
IF DCNT = 255 THEN
|
||
DO; IF NCOPIED = 0 THEN
|
||
call error(10,0,0,.searfcb); /* file not found */
|
||
CALL CRLF;
|
||
RETURN;
|
||
END;
|
||
NEXTDIR = NDCNT + 1;
|
||
/* GET THE FILE CONTROL BLOCK NAME TO DEST */
|
||
CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15);
|
||
CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */
|
||
if not archiv or archck then
|
||
do; odest.fcb(12) = 0;
|
||
IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */
|
||
DO; if not kilds then /* kill display option */
|
||
do; IF NCOPIED = 0 THEN
|
||
CALL PRINT(.('COPYING -$'));
|
||
CALL PRNAME;
|
||
end;
|
||
ncopied = ncopied + 1;
|
||
CALL SIMPLECOPY;
|
||
END;
|
||
end;
|
||
END;
|
||
END MULTCOPY;
|
||
|
||
CK$DISK: PROCEDURE;
|
||
/* error if same user and same disk */
|
||
IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN
|
||
CALL FORMERR;
|
||
END CK$DISK;
|
||
|
||
CK$EOL: PROCEDURE;
|
||
CALL DEBLANK;
|
||
IF CHAR <> CR THEN CALL FORMERR;
|
||
END CK$EOL;
|
||
|
||
SCANDEST: PROCEDURE(COPYFCB);
|
||
DECLARE COPYFCB ADDRESS;
|
||
CALL CK$EOL;
|
||
CALL MOVE(.source.fcb(1),COPYFCB,35);
|
||
CALL CK$DISK;
|
||
END SCANDEST;
|
||
|
||
SCANEQL: PROCEDURE;
|
||
CALL SCAN(.SOURCE);
|
||
IF NOT (TYPE = SPECL AND CHAR = '=') THEN CALL FORMERR;
|
||
END SCANEQL;
|
||
|
||
|
||
PIPENTRY:
|
||
/* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED
|
||
FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */
|
||
CALL MOVE(.BUFF,.COMLEN,80H);
|
||
MULTCOM = COMLEN = 0;
|
||
|
||
if multcom then
|
||
do; call printx(.('MP/M II PIP VERSION 2.0$'));
|
||
call crlf;
|
||
end;
|
||
|
||
/* GET CURRENT CP/M VERSION */
|
||
IF CVERSION < VERSION THEN
|
||
DO;
|
||
CALL PRINT(.('REQUIRES MP/M II$'));
|
||
CALL BOOT;
|
||
END;
|
||
CUSER = GETUSER; /* GET CURRENT USER */
|
||
CDISK = getdisk; /* GET CURRENT DISK */
|
||
call errmode(255); /* set return error mode */
|
||
eretry = 0;
|
||
|
||
RETRY:
|
||
/* ENTER HERE ON ERROR EXIT FROM THE PROCEDURE 'ERROR' */
|
||
if eretry <> 0 then
|
||
do; call multcopy;
|
||
comlen = multcom;
|
||
end;
|
||
CALL SIZE$MEMORY;
|
||
/* MAIN PROCESSING LOOP. PROCESS UNTIL CR ONLY */
|
||
DO FOREVER;
|
||
C1, C2, C3 = 0; /* LINE COUNT = 000000 */
|
||
PUTNUM = TRUE; /* ACTS LIKE LF OCCURRED ON ASCII FILE */
|
||
CONCNT,COLUMN = 0; /* PRINTER TABS */
|
||
LINENO = 254; /* INCREMENTED TO 255 > PAGCNT */
|
||
/* READ FROM CONSOLE IF NOT A ONELINER */
|
||
IF MULTCOM THEN
|
||
DO; CALL PRINTCHAR('*'); CALL RDCOM;
|
||
CALL CRLF;
|
||
END;
|
||
CBP = 255;
|
||
IF COMLEN = 0 THEN /* SINGLE CARRIAGE RETURN */
|
||
CALL BOOT; /* normal exit from pip here */
|
||
|
||
/* LOOK FOR SPECIAL CASES FIRST */
|
||
PSOURCE,PDEST = 0;
|
||
fastcopy = false;
|
||
getpw = true;
|
||
CALL SCAN(.odest);
|
||
IF TYPE = PERIPH THEN GO TO SIMPLECOM;
|
||
IF TYPE = DISKNAME THEN
|
||
DO;
|
||
CALL SCANEQL;
|
||
CALL SCAN(.SOURCE);
|
||
/* MAY BE MULTI COPY */
|
||
IF TYPE <> FILE THEN CALL FORMERR;
|
||
IF AMBIG THEN /* FORM IS A:=B:AFN */
|
||
DO; searfcb(0) = source.fcb(0);
|
||
CALL SCANDEST(.searfcb(1));
|
||
CALL MULTCOPY;
|
||
END;
|
||
ELSE
|
||
DO; CALL SCANDEST(.odest.fcb(1));
|
||
/* FORM IS A:=B:UFN */
|
||
CALL SIMPLECOPY;
|
||
END;
|
||
GO TO ENDCOM;
|
||
END;
|
||
|
||
IF TYPE <> FILE OR AMBIG THEN CALL FORMERR;
|
||
CALL SCANEQL;
|
||
CALL SCAN(.SOURCE);
|
||
IF TYPE = DISKNAME THEN
|
||
DO;
|
||
CALL CK$DISK;
|
||
call move(.odest.fcb(1),.source.fcb(1),(frsize + nsize));
|
||
CALL CK$EOL;
|
||
CALL SIMPLECOPY;
|
||
GO TO ENDCOM;
|
||
END;
|
||
/* MAY BE POSSIBLE TO DO A FAST DISK COPY */
|
||
IF TYPE = FILE THEN /* FILE TO FILE */
|
||
DO; CALL DEBLANK;
|
||
IF CHAR <> CR THEN GO TO SIMPLECOM;
|
||
/* FILE TO FILE */
|
||
CALL SIMPLECOPY;
|
||
GO TO ENDCOM;
|
||
END;
|
||
|
||
SIMPLECOM:
|
||
CBP = 255; /* READY FOR RESCAN */
|
||
|
||
/* OTHERWISE PROCESS SIMPLE REQUEST */
|
||
CALL SCAN(.odest);
|
||
IF (TYPE < FILE) OR AMBIG THEN /* DELIMITER OR ERROR */
|
||
call error(3,0,0,0); /* invalid destination */
|
||
|
||
DHEX = FALSE;
|
||
IF TYPE = FILE THEN
|
||
DO; /* DESTINATION IS A FILE, SAVE EXTENT NAME */
|
||
CALL SETUPDEST;
|
||
CHAR = 255;
|
||
END;
|
||
ELSE /* PERIPHERAL NAME */
|
||
IF CHAR >= NULP OR CHAR <= RDR THEN
|
||
call error(3,0,0,0); /* invalid destination */
|
||
IF (PDEST := CHAR + 1) = PUNP THEN
|
||
CALL NULLS;
|
||
/* NOW SCAN THE DELIMITER */
|
||
CALL SCAN(.SOURCE);
|
||
IF TYPE <> SPECL OR CHAR <> '=' THEN
|
||
call formerr; /* invalid format */
|
||
|
||
/* OTHERWISE SCAN AND COPY UNTIL CR */
|
||
COPYING = TRUE;
|
||
DO WHILE COPYING;
|
||
CALL SCAN(.SOURCE);
|
||
SCOM = FALSE;
|
||
IF TYPE = FILE AND NOT AMBIG THEN /* A SOURCE FILE */
|
||
DO;
|
||
CALL SETUPSOURCE;
|
||
CHAR = 255;
|
||
END;
|
||
ELSE IF TYPE <> PERIPH OR (CHAR <= LST AND CHAR > RDR) THEN
|
||
call error(4,0,0,0); /* invalid source */
|
||
|
||
SCOM = SCOM OR OBJ; /* MAY BE ABSOLUTE COPY */
|
||
PSOURCE = CHAR + 1;
|
||
IF CHAR = NULP THEN CALL NULLS;
|
||
ELSE IF CHAR = EOFP THEN
|
||
CALL PUTDEST(ENDFILE);
|
||
ELSE
|
||
DO; /* DISK COPY */
|
||
IF (CHAR < HSRDR AND DHEX) THEN HEXT = 1;
|
||
/* HEX FILE SET IF SOURCE IS RDR AND DEST IS HEX FILE */
|
||
|
||
if (pdest = 10 or pdest = 11) then /* periph = prn or lst */
|
||
do;
|
||
if conatlst = 255 then
|
||
call error(15,0,0,0); /* printer busy */
|
||
IF PDEST = PRNT THEN
|
||
DO; NUMB = 1;
|
||
IF TABS = 0 THEN TABS = 8;
|
||
IF PAGCNT = 0 THEN PAGCNT = 1;
|
||
END;
|
||
end;
|
||
CALL COPYCHAR;
|
||
END;
|
||
|
||
CALL CK$STRINGS;
|
||
/* READ ENDFILE, GO TO NEXT SOURCE */
|
||
if type = file then
|
||
do;
|
||
call setsuser;
|
||
call close(.source);
|
||
call setcuser;
|
||
end;
|
||
CALL SCAN(.SOURCE);
|
||
IF TYPE <> SPECL OR (CHAR <> ',' AND CHAR <> CR) THEN
|
||
call error(16,0,0,0); /* invalid separator */
|
||
|
||
COPYING = CHAR <> CR;
|
||
END;
|
||
|
||
/* IF NECESSARY, CLOSE FILE OR PUNCH TRAILER */
|
||
IF PDEST = PUNP THEN
|
||
DO; CALL PUTDEST(ENDFILE); CALL NULLS;
|
||
END;
|
||
IF PDEST = 0 THEN /* FILE HAS TO BE CLOSED AND RENAMED */
|
||
CALL CLOSEDEST;
|
||
|
||
/* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */
|
||
ENDCOM:
|
||
COMLEN = MULTCOM;
|
||
|
||
END; /* DO FOREVER */
|
||
END;
|
||
|
||
|