seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 16:34:07 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/pip.plm
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

1928 lines
57 KiB
Plaintext
Raw Blame History

$title('PERIPHERAL INTERCHANGE PROGRAM')
PIPMOD:
DO;
/* P E R I P H E R A L I N T E R C H A N G E P R O G R A M
COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982
DIGITAL RESEARCH
BOX 579
PACIFIC GROVE, CA
93950
Revised:
17 Jan 80 by Thomas Rolander (MP/M 1.1)
05 Oct 81 by Ray Pedrizetti (MP/M-86 2.0)
18 Dec 81 by Ray Pedrizetti (CP/M-86 1.1)
29 Jun 82 by Ray Pedrizetti (CCP/M-86 3.0)
26 May 1998 John Elliott DRI patch 6 */
/* Command lines used for CMD file generation */
/* (on VAX)
asm86 scd1.a86
asm86 inpout.a86
plm86 pip.plm debug xref optimize(3)
link86 scd1.obj,inpout.obj,pip.obj, to pip.lnk
loc86 pip.lnk od(sm(code,dats,data,const,stack)) -
ad(sm(code(0), dats(10000h))) ss(stack(+32)) to pip.
h86 pip
(on a micro)
vax pip.h86 $fans
gencmd pip data[b1000 m280 xfff]
* note the beginning of the data segment will change when
* the program is changed. see the 'MP2' file generated
* by LOC86. the constants are last to force hex generation
*/
/* Compiler Directives */
/** $set (mpm) **/
/** $reset (cpm3) **/
/** $cond **/
declare /* resets stack for error handling */
reset label external;
DECLARE
MAXB ADDRESS EXTERNAL, /* ADDR FIELD OF JMP BDOS */
FCB (33) BYTE EXTERNAL, /* DEFAULT FILE CONTROL BLOCK */
BUFF(128)BYTE EXTERNAL; /* DEFAULT BUFFER */
declare
retry byte initial(0); /* true if error has occured */
OUTD: PROCEDURE(B) external;
DECLARE B BYTE;
/* SEND B TO OUT: DEVICE */
END OUTD;
INPD: PROCEDURE BYTE external;
END INPD;
MON1: PROCEDURE(F,A) EXTERNAL;
DECLARE F BYTE,
A ADDRESS;
END MON1;
MON2: PROCEDURE(F,A) BYTE EXTERNAL;
DECLARE F BYTE,
A ADDRESS;
END MON2;
MON3: PROCEDURE(F,A) ADDRESS EXTERNAL;
DECLARE F BYTE,
A ADDRESS;
END MON3;
plm: procedure public;
DECLARE
/** $if mpm **/
VERSION LITERALLY '0031H', /* REQUIRED FOR BDOS 3.1 OPERATION */
/** $else **/
/** $endif **/
ENDFILE LITERALLY '1AH'; /* END OF FILE MARK */
DECLARE COPYRIGHT(*) BYTE DATA (
/** $if cpm3 **/
' (12/06/82) CP/M 3 PIP VERS 3.0 ');
/** $else **/
/** $endif **/
/* LITERAL DECLARATIONS */
DECLARE
LIT LITERALLY 'LITERALLY',
LPP LIT '60', /* LINES PER PAGE */
TAB LIT '09H', /* HORIZONTAL TAB */
FF LIT '0CH', /* FORM FEED */
LA LIT '05FH', /* LEFT ARROW */
LB LIT '05BH', /* LEFT BRACKET */
RB LIT '05DH', /* RIGHT BRACKET */
FSIZE LIT '33',
FRSIZE LIT '36', /* SIZE OF RANDOM FCB */
NSIZE LIT '8',
FNSIZE LIT '11',
FEXT LIT '9',
FEXTL LIT '3',
/* scanner return type code */
outt LIT '0', /* output device */
PRNT LIT '1', /* PRINTER */
LSTT LIT '2', /* list device */
axot lit '3', /* auxilary output device */
FILE LIT '4', /* file type */
auxt lit '5', /* auxilary input/output device */
CONS LIT '6', /* CONSOLE */
axit LIT '7', /* auxilary input device */
inpt lit '8', /* input device */
NULT LIT '9', /* nul characters */
EOFT LIT '10', /* EOF character */
ERR LIT '11', /* error type */
SPECL LIT '12', /* special character */
DISKNAME LIT '13'; /* diskname letter */
DECLARE
SEARFCB LIT 'FCB'; /* SEARCH FCB IN MULTI COPY */
DECLARE
TRUE LIT '1',
FALSE LIT '0',
FOREVER LIT 'WHILE TRUE',
cntrlc lit '3',
CR LIT '13',
LF LIT '10',
WHAT LIT '63';
/** $if mpm **/
declare
maxmcnt lit '128', /* maximum multi sector count */
maxmbuf lit '16384'; /* maximum multi sector buffer size */
/** $endif **/
DECLARE
COLUMN BYTE, /* COLUMN COUNT FOR PRINTER TABS */
LINENO BYTE, /* LINE WITHIN PAGE */
FEEDBASE BYTE, /* USED TO FEED SEARCH CHARACTERS */
FEEDLEN BYTE, /* LENGTH OF FEED STRING */
MATCHLEN BYTE, /* USED IN MATCHING STRINGS */
QUITLEN BYTE, /* USED TO TERMINATE QUIT COMMAND */
CDISK BYTE, /* CURRENT DISK */
SBLEN ADDRESS, /* SOURCE BUFFER LENGTH */
DBLEN ADDRESS, /* DEST BUFFER LENGTH */
tblen address, /* temp buffer length */
SBASE ADDRESS, /* SOURCE BUFFER BASE */
/* THE VECTORS DBUFF AND SBUFF ARE DECLARED WITH DIMENSION
1024, BUT ACTUALLY VARY WITH THE FREE MEMORY SIZE */
DBUFF(1024) BYTE AT (.MEMORY), /* DESTINATION BUFFER */
SBUFF BASED SBASE (1024) BYTE, /* SOURCE BUFFER */
/* source fcb, password and password mode */
source structure (
fcb(frsize) byte,
/** $if mpm **/
pwnam(nsize) byte,
pwmode byte,
/** $endif **/
user byte,
type byte ),
/* temporary destination fcb, password and password mode */
dest structure (
fcb(frsize) byte,
/** $if mpm **/
pwnam(nsize) byte,
pwmode byte,
/** $endif **/
user byte,
type byte ),
/* original destination fcb, password and password mode */
odest structure (
fcb(frsize) byte,
/** $if mpm **/
pwnam(nsize) byte,
pwmode byte,
/** $endif **/
user byte,
type byte ),
filsize(3) byte, /* file size random record number */
DESTR ADDRESS AT(.DEST.FCB(33)), /* RANDOM RECORD POSITION */
SOURCER ADDRESS AT(.SOURCE.FCB(33)), /* RANDOM RECORD POSITION */
DESTR2 BYTE AT(.DEST.FCB(35)), /* RANDOM RECORD POSITION R2 */
SOURCER2 BYTE AT(.SOURCE.FCB(35)), /* RANDOM RECORD POSITION R2 */
extsave byte, /* temp extent byte for bdos bug */
nsbuf address, /* next source buffer */
/** $if mpm **/
bufsize address, /* multsect buffer size */
mseccnt byte, /* last multi sector count value */
/** $endif **/
NSOURCE ADDRESS, /* NEXT SOURCE CHARACTER */
NDEST ADDRESS; /* NEXT DESTINATION CHARACTER */
DECLARE
fastcopy byte, /* true if copy directly to dbuf */
dblbuf byte, /* true if both source and dest buffer used */
concat byte, /* true if concatination command */
ambig byte, /* true if file is ambig type */
dfile byte, /* true if dest is file type */
sfile byte, /* true if source is file type */
made byte, /* true if destination file already made */
opened byte, /* true if source file open */
endofsrc byte, /* true if end of source file */
nendcmd byte, /* true if not end of command tail */
insparc byte, /* true if in middle of sparce file */
sparfil byte, /* true if sparce file being copied */
MULTCOM BYTE, /* true if processing multiple commands */
PUTNUM BYTE, /* SET WHEN READY FOR NEXT LINE NUM */
CONCNT BYTE, /* COUNTER FOR CONSOLE READY CHECK */
CHAR BYTE, /* LAST CHARACTER SCANNED */
FLEN BYTE; /* FILE NAME LENGTH */
declare
f1 byte, /* f1 user attribute flag */
f2 byte, /* f2 user attribute flag */
f3 byte, /* f3 user attribute flag */
f4 byte, /* f4 user attribute flag */
ro byte, /* read only attribute flag */
sys byte, /* system attribute flag */
/** $if mpm **/
exten byte, /* extention error code */
odcnt byte, /* saves dcnt for open dest file */
eretry byte, /* error return flag */
/** $endif **/
dcnt byte; /* error code or directory code */
DECLARE CBUFF(130) BYTE, /* COMMAND BUFFER */
MAXLEN BYTE AT (.CBUFF(0)), /* MAX BUFFER LENGTH */
COMLEN BYTE AT (.CBUFF(1)), /* CURRENT LENGTH */
COMBUFF(128) BYTE AT (.CBUFF(2)), /* COMMAND BUFFER CONTENTS */
CBP BYTE; /* COMMAND BUFFER POINTER */
DECLARE
CUSER BYTE, /* CURRENT USER NUMBER */
last$user byte;
DECLARE /* CONTROL TOGGLE VECTOR */
CONT(26) BYTE, /* ONE FOR EACH ALPHABETIC */
/* 00 01 02 03 04 05 06 07 08 09 10 11 12 13
A B C D E F G H I J K L M N
14 15 16 17 18 19 20 21 22 23 24 25
O P Q R S T U V W X Y Z */
archiv byte at(.cont(0)), /* file archive */
confrm byte at(.cont(2)), /* confirm copy */
DELET BYTE AT(.CONT(3)), /* DELETE CHARACTERS */
ECHO BYTE AT(.CONT(4)), /* ECHO CONSOLE CHARACTERS */
FORMF BYTE AT(.CONT(5)), /* FORM FILTER */
GETU BYTE AT(.CONT(6)), /* GET FILE, USER # */
HEXT BYTE AT(.CONT(7)), /* HEX FILE TRANSFER */
IGNOR BYTE AT(.CONT(8)), /* IGNORE :00 RECORD ON FILE */
kilds byte at(.cont(10)), /* kill filename display */
LOWER BYTE AT(.CONT(11)), /* TRANSLATE TO LOWER CASE */
NUMB BYTE AT(.CONT(13)), /* NUMBER OUTPUT LINES */
OBJ BYTE AT(.CONT(14)), /* OBJECT FILE TRANSFER */
PAGCNT BYTE AT(.CONT(15)), /* PAGE LENGTH */
QUITS BYTE AT(.CONT(16)), /* QUIT COPY */
RSYS BYTE AT(.CONT(17)), /* READ SYSTEM FILES */
STARTS BYTE AT(.CONT(18)), /* START COPY */
TABS BYTE AT(.CONT(19)), /* TAB SET */
UPPER BYTE AT(.CONT(20)), /* UPPER CASE TRANSLATE */
VERIF BYTE AT(.CONT(21)), /* VERIFY EQUAL FILES ONLY */
WRROF BYTE AT(.CONT(22)), /* WRITE TO R/O FILE */
ZEROP BYTE AT(.CONT(25)); /* ZERO PARITY ON INPUT */
DECLARE ZEROSUP BYTE, /* ZERO SUPPRESSION */
(C3,C2,C1) BYTE; /* LINE COUNT ON PRINTER */
/** $if mpm **/
retcodes: procedure(a);
declare a address;
dcnt = low(a);
exten = high(a);
end retcodes;
/** $endif **/
BOOT: PROCEDURE;
/* SYSTEM REBOOT */
CALL MON1(0,0);
END BOOT;
RDCHAR: PROCEDURE BYTE;
/* READ CONSOLE CHARACTER */
RETURN MON2(1,0);
END RDCHAR;
PRINTCHAR: PROCEDURE(CHAR);
DECLARE CHAR BYTE;
CALL MON1(2,CHAR AND 7FH);
END PRINTCHAR;
CRLF: PROCEDURE;
CALL PRINTCHAR(CR);
CALL PRINTCHAR(LF);
END CRLF;
printx: procedure(a);
declare a address;
call mon1(9,a);
end printx;
PRINT: PROCEDURE(A);
DECLARE A ADDRESS;
/* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
NEXT DOLLAR SIGN IS ENCOUNTERED */
CALL CRLF;
CALL printx(A);
END PRINT;
RDCOM: PROCEDURE;
/* READ INTO COMMAND BUFFER */
MAXLEN = 128;
CALL MON1(10,.MAXLEN);
END RDCOM;
CVERSION: PROCEDURE ADDRESS;
RETURN MON3(12,0); /* VERSION NUMBER */
END CVERSION;
SETDMA: PROCEDURE(A);
DECLARE A ADDRESS;
CALL MON1(26,A);
END SETDMA;
/** $if mpm **/
setpw: procedure(fcba);
declare fcba address;
declare fcbs based fcba structure (
fcb(frsize) byte,
pwnam(nsize) byte );
call setdma(.fcbs.pwnam(0));
end setpw;
/** $endif **/
OPEN: PROCEDURE(fcba);
DECLARE fcba ADDRESS;
declare fcb based fcba (frsize) byte;
/** $if mpm **/
CALL SETPW(fcba);
call retcodes(mon3(15,fcba));
/** $else **/
/** $endif **/
if dcnt <> 255 and rol(fcb(8),1) then
do; call mon1(16,fcba);
dcnt = 255;
/** $if mpm **/
exten = 0;
/** $endif **/
end;
END OPEN;
CLOSE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(MON3(16,FCB));
/** $else **/
/** $endif **/
END CLOSE;
SEARCH: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(MON3(17,FCB));
/** $else **/
/** $endif **/
END SEARCH;
SEARCHN: PROCEDURE;
/** $if mpm **/
call retcodes(MON3(18,0));
/** $else **/
/** $endif **/
END SEARCHN;
DELETE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
CALL SETPW(FCB);
call retcodes(MON3(19,FCB));
/** $else **/
/** $endif **/
END DELETE;
DISKRD: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(MON3(20,FCB));
/** $else **/
/** $endif **/
END DISKRD;
DISKWRITE: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(MON3(21,FCB));
/** $else **/
/** $endif **/
END DISKWRITE;
MAKE: procedure(fcba);
declare fcba address;
/** $if mpm **/
declare fcbs based fcba structure (
fcb(frsize) byte,
pwnam(nsize) byte );
if fcbs.pwnam(0) = 0 then /* zero if no password */
fcbs.fcb(6) = fcbs.fcb(6) and 7fh; /* reset password attribute */
else do;
fcbs.fcb(6) = fcbs.fcb(6) or 80h; /* set password attribute */
call setdma(.fcbs.pwnam(0)); /* set password dma */
end;
call retcodes(mon3(22,fcba));
/** $else **/
/** $endif **/
END MAKE;
RENAME: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
CALL SETPW(FCB);
call retcodes(MON3(23,FCB)) ;
/** $else **/
/** $endif **/
END RENAME;
getdisk: procedure byte;
return mon2(25,0);
end getdisk;
SETIND: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(MON3(30,FCB));
/** $else **/
/** $endif **/
END SETIND;
GETUSER: PROCEDURE BYTE;
RETURN MON2(32,0FFH);
END GETUSER;
SETUSER: PROCEDURE(USER);
DECLARE USER BYTE;
if last$user <> user then
CALL MON1(32,(last$user:=USER));
END SETUSER;
SETCUSER: PROCEDURE;
CALL SETUSER(CUSER);
END SETCUSER;
setduser: procedure;
call setuser(odest.user);
end setduser;
SETSUSER: PROCEDURE;
CALL SETUSER(source.user);
END SETSUSER;
RD$RANDOM: PROCEDURE(FCB) BYTE;
DECLARE FCB ADDRESS;
/** $if mpm **/
call retcodes(mon3(33,fcb));
/** $else **/
/** $endif **/
return dcnt;
END RD$RANDOM;
write$random: procedure(fcb) byte;
declare fcb address;
/** $if mpm **/
call retcodes(mon3(34,fcb));
/** $else **/
/** $endif **/
return dcnt;
end write$random;
retfsize: procedure(fcb) byte;
declare fcb address;
return mon2(35,fcb);
end retfsize;
SET$RANDOM: PROCEDURE(FCB);
DECLARE FCB ADDRESS;
/* SET RANDOM RECORD POSITION */
CALL MON1(36,FCB);
END SET$RANDOM;
/** $if mpm **/
multsect: procedure(cnt);
declare cnt byte;
if mseccnt <> cnt then
call mon1(44,(mseccnt := cnt));
end multsect;
flushbuf: procedure;
call mon1(48, 0ffh); /* 0FFH = flush and discard buffers */
end flushbuf;
conatlst: procedure byte;
return mon2(161,0);
end conatlst;
/** $endif **/
MOVE: PROCEDURE(S,D,N);
DECLARE (S,D) ADDRESS, N BYTE;
DECLARE A BASED S BYTE, B BASED D BYTE;
DO WHILE (N:=N-1) <> 255;
B = A; S = S+1; D = D+1;
END;
END MOVE;
/* errtype error messages */
declare er00(*) byte data ('DISK READ$');
declare er01(*) byte data ('DISK WRITE$');
declare er02(*) byte data ('VERIFY$');
declare er03(*) byte data ('INVALID DESTINATION$');
declare er04(*) byte data ('INVALID SOURCE$');
declare er05(*) byte data ('USER ABORTED$');
declare er06(*) byte data ('BAD PARAMETER$');
declare er07(*) byte data ('INVALID USER NUMBER$');
declare er08(*) byte data ('INVALID FORMAT$');
declare er09(*) byte data ('HEX RECORD CHECKSUM$');
declare er10(*) byte data ('FILE NOT FOUND$');
declare er11(*) byte data ('START NOT FOUND$');
declare er12(*) byte data ('QUIT NOT FOUND$');
declare er13(*) byte data ('INVALID HEX DIGIT$');
declare er14(*) byte data ('CLOSE FILE$');
declare er15(*) byte data ('UNEXPECTED END OF HEX FILE$');
declare er16(*) byte data ('INVALID SEPARATOR$');
declare er17(*) byte data ('NO DIRECTORY SPACE$');
declare er18(*) byte data ('INVALID FORMAT WITH SPARCE FILE$');
/** $if mpm **/
declare er19(*) byte data ('MAKE FILE$');
declare er20(*) byte data ('OPEN FILE$');
declare er21(*) byte data ('PRINTER BUSY$');
declare er22(*) byte data ('CAN''T DELETE TEMP FILE$');
/** $endif **/
declare errmsg(*) address data(
.er00,.er01,.er02,.er03,.er04,
.er05,.er06,.er07,.er08,.er09,
.er10,.er11,.er12,.er13,.er14,
.er15,.er16,.er17,.er18
/** $if mpm **/
,.er19,.er20,.er21,.er22
/** $endif **/
);
declare sper00(*) byte data ('NO DIRECTORY SPACE$');
declare sper01(*) byte data ('NO DATA BLOCK$');
declare sper02(*) byte data ('CAN''T CLOSE CURRENT EXTENT$');
declare sper03(*) byte data ('SEEK TO UNWRITTEN EXTENT$');
declare sper05(*) byte data ('RANDOM RECORD OUT OF RANGE$');
declare sper06(*) byte data ('RECORDS DON''T MATCH$');
declare sper07(*) byte data ('RECORD LOCKED$');
declare sper08(*) byte data ('INVALID FILENAME$');
declare sper09(*) byte data ('FCB CHECKSUM$');
declare numspmsgs lit '10'; /* number of extended messages */
declare special$msg(numspmsgs) address data(
.sper00,.sper01,.sper02,.sper03,.sper00,
.sper05,.sper06,.sper07,.sper08,.sper09);
/** $if mpm **/
/* extended error messages */
declare ex00(*) byte data ('$'); /* NO MESSAGE */
declare ex01(*) byte data ('NONRECOVERABLE$');
declare ex02(*) byte data ('R/O DISK$');
declare ex03(*) byte data ('R/O FILE$');
declare ex04(*) byte data ('INVALID DISK SELECT$');
declare ex05(*) byte data ('INCOMPATIBLE MODE$');
declare ex07(*) byte data ('INVALID PASSWORD$');
declare ex08(*) byte data ('ALREADY EXISTS$');
declare ex10(*) byte data ('LIMIT EXCEEDED$');
declare nummsgs lit '11'; /* number of extended messages */
declare extmsg(nummsgs) address data(
.ex00,.ex01,.ex02,.ex03,.ex04,
.ex05,.sper09,.ex07,.ex08,.sper08,
.ex10);
/** $endif **/
error$cleanup: procedure;
/** $if mpm **/
call multsect(1);
/** $endif **/
eretry = 0; /* initialize to no error retry */
if opened then /* if source file opened */
do; call setsuser;
call close(.source);
opened = false;
end;
if made then
do; call setduser;
call close(.dest);
call delete(.dest); /* delete destination scratch file */
end;
/* Zero the command length in case this is a single command */
comlen = 0;
retry = true;
call print(.('ERROR: $'));
end error$cleanup;
error: procedure (errtype);
declare errtype byte;
call error$cleanup;
call printx(errmsg(errtype));
call crlf;
go to reset;
end error;
xerror: procedure (funcno,fileadr);
declare temp byte,
i byte,
sdcnt byte,
sexten byte,
funcno byte,
fileadr address,
fcb based fileadr (fsize) byte;
declare message$index$tbl(17) byte data
(2,18,13,15,9,3,10,20,14,10,22,17,19,0,1,0,1);
sdcnt = dcnt;
sexten = exten;
call error$cleanup;
if (funcno < 6) or (sdcnt <> 0ffh) then
sexten = 0;
else sexten = sexten and 0fh;
call printx(errmsg(message$index$tbl(funcno)));
if (funcno > 12) and (funcno < 17) and
(sdcnt <> 0ffh) and (sdcnt <= numspmsgs) then
do; call printchar(' ');
call printx(special$msg(sdcnt-1));
sexten = 0;
end;
/** $if mpm **/
if sexten < nummsgs then
do; call printchar(' ');
call printx(extmsg(sexten));
end;
/** $endif **/
call printx(.(' - $'));
if fileadr <> 0 then
do; call printchar('A' + fcb(0) - 1);
call printchar(':');
do i = 1 to fnsize;
if (temp := fcb(i) and 07fh) <> ' ' then
do; if i = fext then call printchar('.');
call printchar(temp);
end;
end;
end;
call crlf;
if (sdcnt = 3) or (sdcnt = 4) or (sdcnt = 6) or (sdcnt = 8) then
eretry = ambig;
else
if (sexten = 3) or ((sexten > 4) and (sexten < 9)) or (sexten > 9) then
eretry = ambig;
go to reset;
end xerror;
FORMERR: PROCEDURE;
call error(8); /* invalid format */
END FORMERR;
CONBRK: PROCEDURE;
/* CHECK CONSOLE CHARACTER READY */
if mon2(11,0) <> 0 then
if mon2(6,0fdh) = cntrlc then
call error(5);
END CONBRK;
MAXSIZE: procedure byte;
/* three byte compare of random record field
returns true if source.fcb.ranrec >= filesize */
if (source.fcb(35) < filsize(2)) then
return false;
if (source.fcb(35) = filsize(2)) then
do;
if (source.fcb(34) < filsize(1)) then
return false;
if (source.fcb(34) = filsize(1)) then
do;
if (source.fcb(33) < filsize(0)) then
return false;
end;
end;
return true;
end maxsize;
SETUPDEST: PROCEDURE;
call setduser; /* destination user */
/** $if mpm **/
call move(.odest,.dest,(frsize + nsize + 1)); /* save original dest */
/** $else **/
/** $endif **/
/* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
CALL MOVE(.('$$$'),.DEST.FCB(FEXT),FEXTL);
/** $if mpm **/
odest.fcb(6) = odest.fcb(6) or 80h;
call open(.odest); /* try to open destination file */
odcnt = dcnt; /* and save error code */
if odcnt <> 255 then
call close(.odest);
else if (exten and 0fh) <> 0 then /* file exists */
call xerror(7,.odest); /* but can't open - error */
CALL DELETE(.DEST); /* REMOVE OLD $$$ FILE */
if dcnt = 255 and exten <> 0 then
/* cant delete temp file */
call xerror(10,.dest);
CALL MAKE(.DEST); /* CREATE A NEW ONE */
IF DCNT = 255 THEN
if (exten and 0fh) = 0 then
call xerror(11,.dest); /* no directory space */
else call xerror(12,.dest); /* make file error */
/** $else **/
/** $endif **/
DEST.FCB(32) = 0;
made = true;
END SETUPDEST;
SETUPSOURCE: PROCEDURE;
declare (i,j) byte;
CALL SETSUSER; /* SOURCE USER */
/** $if mpm **/
source.fcb(6) = source.fcb(6) or 80h;
/** $endif **/
CALL OPEN(.SOURCE); /* open source */
if dcnt <> 255 then
opened = true;
IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN
/* skip system file */
DCNT = 255;
IF DCNT = 255 THEN
/** $if mpm **/
if (exten and 0fh) = 0 then
call xerror(6,.source); /* file not found */
else
call xerror(7,.source); /* open file error */
/** $else **/
/** $endif **/
f1 = source.fcb(1) and 80h; /* save file atributes */
f2 = source.fcb(2) and 80h;
f3 = source.fcb(3) and 80h;
f4 = source.fcb(4) and 80h;
ro = source.fcb(9) and 80h;
sys = source.fcb(10) and 80h;
dcnt = retfsize(.source);
call move(.source.fcb(33),.filsize,3);
SOURCE.FCB(32) = 0;
source.fcb(33),source.fcb(34),source.fcb(35) = 0;
/* cause immediate read with no preceding write */
NSOURCE = 0ffffh;
END SETUPSOURCE;
WRITEDEST: PROCEDURE;
/* WRITE OUTPUT BUFFERS UP TO BUT NOT INCLUDING POSITION
NDEST - THE LOW ORDER 7 BITS OF NDEST ARE ZERO */
DECLARE (J,DATAOK) BYTE,
(tdest,n) address;
if not made then call setupdest;
if (n := ndest and 0ff80h) = 0 then return;
tdest = 0;
call setduser; /* destination user */
if (sparfil := (sparfil or insparc)) then
/* set up fcb from random record no. */
do;
/** $if mpm **/
call multsect(1);
/** $endif **/
CALL SETDMA(.dbuff(tdest));
if write$random(.dest) <> 0 then
call xerror(16,.dest); /* DISK WRITE ERROR */
end;
else
CALL SETRANDOM(.DEST); /* SET BASE RECORD FOR VERIFY */
/** $if mpm **/
if fastcopy then
do; bufsize = maxmbuf;
call multsect(maxmcnt);
end;
else
do; bufsize = 128;
call multsect(1);
end;
/** $endif **/
do while n - tdest > 127;
/** $if mpm **/
if fastcopy and (n - tdest < maxmbuf) then
do; bufsize = n - tdest;
call multsect(low(shr(bufsize,7)));
end;
/** $endif **/
/* SET DMA ADDRESS TO NEXT BUFFER */
CALL SETDMA(.dbuff(tdest));
call diskwrite(.dest);
IF dcnt <> 0 THEN
call xerror(14,.dest); /* DISK WRITE ERROR */
/** $if mpm **/
tdest = tdest + bufsize;
/** $else **/
/** $endif **/
END;
IF VERIF THEN /* VERIFY DATA WRITTEN OK */
DO;
call flushbuf;
tdest = 0;
/** $if mpm **/
call multsect(1);
/** $endif **/
CALL SETDMA(.BUFF); /* FOR COMPARE */
do while tdest < n;
DATAOK = (RDRANDOM(.DEST) = 0);
if (DESTR := DESTR + 1) = 0 then /* 3 byte inc for */
destr2 = destr2 + 1; /* next random record */
J = 0;
/* PERFORM COMPARISON */
DO WHILE DATAOK AND J < 80H;
DATAOK = (BUFF(J) = DBUFF(tdest+J));
J = J + 1;
END;
tdest = tdest + 128;
IF NOT DATAOK THEN
call xerror(0,.dest); /* VERIFY ERROR */
END;
call diskrd(.dest);
/* NOW READY TO CONTINUE THE WRITE OPERATION */
END;
CALL SETRANDOM(.DEST); /* set base record for sparce copy */
call move(.dbuff(tdest),.dbuff(0),low(ndest := ndest - tdest));
END WRITEDEST;
FILLSOURCE: PROCEDURE;
/* FILL THE SOURCE BUFFER */
call conbrk;
/** $if mpm **/
if fastcopy then
do; bufsize = maxmbuf;
call multsect(maxmcnt);
end;
else do;
bufsize = 128;
call multsect(1);
end;
/** $endif **/
CALL SETSUSER; /* SOURCE USER NUMBER SET */
nsource = nsbuf;
do while sblen - nsbuf > 127;
if fastcopy and (sblen - nsbuf < maxmbuf) then
do; bufsize = (sblen - nsbuf) and 0ff80h;
call multsect(low(shr(bufsize,7)));
end;
/* SET DMA ADDRESS TO NEXT BUFFER POSIITION */
CALL SETDMA(.SBUFF(nsbuf));
extsave = source.fcb(12); /* save extent field */
call diskrd(.source);
IF dcnt <> 0 THEN
DO; IF dcnt <> 1 THEN
call xerror(13,.source); /* DISK READ ERROR */
/* END - OF - FILE */
/** $if mpm **/
if fastcopy then /* add no. sectors copied */
nsbuf = nsbuf + shl(double(exten),7);
/* nsbuf = nsbuf + shl(double(exten and 0f0h),3); */
/** $endif **/
/* check boundry condition for bug in bdos and correct */
if (source.fcb(12) <> extsave) and (source.fcb(32) = 80h) then
source.fcb(32) = 0; /* zero current record */
call set$random(.source);
if (insparc := not maxsize) then
do;
if concat or (not fastcopy) then
/* invalid format with sparce file */
call xerror(1,.source);
end;
else
do;
call close(.source);
opened = false;
end;
endofsrc = true; /* set end of source file */
SBUFF(nsbuf) = ENDFILE; return;
END;
ELSE
/** $if mpm **/
nsbuf = nsbuf + bufsize;
/** $else **/
/** $endif **/
END;
END FILLSOURCE;
PUTDCHAR: PROCEDURE(B);
DECLARE B BYTE;
/* WRITE BYTE B TO THE DESTINATION DEVICE GIVEN BY ODEST.TYPE */
IF B >= ' ' THEN
DO; COLUMN = COLUMN + 1;
IF DELET > 0 THEN /* MAY BE PAST RIGHT SIDE */
DO; IF COLUMN > DELET THEN RETURN;
END;
END;
if echo then call mon1(2,b); /* echo to console */
do case odest.type;
/* CASE 0 IS OUT */
CALL OUTD(B);
/* CASE 1 IS PRN, TABS EXPANDED, LINES LISTED */
call mon1(5,b);
/* CASE 2 IS LST */
CALL MON1(5,B);
/* CASE 3 IS axo */
axocase:
/** $if not mpm **/
CALL MON1(4,B);
/** $else **/
/** $endif **/
/* CASE 4 IS DESTINATION FILE */
DO;
IF NDEST >= DBLEN THEN CALL WRITEDEST;
DBUFF(NDEST) = B;
NDEST = NDEST+1;
END;
/* CASE 5 IS AUX */
goto axocase;
/* CASE 6 IS CON */
CALL MON1(2,B);
END; /* of case */
END PUTDCHAR;
PUTDESTC: PROCEDURE(B);
DECLARE (B,I) BYTE;
/* WRITE DESTINATION CHARACTER, TAB EXPANSION */
IF B <> TAB THEN CALL PUTDCHAR(B);
ELSE IF TABS = 0 THEN CALL PUTDCHAR(B);
ELSE /* B IS TAB CHAR, TABS > 0 */
DO; I = COLUMN;
DO WHILE I >= TABS;
I = I - TABS;
END;
I = TABS - I;
DO WHILE I > 0;
I = I - 1;
CALL PUTDCHAR(' ');
END;
END;
IF B = CR THEN COLUMN = 0;
END PUTDESTC;
PRINT1: PROCEDURE(B);
DECLARE B BYTE;
IF (ZEROSUP := ZEROSUP AND B = 0) THEN
CALL PUTDESTC(' ');
ELSE
CALL PUTDESTC('0'+B);
END PRINT1;
PRINTDIG: PROCEDURE(D);
DECLARE D BYTE;
CALL PRINT1(SHR(D,4)); CALL PRINT1(D AND 1111B);
END PRINTDIG;
NEWLINE: PROCEDURE;
DECLARE ONE BYTE;
ONE = 1;
ZEROSUP = (NUMB = 1);
C1 = DEC(C1+ONE); C2 = DEC(C2 PLUS 0); C3 = DEC(C3 PLUS 0);
CALL PRINTDIG(C3); CALL PRINTDIG(C2); CALL PRINTDIG(C1);
IF NUMB = 1 THEN /* USUALLY PRINTER OUTPUT */
DO; CALL PUTDESTC(':'); CALL PUTDESTC(' ');
END;
ELSE
CALL PUTDESTC(TAB);
END NEWLINE;
PUTDEST: PROCEDURE(B);
DECLARE (I,B) BYTE;
/* WRITE DESTINATION CHARACTER, CHECK TABS AND LINES */
IF FORMF THEN /* SKIP FORM FEEDS */
DO; IF B = FF THEN RETURN;
END;
IF PUTNUM THEN /* END OF LINE OR START OF FILE */
DO;
IF (B <> FF) and (b <> endfile) THEN
DO; /* NOT FORM FEED or end of file */
IF (I:=PAGCNT) <> 0 THEN /* PAGE EJECT */
DO; IF I=1 THEN I=LPP;
IF (LINENO := LINENO + 1) >= I THEN
DO; LINENO = 0; /* NEW PAGE */
CALL PUTDESTC(FF);
END;
END;
IF NUMB > 0 THEN
CALL NEWLINE;
PUTNUM = FALSE;
END;
END;
IF B = FF THEN LINENO = 0;
CALL PUTDESTC(B);
IF B = LF THEN PUTNUM = TRUE;
END PUTDEST;
UTRAN: PROCEDURE(B) BYTE;
DECLARE B BYTE;
/* TRANSLATE ALPHA TO UPPER CASE */
IF B >= 110$0001B AND B <= 111$1010B THEN /* LOWER CASE */
B = B AND 101$1111B; /* TO UPPER CASE */
RETURN B;
END UTRAN;
LTRAN: PROCEDURE(B) BYTE;
DECLARE B BYTE;
/* TRANSLATE TO LOWER CASE ALPHA */
IF B >= 'A' AND B <= 'Z' THEN
B = B OR 10$0000B; /* TO LOWER */
RETURN B;
END LTRAN;
GETSOURCEC: PROCEDURE BYTE;
/* READ NEXT SOURCE CHARACTER */
DECLARE (B,CONCHK) BYTE;
CONCHK = TRUE; /* CONSOLE STATUS CHECK BELOW */
DO CASE source.type;
/* CASE 0 IS out */
go to notsource;
/* CASE 1 IS prn */
go to notsource;
/* CASE 2 IS lst */
notsource:
call error(4); /* INVALID SOURCE */
/* CASE 3 IS axo */
go to notsource;
/* CASE 4 IS SOURCE FILE */
DO;
IF NSOURCE >= SBLEN THEN
do; if dblbuf or (not dfile) then
nsbuf = 0;
else if (nsource <> 0ffffh) then
do; call writedest;
nsbuf = ndest;
end;
CALL FILLSOURCE;
end;
B = SBUFF(NSOURCE);
NSOURCE = NSOURCE + 1;
END;
/* CASE 5 IS AUX */
goto axicase;
/* CASE 6 IS CON */
DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
B = MON2(1,0);
END;
/* CASE 7 IS axi */
axicase:
/** $if not mpm **/
B = MON2(3,0) AND 7FH;
/** $else **/
/** $endif **/
/* CASE 7 IS INP */
B = INPD;
END; /* OF CASES */
IF CONCHK THEN /* TEST FOR CONSOLE CHAR READY */
DO;
IF obj THEN /* SOURCE IS AN OBJECT FILE */
CONCHK = ((CONCNT := CONCNT + 1) = 0);
ELSE /* ASCII */
CONCHK = (B = LF);
IF CONCHK THEN
DO;
call CONBRK;
END;
END;
IF ZEROP THEN B = B AND 7FH;
IF UPPER THEN RETURN UTRAN(B);
IF LOWER THEN RETURN LTRAN(B);
RETURN B;
END GETSOURCEC;
GETSOURCE: PROCEDURE BYTE;
/* GET NEXT SOURCE CHARACTER */
DECLARE CHAR BYTE;
MATCH: PROCEDURE(B) BYTE;
/* MATCH START AND QUIT STRINGS */
DECLARE (B,C) BYTE;
IF (C:=COMBUFF(B:=(B+MATCHLEN))) = ENDFILE THEN /* END MATCH */
DO; COMBUFF(B) = CHAR; /* SAVE CURRENT CHARACTER */
RETURN TRUE;
END;
IF C = CHAR THEN MATCHLEN = MATCHLEN + 1;
ELSE
MATCHLEN = 0; /* NO MATCH */
RETURN FALSE;
END MATCH;
IF QUITLEN > 0 THEN
DO; IF (QUITLEN := QUITLEN - 1) = 1 THEN RETURN LF;
RETURN ENDFILE; /* TERMINATED WITH CR,LF,ENDFILE */
END;
DO FOREVER; /* LOOKING FOR START */
IF FEEDLEN > 0 THEN /* GET SEARCH CHARACTERS */
DO; FEEDLEN = FEEDLEN - 1;
CHAR = COMBUFF(FEEDBASE);
FEEDBASE = FEEDBASE + 1;
RETURN CHAR;
END;
IF (CHAR := GETSOURCEC) = ENDFILE THEN RETURN ENDFILE;
IF STARTS > 0 THEN /* LOOKING FOR START STRING */
DO; IF MATCH(STARTS) THEN
DO; FEEDBASE = STARTS; STARTS = 0;
FEEDLEN = MATCHLEN + 1;
matchlen = 0;
END; /* OTHERWISE NO MATCH, SKIP CHARACTER */
END;
ELSE IF QUITS > 0 THEN /* PASS CHARACTERS TIL MATCH */
DO; IF MATCH(QUITS) THEN
DO; QUITS = 0; QUITLEN = 2;
/* SUBSEQUENTLY RETURN CR, LF, ENDFILE */
RETURN CR;
END;
RETURN CHAR;
END;
ELSE
RETURN CHAR;
END; /* OF DO FOREVER */
END GETSOURCE;
RD$EOF: PROCEDURE BYTE;
/* RETURN TRUE IF END OF FILE */
CHAR = GETSOURCE;
IF obj THEN RETURN (endofsrc and (nsource > nsbuf));
RETURN (CHAR = ENDFILE);
END RD$EOF;
HEXRECORD: PROCEDURE;
DECLARE (h, hbuf, RL, CS, RT) BYTE,
zerorec byte, /* true if last record had length of zero */
LDA ADDRESS; /* LOAD ADDRESS WHICH FOLLOWS : */
ckhex: procedure byte;
IF H - '0' <= 9 THEN
RETURN H-'0';
IF H - 'A' > 5 THEN
CALL xerror(2,.source); /* invalid hex digit */
RETURN H - 'A' + 10;
end ckhex;
rdhex: procedure byte;
call putdest(h := getsource);
return ckhex;
end rdhex;
RDCS: PROCEDURE BYTE;
/* READ BYTE WITH CHECKSUM */
RETURN CS := CS + (SHL(RDHEX,4) OR RDHEX);
END RDCS;
RDADDR: PROCEDURE ADDRESS;
/* READ DOUBLE BYTE WITH CHECKSUM */
RETURN SHL(DOUBLE(RDCS),8) OR RDCS;
END RDADDR;
/* READ HEX FILE AND CHECK EACH RECORD
FOR VALID DIGITS, AND PROPER CHECKSUM */
zerorec = false;
/* READ NEXT RECORD */
h = getsource;
do forever;
/* SCAN FOR THE ':' */
DO WHILE h <> ':';
IF (h = ENDFILE) THEN
do; if zerorec then return;
CALL xerror(3,.source); /* unexpected end of hex file */
end;
call putdest(h);
h = getsource;
END;
/* ':' FOUND */
/* check for end of hex record */
h = getsource;
rl = shl(ckhex,4);
hbuf = h; h = getsource;
rl = rl or ckhex;
if (rl = 0) then zerorec = true;
else zerorec = false;
if (zerorec and ignor) then
do while (h <> ':') and (h <> endfile);
h = getsource;
end;
else do; call putdest(':');
call putdest(hbuf);
call putdest(h);
cs = rl;
LDA = RDADDR; /* LOAD ADDRESS */
/* READ WORDS UNTIL RECORD LENGTH EXHAUSTED */
RT = RDCS; /* RECORD TYPE */
DO WHILE RL <> 0; RL = RL - 1;
hbuf = RDCS;
/* INCREMENT LA HERE FOR EXACT ADDRESS */
END;
/* CHECK SUM */
IF rdcs <> 0 THEN
CALL xerror(4,.source); /* hex record checksum */
h = getsource;
end;
end; /* do forever */
END HEXRECORD;
CK$STRINGS: PROCEDURE;
IF STARTS > 0 THEN
call error(11); /* START NOT FOUND */
IF QUITS > 0 THEN
call error(12); /* QUIT NOT FOUND */
END CK$STRINGS;
CLOSEDEST: PROCEDURE;
DO WHILE (LOW(NDEST) AND 7FH) <> 0;
CALL PUTDEST(ENDFILE);
END;
CALL CK$STRINGS;
CALL WRITEDEST;
call setduser; /* destination user */
CALL CLOSE(.DEST);
IF DCNT = 255 THEN
/** $if mpm **/
call xerror(8,.dest); /* CLOSE FILE */
IF odcnt <> 255 THEN /* FILE EXISTS */
do;
/** $else **/
/** $endif **/
IF ROL(odest.fcb(9),1) THEN /* READ ONLY */
DO;
IF NOT WRROF THEN
DO;
do while ((dcnt <> 'Y') and (dcnt <> 'N'));
CALL PRINT (.('DESTINATION IS R/O, DELETE (Y/N)? $'));
dcnt = utran(rdchar);
end;
IF dcnt <> 'Y' THEN
DO; CALL PRINT(.('**NOT DELETED**$'));
CALL CRLF;
CALL DELETE(.DEST);
RETURN;
END;
CALL CRLF;
END;
END;
/* reset r/o and sys attributes */
odest.fcb(9) = odest.fcb(9) and 7fh;
odest.fcb(10) = odest.fcb(10) AND 7FH;
CALL SETIND(.odest);
CALL DELETE(.odest);
END;
CALL MOVE(.odest.fcb,.dest.fcb(16),16); /* READY FOR RENAME */
CALL RENAME(.DEST);
/* set destination attributes same as source */
odest.fcb(1) = (odest.fcb(1) and 07fh) or f1;
odest.fcb(2) = (odest.fcb(2) and 07fh) or f2;
odest.fcb(3) = (odest.fcb(3) and 07fh) or f3;
odest.fcb(4) = (odest.fcb(4) and 07fh) or f4;
odest.fcb(8) = (odest.fcb(8) and 07fh);
odest.fcb(9) = (odest.fcb(9) and 07fh) or ro;
odest.fcb(10) = (odest.fcb(10) and 07fh) or sys;
odest.fcb(11) = (odest.fcb(11) and 07fh);
call setind(.odest);
if archiv then /* set archive bit */
do; call setsuser;
source.fcb(11) = source.fcb(11) or 080h;
source.fcb(12) = 0;
call setind(.source);
end;
END CLOSEDEST;
SIZE$MEMORY: PROCEDURE;
/* SET UP SOURCE AND DESTINATION BUFFERS */
if not dblbuf then
do; /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
sbase = .memory;
sblen,dblen = ((maxb - .memory) and 0ff80h) - 128;
end;
else do; /* may need to write destination buffer */
sblen,dblen = (shr((maxb - .memory),1) and 0ff80h) - 128;
sbase = .memory + dblen + 128;
if ndest >= dblen then call writedest;
nsbuf = 0;
end;
END SIZE$MEMORY;
setupeob: procedure;
/* sets nsbuf to end of source buffer */
declare i byte;
if (not obj) and (nsbuf <> 0) then
do; tblen = nsbuf - 128;
do i = 0 to 128;
if (sbuff(tblen + i)) = endfile then
do; nsbuf = tblen + i;
return;
end;
end;
end;
end setupeob;
SIMPLECOPY: PROCEDURE;
DECLARE I BYTE;
declare
fast lit '0', /* fast file to file copy */
chrt lit '1', /* character transfer option */
dubl lit '2'; /* double buffer required for file copy */
declare optype(26) byte data (
/* option type for each option character */
fast, /* for A option */
fast, /* for B option */
fast, /* for C option */
dubl, /* for D option */
chrt, /* for E option */
dubl, /* for F option */
fast, /* for G option */
chrt, /* for H option */
dubl, /* for I option */
fast, /* for J option */
fast, /* for K option */
chrt, /* for L option */
fast, /* for M option */
dubl, /* for N option */
fast, /* for O option */
dubl, /* for P option */
dubl, /* for Q option */
fast, /* for R option */
dubl, /* for S option */
dubl, /* for T option */
chrt, /* for U option */
fast, /* for V option */
fast, /* for W option */
fast, /* for X option */
fast, /* for Y option */
chrt); /* for Z option */
chkrandom: procedure;
call setsuser;
call set$random(.source);
/** $if mpm **/
call multsect(1);
/** $endif **/
call setdma(.buff);
do forever;
if (((dcnt := rd$random(.source)) = 0) or maxsize) then
do; destr = sourcer;
destr2 = sourcer2;
endofsrc = false;
return;
end;
if dcnt = 1 then
do; if (sourcer := sourcer + 1) = 0 then
sourcer2 = sourcer2 + 1;
end;
else if dcnt = 4 then
do;
if (sourcer := (sourcer + 128) and 0ff80h) = 0 then
sourcer2 = sourcer2 + 1;
end;
else
call xerror(15,.source);
end;
end chkrandom;
fastcopy = (sfile and dfile);
endofsrc = false;
dblbuf = false;
sparfil = false;
insparc = false;
/* LOOK FOR PARAMETERS */
DO I = 0 TO 25;
IF CONT(I) <> 0 THEN
DO;
IF optype(i) = chrt THEN
FASTCOPY = FALSE;
else
if optype(i) = dubl then
do; dblbuf = (sfile and dfile);
fastcopy = false;
end;
END;
END;
CALL SIZE$MEMORY;
if sfile then
CALL SETUPSOURCE;
/* FILES READY FOR COPY */
if fastcopy then
do while not endofsrc;
CALL FILLSOURCE;
if endofsrc and concat then
do; call setupeob;
ndest = nsbuf;
if nendcmd then return;
end;
ndest = nsbuf;
CALL WRITEDEST;
nsbuf = ndest;
if (endofsrc and insparc) then
call chkrandom;
end;
else do;
/* PERFORM THE ACTUAL COPY FUNCTION */
IF HEXT OR IGNOR THEN /* HEX FILE */
call hexrecord;
ELSE
DO WHILE NOT RD$EOF;
CALL PUTDEST(CHAR);
END;
if concat and nendcmd then
do; nsbuf = ndest;
return;
end;
end;
if dfile then
CALL CLOSEDEST;
END SIMPLECOPY;
MULTCOPY: PROCEDURE;
DECLARE (NEXTDIR, NDCNT, NCOPIED) ADDRESS;
PRNAME: PROCEDURE;
/* PRINT CURRENT FILE NAME */
DECLARE (I,C) BYTE;
CALL CRLF;
DO I = 1 TO FNSIZE;
IF (C := odest.fcb(I)) <> ' ' THEN
DO; IF I = FEXT THEN CALL PRINTCHAR('.');
CALL PRINTCHAR(C);
END;
END;
END PRNAME;
archck: procedure byte;
/* check if archive bit is set in any extent of source file */
if not archiv then
return 1;
call setsuser;
source.fcb(12) = what;
call search(.source);
do while dcnt <> 255;
/* [JCE] Patch 6: the last parameter on this line was 15 */
call move(.buff+shl(dcnt and 11b,5)+1,.source.fcb(1),11);
if not rol(source.fcb(11),1) then
return 1;
call searchn;
end;
return 0;
end archck;
/** $if mpm **/
/* initialize counters if not error retry */
if eretry = 0 then NEXTDIR, NCOPIED = 0;
/** $else **/
/** $endif **/
DO FOREVER;
/* FIND A MATCHING ENTRY */
CALL SETSUSER; /* SOURCE USER */
CALL SETDMA(.BUFF);
searfcb(12) = 0;
CALL SEARCH(.SEARFCB);
NDCNT = 0;
DO WHILE (DCNT <> 255) AND NDCNT < NEXTDIR;
NDCNT = NDCNT + 1;
CALL SEARCHN;
END;
/* FILE CONTROL BLOCK IN BUFFER */
IF DCNT = 255 THEN
DO; IF NCOPIED = 0 THEN
call xerror(9,.searfcb); /* file not found */
if not kilds then
CALL CRLF;
RETURN;
END;
NEXTDIR = NDCNT + 1;
/* GET THE FILE CONTROL BLOCK NAME TO DEST */
CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.odest.fcb(1),15);
CALL MOVE(.odest.fcb(1),.SOURCE.FCB(1),15); /* FILL BOTH FCB'S */
if archck then
do; odest.fcb(12) = 0;
source.fcb(12) = 0;
IF RSYS OR NOT ROL(odest.fcb(10),1) THEN /* OK TO READ */
DO; if not kilds then /* kill display option */
do; IF NCOPIED = 0 THEN
CALL PRINT(.('COPYING -$'));
dcnt = false;
do while ((dcnt <> 'Y') and (dcnt <> 'N'));
call prname;
if confrm then
do; call printx(.(' (Y/N)? $'));
dcnt = utran(rdchar);
end;
else
dcnt = 'Y';
end;
end;
ncopied = ncopied + 1;
made = false; /* destination file not made */
if (dcnt = 'Y') or (kilds) then
CALL SIMPLECOPY;
END;
end;
END;
END MULTCOPY;
CK$DISK: PROCEDURE;
/* error if same user and same disk */
IF (odest.user = source.user) and (odest.fcb(0) = source.fcb(0)) THEN
CALL FORMERR;
END CK$DISK;
GNC: PROCEDURE BYTE;
IF (CBP := CBP + 1) >= COMLEN THEN RETURN CR;
RETURN UTRAN(COMBUFF(CBP));
END GNC;
DEBLANK: PROCEDURE;
DO WHILE (CHAR := GNC) = ' ';
END;
END DEBLANK;
CK$EOL: PROCEDURE;
CALL DEBLANK;
IF CHAR <> CR THEN CALL FORMERR;
END CK$EOL;
SCAN: PROCEDURE(FCBA);
DECLARE FCBA ADDRESS, /* ADDRESS OF FCB TO FILL */
fcbs based fcba structure ( /* FCB STRUCTURE */
fcb(frsize) byte,
/** $if mpm **/
pwnam(nsize) byte,
pwmode byte,
/** $endif **/
user byte,
type byte );
DECLARE (I,K) BYTE; /* TEMP COUNTERS */
/* SCAN LOOKS FOR THE NEXT DELIMITER, DEVICE NAME, OR FILE NAME.
THE VALUE OF CBP MUST BE 255 UPON ENTRY THE FIRST TIME */
DELIMITER: PROCEDURE(C) BYTE;
DECLARE (I,C) BYTE;
DECLARE DEL(*) BYTE DATA
(' =.:;,<>',CR,LA,LB,RB);
DO I = 0 TO LAST(DEL);
IF C = DEL(I) THEN RETURN TRUE;
END;
RETURN FALSE;
END DELIMITER;
PUTCHAR: PROCEDURE;
FCBS.FCB(FLEN:=FLEN+1) = CHAR;
IF CHAR = WHAT THEN AMBIG = TRUE; /* CONTAINS AMBIGUOUS REF */
END PUTCHAR;
FILLQ: PROCEDURE(LEN);
/* FILL CURRENT NAME OR TYPE WITH QUESTION MARKS */
DECLARE LEN BYTE;
CHAR = WHAT; /* QUESTION MARK */
DO WHILE FLEN < LEN;
CALL PUTCHAR;
END;
END FILLQ;
SCANPAR: PROCEDURE;
DECLARE (I,J) BYTE;
/* SCAN OPTIONAL PARAMETERS */
CHAR = GNC; /* SCAN PAST BRACKET */
DO WHILE NOT(CHAR = CR OR CHAR = RB);
IF (I := CHAR - 'A') > 25 THEN /* NOT ALPHA */
DO; IF CHAR = ' ' THEN
CHAR = GNC;
ELSE
call error(6); /* BAD PARAMETER */
END;
ELSE
DO; /* SCAN PARAMETER VALUE */
IF CHAR = 'S' OR CHAR = 'Q' THEN
DO; /* START OR QUIT COMMAND */
J = CBP + 1; /* START OF STRING */
DO WHILE NOT ((CHAR := GNC) = ENDFILE OR CHAR = CR);
END;
CHAR=GNC;
END;
ELSE IF (J := (CHAR := GNC) - '0') > 9 THEN
J = 1;
ELSE
DO WHILE (K := (CHAR := GNC) - '0') <= 9;
J = J * 10 + K;
END;
CONT(I) = J;
IF I = 6 THEN /* SET SOURCE USER */
DO;
IF J > 15 THEN
call error(7); /* INVALID USER NUMBER */
fcbs.user = J;
END;
END;
END;
CHAR = GNC;
END SCANPAR;
/* scan procedure entry point */
/* INITIALIZE FILE CONTROL BLOCK TO EMPTY */
fcbs.type = ERR; CHAR = ' '; FLEN = 0;
/** $if mpm **/
DO WHILE FLEN < (FRSIZE + NSIZE);
IF FLEN = FNSIZE THEN CHAR = 0;
ELSE IF FLEN = FRSIZE THEN CHAR = ' ';
call putchar;
END;
fcbs.pwnam(0) = 0;
fcbs.pwmode = 1;
/** $else **/
/** $endif **/
fcbs.fcb(0) = cdisk +1; /* initialize to current disk */
fcbs.user = cuser; /* and current user */
/* CLEAR PARAMETERS */
DO I = 0 TO 25; CONT(I) = 0;
END;
FEEDLEN,MATCHLEN,QUITLEN = 0;
/* DEBLANK COMMAND BUFFER */
CALL DEBLANK;
/* CHECK PERIPHERALS AND DISK FILES */
/* SCAN NEXT NAME */
DO FOREVER;
FLEN = 0;
DO WHILE NOT DELIMITER(CHAR);
IF FLEN >= NSIZE THEN /* ERROR, FILE NAME TOO LONG */
RETURN;
IF CHAR = '*' THEN CALL FILLQ(NSIZE);
ELSE CALL PUTCHAR;
CHAR = GNC;
END;
/* CHECK FOR DISK NAME OR DEVICE NAME */
IF CHAR = ':' THEN
DO; IF FLEN = 1 THEN
/* MAY BE DISK NAME A ... P */
DO;
IF (fcbs.fcb(0) := fcbs.fcb(1) - 'A' + 1) > 16 THEN
RETURN; /* ERROR, INVALID DISK NAME */
CALL DEBLANK; /* MAY BE DISK NAME ONLY */
IF DELIMITER(CHAR) THEN
DO; IF CHAR = LB THEN
CALL SCANPAR;
CBP = CBP - 1;
fcbs.type = DISKNAME;
RETURN;
END;
END;
ELSE
/* MAY BE A THREE CHARACTER DEVICE NAME */
IF FLEN <> 3 THEN /* ERROR, CANNOT BE DEVICE NAME */
RETURN;
ELSE
/* LOOK FOR DEVICE NAME */
DO; DECLARE (I,J,K) BYTE, M LITERALLY '9',
IO(*) BYTE DATA
('OUTPRNLSTAXO',
0,0,0, /* fake area for file type */
'AUX',
'CONAXIINPNULEOF',0);
J = 255;
DO K = 0 TO M;
I = 0;
DO WHILE ((I:=I+1) <= 3) AND
IO(J+I) = fcbs.fcb(I);
END;
IF I = 4 THEN /* COMPLETE MATCH */
DO; fcbs.type = k;
/* SCAN PARAMETERS */
IF GNC = LB THEN CALL SCANPAR;
CBP = CBP - 1;
RETURN;
END;
J = J + 3; /* OTHERWISE TRY NEXT DEVICE */
END;
RETURN; /* ERROR, NO DEVICE NAME MATCH */
END;
IF CHAR = LB THEN /* PARAMETERS FOLLOW */
CALL SCANPAR;
END;
ELSE
/* CHAR IS NOT ':', SO FILE NAME IS SET. SCAN REMAINDER */
DO; IF FLEN = 0 THEN /* ERROR, NO PRIMARY NAME */
RETURN;
FLEN = NSIZE;
IF CHAR = '.' THEN /* SCAN FILE TYPE */
DO WHILE NOT DELIMITER(CHAR := GNC);
IF FLEN >= FNSIZE THEN
RETURN; /* ERROR, TYPE FIELD TOO LONG */
IF CHAR = '*' THEN CALL FILLQ(FNSIZE);
ELSE CALL PUTCHAR;
END;
/** $if mpm **/
FLEN = 0;
IF CHAR = ';' THEN /* SCAN PASSWORD */
DO WHILE NOT DELIMITER(CHAR := GNC);
IF FLEN >= NSIZE THEN
/* ERROR, PW TOO LONG */ RETURN;
ELSE /* SAVE PASSWORD */
FCBS.PWNAM(FLEN) = CHAR;
FLEN = FLEN + 1;
END;
/** $endif **/
IF CHAR = LB THEN
CALL SCANPAR;
/* RESCAN DELIMITER NEXT TIME AROUND */
CBP = CBP - 1;
fcbs.type = FILE;
FCBS.FCB(32) = 0;
RETURN;
END;
END;
END SCAN;
/* PLM (PIP) ENTRY POINT */
/* BUFFER AT 80H CONTAINS REMAINDER OF LINE TYPED
FOLLOWING THE COMMAND 'PIP' - IF ZERO THEN PROMPT TIL CR */
if not retry then
do; CALL MOVE(.BUFF,.COMLEN,80H);
MULTCOM = (COMLEN = 0);
/* GET CURRENT CP/M VERSION */
IF low(CVERSION) < VERSION THEN
DO;
/** $if cpm3 **/
CALL PRINT(.('REQUIRES CP/M 3$'));
/** $else **/
/** $endif **/
CALL BOOT;
END;
call mon1(45,255); /* set return error mode */
/** $if cpm3 **/
call mon1(109,1); /* set CP/M 3 control-C status mode */
/** $endif **/
if multcom then
do;
/** $if cpm3 **/
call printx(.('CP/M 3 PIP VERSION 3.0$'));
/** $else **/
/** $endif **/
call crlf;
end;
cuser,last$user = getuser; /* GET CURRENT USER */
cdisk = getdisk; /* GET CURRENT DISK */
/** $if mpm **/
mseccnt = 1;
/** $endif **/
eretry = false; /* need to initialize here for first time */
end;
/* START HERE ON RESET EXIT FROM THE PROCEDURE 'ERROR' */
/** $if mpm **/
if eretry <> 0 then
do; call multcopy;
comlen = multcom;
end;
/** $endif **/
/* MAIN PROCESSING LOOP. PROCESS UNTIL CR ONLY */
DO FOREVER;
C1, C2, C3 = 0; /* LINE COUNT = 000000 */
CONCNT,COLUMN = 0; /* PRINTER TABS */
ndest,nsbuf = 0;
ambig = false;
made = false; /* destination file not made */
opened = false; /* source file not opened */
concat = false;
eretry = false;
PUTNUM = TRUE; /* ACTS LIKE LF OCCURRED ON ASCII FILE */
dfile,sfile = true;
nendcmd = true;
LINENO = 254; /* INCREMENTED TO 255 > PAGCNT */
/* READ FROM CONSOLE IF NOT A ONELINER */
IF MULTCOM THEN
DO; CALL PRINTCHAR('*'); CALL RDCOM;
CALL CRLF;
END;
CBP = 255;
IF COMLEN = 0 THEN /* character = <CR> */
do; call setcuser; /* restore current user */
CALL BOOT; /* normal exit from pip here */
end;
/* LOOK FOR SPECIAL CASES FIRST */
CALL SCAN(.odest);
if ambig then
call xerror(5,.odest); /* invalid destination */
call deblank; /* check for equal sign or left arrow */
if (char <> '=') and (char <> la) then call formerr;
call scan(.source);
IF odest.type = DISKNAME THEN
DO;
IF source.type <> file then call formerr;
CALL CK$EOL;
CALL CK$DISK;
odest.type = file; /* set for character transfer */
/* MAY BE MULTI COPY */
IF AMBIG THEN /* FORM IS A:=B:AFN */
DO;
CALL MOVE(.source.fcb(0),.searfcb(0),frsize);
CALL MULTCOPY;
END;
ELSE DO; /* FORM IS A:=B:UFN */
CALL MOVE(.source.fcb(1),.odest.fcb(1),frsize - 1);
CALL SIMPLECOPY;
END;
END;
else IF (odest.type = FILE) and (source.type = DISKNAME) THEN
DO;
CALL CK$EOL;
CALL CK$DISK;
source.type = file; /* set for character transfer */
/** $if mpm **/
call move(.odest.fcb(1),.source.fcb(1),(frsize+nsize));
/** $else **/
/** $endif **/
CALL SIMPLECOPY;
END;
else if (odest.type > cons) then
call error(3); /* invalid destination */
else do;
IF odest.type <> FILE THEN dfile = false;
/** $if not mpm **/
/* no conditional attach list device */
/** $else **/
/** $endif **/
/* SCAN AND COPY UNTIL CR */
DO WHILE nendcmd;
sfile = true;
call deblank;
IF (CHAR <> ',' AND CHAR <> CR) THEN
call error(16); /* invalid separator */
concat = concat or (nendcmd := (char = ','));
IF odest.type = PRNT THEN
DO; NUMB = 1;
IF TABS = 0 THEN TABS = 8;
IF PAGCNT = 0 THEN PAGCNT = 1;
END;
IF (source.type < file) or (source.type > eoft) or ambig THEN
call error(4); /* invalid source */
IF source.type <> FILE THEN /* NOT A SOURCE FILE */
sfile = false;
IF source.type = NULT THEN
/* SEND 40 NULLS TO OUTPUT DEVICE */
DO sfile = 0 TO 39; CALL PUTDEST(0);
END;
ELSE IF source.type = EOFT THEN
CALL PUTDEST(ENDFILE);
else call simplecopy;
CALL CK$STRINGS;
/* READ ENDFILE, GO TO NEXT SOURCE */
if nendcmd then call scan(.source);
END;
end;
/* COMLEN SET TO 0 IF NOT PROCESSING MULTIPLE COMMANDS */
COMLEN = MULTCOM;
END; /* DO FOREVER */
end plm;
END;
EOF
Reference in New Issue View Git Blame Copy Permalink