seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 08:24:18 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
master
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 68K/1.0X SOURCES/v102a/plmutils/pip.sa
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

1596 lines
48 KiB
Plaintext
Raw Permalink Blame History

/*SPLH*/ /*$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
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)
31 JULY 82 BY H.CHAKI (CP/M-68K) */
/* COMMAND LINES USED FOR .68K FILE GENERATION */
/* Command line to generate PIP.68K
[[ assume that the all default VOLUME is SYS:0.. on EXORmacs]]
(1)S-PL/H Compile and ASM on EXORmacs
=SPLH PIP,,;A,S,X,NOV,NOF,MAR=1/80
=ASM PIPSUB,,;A,S,X,NOV,NOF,MAR=1/80
=ASM UT68K,,;
[[ caution ]]
PIP: main routine of PIP utility in S-PL/H
PIPSUB: sub routine of PIP utility in ASM
UT68K: standard interface routine in ASM
A: assemble listing option
S: symbol listing option
X: xref listing option
NOV: non save option
NOF: non floatable option
MAR: margin option [[ important ]]
(2)LINK on EXORmacs
=LINK PIP/PIPSUB/UT68K,PIP68K,PIP68K;MIXRL=SPLHLIB.RO
[[ caution ]]
R option: generate relocatable object
(3)XLINK on EXORmacs
=XLINK PIP68K.RO,PIP68K.OX,O=PIP68K.OL
(4)Convert file on EXORmacs to send to VAX
=CONV PIP68K.OX,PIP68K.OC
(5)Send to VAX from EXORMACS
=VAX
VAX command
S
Source file
PIP68K.OC
(6)Download to CP/M file from VAX
(7)Re-convert file on CP/M
A>RECONV
input file :PIP68K.OC
output file :PIP.68K
end command line */
DECLARE
VERSION LITERALLY '0022H', /* REQUIRED FOR OPERATION */
MVERSION LITERALLY '1130H'; /* FOR MP/M-86 OPERATION */
DECLARE
MAXB POINTER EXTERNAL, /* ADDR FIELD OF JMP BDOS */
/*68K*/ MAXBL LONG AT(@MAXB),
FCB (33) BYTE EXTERNAL, /* DEFAULT FILE CONTROL BLOCK */
BUFF(128)BYTE EXTERNAL; /* DEFAULT BUFFER */
DECLARE
ENDFILE LITERALLY '1AH'; /* END OF FILE MARK */
DECLARE /* MAIN PROGRAM ENTRY LABEL */
PLM LABEL PUBLIC;
DECLARE COPYRIGHT(*) BYTE DATA (
' (7/31/82) CP/M-68K PIP VERS 1.0 ');
/* LITERAL DECLARATIONS */
DECLARE
/*SPLH*/ /* 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 */
CONS LIT '5', /* CONSOLE */
AXIT LIT '6', /* AUXILARY INPUT DEVICE */
INPT LIT '7', /* INPUT DEVICE */
NULT LIT '8', /* NUL CHARACTERS */
EOFT LIT '9', /* EOF CHARACTER */
ERR LIT '10', /* ERROR TYPE */
SPECL LIT '11', /* SPECIAL CHARACTER */
DISKNAME LIT '12'; /* DISKNAME LETTER */
DECLARE
SEARFCB LITERALLY 'FCB'; /* SEARCH FCB IN MULTI COPY */
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 */
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 POINTER, /* SOURCE BUFFER BASE */
/*68K*/ SBASEL LONG AT(@SBASE),
/*SPLH*/ MEMORY (1024) BYTE EXT,
/*SPLH*/ DCHAKIP POINTER,
DCHAKIL LONG AT(@DCHAKIP),
/* 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,
USER BYTE,
TYPE BYTE ),
/* TEMPORARY DESTINATION FCB, PASSWORD AND PASSWORD MODE */
DEST STRUCTURE (
FCB(FRSIZE) BYTE,
USER BYTE,
TYPE BYTE ),
/* ORIGINAL DESTINATION FCB, PASSWORD AND PASSWORD MODE */
ODEST STRUCTURE (
FCB(FRSIZE) BYTE,
USER BYTE,
TYPE BYTE ),
FILSIZE(3) BYTE, /* FILE SIZE RANDOM RECORD NUMBER */
DESTR ADDRESS AT(@DEST.FCB(34)), /* RANDOM RECORD POSITION */
SOURCER ADDRESS AT(@SOURCE.FCB(34)), /* RANDOM RECORD POSITION */
DESTR2 BYTE AT(@DEST.FCB(33)), /* RANDOM RECORD POSITION R2 */
SOURCER2 BYTE AT(@SOURCE.FCB(33)), /* RANDOM RECORD POSITION R2 */
EXTSAVE BYTE, /* TEMP EXTENT BYTE FOR BDOS BUG */
NSBUF ADDRESS, /* NEXT SOURCE BUFFER */
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 FILE ALREADY MADE */
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, /* 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 */
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 */
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 */
DECLARE
CUSER BYTE; /* CURRENT USER NUMBER */
DECLARE
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 */
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 */
DCL DUMMYP POINTER,
DUMMYL LONG AT(@DUMMYP);
DCL DUM1P POINTER,
DUM1L LONG AT(@DUM1P);
DCL DUM2P POINTER,
DUM2L LONG AT(@DUM2P);
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;
/* 68K*/
MON5: PROC(F,A) EXT;
DCL F BYTE,A POINTER;
END;
MON6: PROC(F,A) BYTE EXT;
DCL F BYTE,A POINTER;
END;
MON7: PROC(F,A) ADDR EXT;
DCL F BYTE,A POINTER;
END;
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 POINTER;
CALL MON5(9,A);
END PRINTX;
PRINT: PROCEDURE(A);
DECLARE A POINTER;
/* 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 MON5(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 POINTER;
CALL MON5(26,A);
END SETDMA;
OPEN: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(15,FCB);
END OPEN;
CLOSE: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(16,FCB);
END CLOSE;
CK$USER: PROCEDURE;
DO FOREVER;
IF DCNT = 0FFH THEN RETURN;
IF LAST$USER = BUFF(ROR (DCNT,3) AND 110$0000B)
THEN RETURN;
DCNT = MON2(18,0);
END;
END CK$USER;
SEARCH: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(17,FCB);
CALL CK$USER;
END SEARCH;
SEARCHN: PROCEDURE;
DCNT = MON2(18,0);
CALL CK$USER;
END SEARCHN;
DELETE: PROCEDURE(FCB);
DECLARE FCB POINTER;
CALL MON5(19,FCB);
END DELETE;
DISKRD: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(20,FCB);
END DISKRD;
DISKWRITE: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(21,FCB);
END DISKWRITE;
MAKE: PROCEDURE(FCBA);
DECLARE FCBA POINTER;
DCNT = MON6(22,FCBA);
END MAKE;
RENAME: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(23,FCB);
END RENAME;
GETDISK: PROCEDURE BYTE;
RETURN MON2(25,0);
END GETDISK;
SETIND: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(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 POINTER;
RETURN MON6(33,FCB);
END RD$RANDOM;
WRITE$RANDOM: PROCEDURE(FCB) BYTE;
DECLARE FCB POINTER;
RETURN MON6(34,FCB);
END WRITE$RANDOM;
RETFSIZE: PROCEDURE(FCB) BYTE;
DECLARE FCB POINTER;
RETURN MON6(35,FCB);
END RETFSIZE;
SET$RANDOM: PROCEDURE(FCB);
DECLARE FCB POINTER;
/* SET RANDOM RECORD POSITION */
CALL MON5(36,FCB);
END SET$RANDOM;
MOVE: PROCEDURE(S,D,N);
DECLARE (S,D) POINTER, N BYTE;
DECLARE A BASED DUM1P BYTE, B BASED DUM2P BYTE;
/*68K*/ DUM1P=S; DUM2P=D;
DO WHILE (N:=N-1) <> 255;
/*68K*/ B = A; DUM1L=DUM1L+1; DUM2L=DUM2L+1;
END;
END MOVE;
ERROR: PROCEDURE(ERRTYPE,FILEADR);
DECLARE I BYTE,
TEMP BYTE,
ERRTYPE BYTE,
FILEADR POINTER,
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 ('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 SPARSE FILE$');
DECLARE ERRMSG(*) POINTER DATA(
@ER00,@ER01,@ER02,@ER03,@ER04,
@ER05,@ER06,@ER07,@ER08,@ER09,
@ER10,@ER11,@ER12,@ER13,@ER14,
@ER15,@ER16,@ER17,@ER18);
CALL SETDUSER;
IF MADE THEN
DO; CALL CLOSE(@DEST);
CALL DELETE(@DEST); /* DELETE DESTINATION SCRATCH FILE */
END;
/* PRINT OUT ERROR MESSAGE */
CALL PRINT(@('ERROR: $'));
CALL PRINTX(ERRMSG(ERRTYPE));
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;
CALL CRLF;
GO TO RETRY;
END ERROR;
FORMERR: PROCEDURE;
CALL ERROR(8,0); /* INVALID FORMAT */
END FORMERR;
MAXSIZE: PROCEDURE BYTE;
IF (SOURCE.FCB(35) = FILSIZE(2)) AND
(SOURCE.FCB(34) = FILSIZE(1)) AND
(SOURCE.FCB(33) = FILSIZE(0)) THEN RETURN TRUE;
RETURN FALSE;
END MAXSIZE;
SETUPDEST: PROCEDURE;
CALL SETDUSER; /* DESTINATION USER */
CALL MOVE(@ODEST,@DEST,(FRSIZE + 1)); /* SAVE ORIGINAL DEST */
/* MOVE THREE CHARACTER EXTENT INTO DEST FCB */
CALL MOVE(@('$$$'),@DEST.FCB(FEXT),FEXTL);
CALL DELETE(@DEST); /* REMOVE OLD $$$ FILE */
CALL MAKE(@DEST); /* CREATE A NEW ONE */
IF DCNT = 255 THEN
CALL ERROR(17,@DEST); /* NO DIRECTORY SPACE */
DEST.FCB(32) = 0;
MADE = TRUE;
END SETUPDEST;
SETUPSOURCE: PROCEDURE;
CALL SETSUSER; /* SOURCE USER */
CALL OPEN(@SOURCE); /* OPEN SOURCE */
IF (NOT RSYS) AND ROL(SOURCE.FCB(10),1) THEN
/* SKIP SYSTEM FILE */
DCNT = 255;
IF DCNT = 255 THEN
CALL ERROR(10,@SOURCE); /* FILE NOT FOUND */
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 BYTE,
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 */
CALL SETDMA(@DBUFF(TDEST));
IF (SPARFIL := (SPARFIL OR INSPARC)) THEN
/* SET UP FCB FROM RANDOM RECORD NO. */
DO; IF WRITE$RANDOM(@DEST) = 255 THEN
CALL ERROR(1,@DEST); /* DISK WRITE ERROR */
END;
ELSE
CALL SETRANDOM(@DEST); /* SET BASE RECORD FOR VERIFY */
DO WHILE TDEST < N;
/* SET DMA ADDRESS TO NEXT BUFFER */
CALL SETDMA(@DBUFF(TDEST));
CALL DISKWRITE(@DEST);
IF DCNT <> 0 THEN
CALL ERROR(1,@DEST); /* DISK WRITE ERROR */
TDEST = TDEST + 128;
END;
IF VERIF THEN /* VERIFY DATA WRITTEN OK */
DO;
TDEST = 0;
CALL SETDMA(@BUFF); /* FOR COMPARE */
DO WHILE TDEST < 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(TDEST+J));
J = J + 1;
END;
TDEST = TDEST + 128;
IF NOT DATAOK THEN
CALL ERROR(2,@DEST); /* VERIFY ERROR */
END;
CALL DISKWRITE(@DEST);
/* NOW READY TO CONTINUE THE WRITE OPERATION */
END;
CALL MOVE(@DBUFF(TDEST),@DBUFF(0),LOW(NDEST := NDEST - TDEST));
END WRITEDEST;
FILLSOURCE: PROCEDURE;
/* FILL THE SOURCE BUFFER */
CALL SETSUSER; /* SOURCE USER NUMBER SET */
NSOURCE = NSBUF;
DO WHILE NSBUF < SBLEN;
/* 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 ERROR(0,@SOURCE); /* DISK READ ERROR */
/* END - OF - FILE */
/* 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) AND (CONCAT OR NOT FASTCOPY) THEN
CALL ERROR(18,@SOURCE); /* INVALID FORMAT WITH SPARCE FILE */
ENDOFSRC = TRUE; /* SET END OF SOURCE FILE */
SBUFF(NSBUF) = ENDFILE; RETURN;
END;
ELSE
NSBUF = NSBUF + 128;
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 */
CALL MON1(4,B);
/* CASE 4 IS DESTINATION FILE */
DO;
IF NDEST >= DBLEN THEN CALL WRITEDEST;
DBUFF(NDEST) = B;
NDEST = NDEST+1;
END;
/* CASE 5 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 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 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,0); /* INVALID SOURCE */
/* CASE 3 IS AXO */
GO TO NOTSOURCE;
/* CASE 4 IS SOURCE FILE */
DO; IF NSOURCE >= SBLEN THEN
/*68K*/ 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 CON */
DO; CONCHK = FALSE; /* DON'T CHECK CONSOLE STATUS */
B = MON2(1,0);
END;
/* CASE 6 IS AXI */
B = MON2(3,0) AND 7FH;
/* 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; IF CONBRK THEN
DO;
IF RDCHAR = ENDFILE THEN RETURN ENDFILE;
CALL ERROR(5,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;
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 ERROR(13,@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 ERROR(15,@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 ERROR(9,@SOURCE); /* HEX RECORD CHECKSUM */
H = GETSOURCE;
END;
END; /* DO FOREVER */
END HEXRECORD;
CK$STRINGS: PROCEDURE;
IF STARTS > 0 THEN
CALL ERROR(11,0); /* START NOT FOUND */
IF QUITS > 0 THEN
CALL ERROR(12,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,@DEST); /* CLOSE FILE */
CALL OPEN(@ODEST);
IF DCNT <> 255 THEN /* FILE EXISTS */
DO;
CALL CLOSE(@ODEST);
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;
DCL CONT BYTE;
/* SET UP SOURCE AND DESTINATION BUFFERS */
/* SPLH */ DCHAKIP=@MEMORY;
/* SPLH */ DCHAKIL=DCHAKIL+8192; /* GET 8K BYTE MEMORY ARRAY*/
/* 68K */ IF DCHAKIL>MAXBL THEN
/* 68K */ DO;
/* 68K */ CALL PRINT(@('**NO MEMORY SPACE**$'));
/* 68K */ CALL BOOT;
/* 68K */ END;
/* 68K */ CONT=0;
/* 68K */ DO WHILE (DCHAKIL<MAXBL) AND (CONT<23) ;
/* 68K */ /* NOT GET MEMORY OVER MAXBL AND OVER 32KB */
/* 68K */ DCHAKIL=DCHAKIL+1024; /* GET 1KB MEMORY DYNAMICALLY */
/* 68K */ CONT=CONT+1;
/* 68K */ END;
DCHAKIL=DCHAKIL-1024; /* SET MEMORY LENGTH */
/* SBASE = .MEMORY + SHR(MAXB - .MEMORY,1); */
/*68K*/
DUM1P=@MEMORY;
DUM2L=(DCHAKIL-DUM1L)/2;
SBASEL=DUM1L+DUM2L;
/* SBLEN, DBLEN = SHR((MAXB - .MEMORY) AND 0FF00H,1) - 128; */
/*68K*/
SBLEN,DBLEN=SHR((UNSIGN(DCHAKIL-DUM1L)) AND 0FF00H,1)-128;
IF NOT DBLBUF THEN
DO; /* ABSORB THE SOURCE BUFFER INTO THE DEST BUFFER */
SBASE = @MEMORY;
IF DBLEN >= 4000H THEN DBLEN,SBLEN = 7F80H;
ELSE DBLEN,SBLEN = DBLEN + SBLEN;
END;
ELSE DO; /* MAY NEED TO WRITE DESTINATION BUFFER */
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 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);
CALL SETDMA(@BUFF);
DO FOREVER;
IF (DCNT := RD$RANDOM(@SOURCE)) = 0 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 ERROR(0,@SOURCE);
END;
END CHKRANDOM;
FASTCOPY = (SFILE AND DFILE);
ENDOFSRC = FALSE;
DBLBUF = FALSE;
SPARFIL = 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 NOT INSPARC) THEN
DO; CALL SETSUSER;
CALL CLOSE(@SOURCE);
IF CONCAT THEN
DO; CALL SETUPEOB;
NDEST = NSBUF;
IF NENDCMD THEN RETURN;
END;
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 */
/* BUG */ IF NOT ARCHIV THEN RETURN 1;
CALL SETSUSER;
SOURCE.FCB(12) = WHAT;
CALL SEARCH(@SOURCE);
DO WHILE DCNT <> 255;
/*68K*/
DUMMYP=@BUFF;
DUMMYL=DUMMYL+LINT(SHL(DCNT AND 11B,5)+1);
/* 68K CALL MOVE(.BUFF+SHL(DCNT AND 11B,5)+1,.SOURCE.FCB(1),15);*/
/*68K*/ CALL MOVE(DUMMYP, @SOURCE.FCB(1),15);
IF NOT ROL(SOURCE.FCB(11),1) THEN
DO; /*SOURCE.FCB(12) = 0; */ /* BUG */
RETURN 1;
END;
CALL SEARCHN;
END;
RETURN 0;
END ARCHCK;
/* INITIALIZE COUNTERS */
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;
/* FILE CONTROL BLOCK IN BUFFER */
IF DCNT = 255 THEN
DO; IF NCOPIED = 0 THEN
CALL ERROR(10,@SEARFCB); /* FILE NOT FOUND */
IF NOT KILDS THEN
CALL CRLF;
RETURN;
END;
NEXTDIR = NDCNT + 1;
/* GET THE FILE CONTROL BLOCK NAME TO DEST */
/*68K*/
DUMMYP=@BUFF;
DUMMYL=DUMMYL+LINT(SHL(DCNT AND 11B,5)+1);
/* 68K CALL MOVE(.BUFF + SHL(DCNT AND 11B,5)+1,.ODEST.FCB(1),15);*/
/*68K*/ CALL MOVE(DUMMYP, @ODEST.FCB(1),15);
CALL MOVE(@ODEST.FCB(1),@SOURCE.FCB(1),15); /* FILL BOTH FCB'S */
IF /* NOT ARCHIV OR */ ARCHCK THEN /* BUG */
DO; ODEST.FCB(12) = 0;
/* BUG */ 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 -$'));
CALL PRNAME;
END;
NCOPIED = NCOPIED + 1;
MADE = FALSE; /* DESTINATION FILE NOT MADE */
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 POINTER, /* ADDRESS OF FCB TO FILL */
FCBS BASED FCBA STRUCTURE ( /* FCB STRUCTURE */
FCB(FRSIZE) BYTE,
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;
/*68K*/ FLEN=FLEN+1;
/*68K*/ FCBS.FCB(FLEN) = 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); /* 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,0); /* 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;
DO WHILE FLEN < FRSIZE -1;
IF FLEN = FNSIZE THEN CHAR = 0;
CALL PUTCHAR;
END;
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 */
'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 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 */
CALL MOVE(@BUFF,@COMLEN,80H);
MULTCOM = (COMLEN = 0);
/* GET CURRENT CP/M VERSION */
IF CVERSION < VERSION THEN
DO;
CALL PRINT(@('REQUIRES CP/M-86$'));
CALL BOOT;
END;
/* IF CVERSION >= MVERSION THEN CALL MON1(45,255);*/
IF MULTCOM THEN
DO; CALL PRINT(@('CP/M-68K PIP VERSION 1.0$'));
CALL CRLF;
END;
CUSER = GETUSER; /* GET CURRENT USER */
CDISK = GETDISK; /* GET CURRENT DISK */
RETRY:
/* ENTER HERE ON ERROR EXIT FROM THE PROCEDURE 'ERROR' */
/* 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 */
CONCAT = 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 <= 1 THEN /* SINGLE CHARACTER OR <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 ERROR(3,@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 */
CALL MOVE(@ODEST.FCB(1),@SOURCE.FCB(1),(FRSIZE - 1));
CALL SIMPLECOPY;
END;
ELSE IF (ODEST.TYPE > CONS) THEN
CALL ERROR(3,0); /* INVALID DESTINATION */
ELSE DO;
IF ODEST.TYPE <> FILE THEN DFILE = FALSE;
/* SCAN AND COPY UNTIL CR */
DO WHILE NENDCMD;
SFILE = TRUE;
CALL DEBLANK;
IF (CHAR <> ',' AND CHAR <> CR) THEN
CALL ERROR(16,0); /* 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,0); /* 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;
Reference in New Issue View Git Blame Copy Permalink