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
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 68K/1.0X SOURCES/v101/utils/stat.sa
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

1873 lines
53 KiB
Plaintext
Raw Blame History

/*SPLH*/ /*$TITLE='STATUS' */
STAT:
DO;
/* COMMON STAT MODULE FOR MP/M-80 2.0 AND MP/M-86 2.0
CP/M-80 2.2 AND CP/M-86 1.1 */
/*
COPYRIGHT(C) 1975, 1976, 1977, 1978, 1979, 1980, 1981,1982
DIGITAL RESEARCH
BOX 579
PACIFIC GROVE, CA
93950
REVISED:
20 JAN 80 BY THOMAS ROLANDER
29 JULY 81 BY DOUG HUSKEY (FOR MP/M 2.0)
02 SEPT 81 (FOR MP/M-86)
14 NOV 81 BY DOUG HUSKEY (FOR CP/M-86)
16 DEC 81 BY DOUG HUSKEY (FOR CP/M-86)
31 JULY 82 BY H.CHAKI(FOR CP/M-68K)
*/
/* MODIFIED 10/30/78 TO FIX THE SPACE COMPUTATION */
/* MODIFIED 01/28/79 TO REMOVE DESPOOL DEPENDENCIES */
/* MODIFIED 07/26/79 TO OPERATE UNDER CP/M 2.0 */
/* MODIFIED 07/31/82 TO OPERATE UNDER CP/M-68K */
/* Command line to generate STAT.68K
[[ assume that the all default VOLUME is SYS:0.. on EXORmacs]]
(1)S-PL/H Compile and ASM on EXORmacs
=SPLH STAT,,;A,S,X,NOV,NOF,MAR=1/80
=SPLH STATSUB,,;A,S,X,NOV,NOF,MAR=1/80
=ASM UT68K,,;
[[ caution ]]
STAT: main routine of STAT utility in S-PL/H
STATSUB: sub routine of STAT utility in S-PL/H
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 STAT/STATSUB/UT68K,STAT68K,STAT68K;MIXRL=SPLHLIB.RO
[[ caution ]]
R option: generate relocatable object
(3)XLINK on EXORmacs
=XLINK STAT68K.RO,STAT68K.OX,O=STAT68K.OL
(4)Convert file on EXORmacs to send to VAX
=CONV STAT68K.OX,STAT68K.OC
(5)Send to VAX from EXORMACS
=VAX
VAX command
S
Source file
STAT68K.OC
(6)Download to CP/M file from VAX
(7)Re-convert file on CP/M
A>RECONV
input file :STAT68K.OC
output file :STAT.68K
end command line */
/*
NOTE: IN AN ATTEMPT TO HAVE A COMMON SOURCE FOR
ALL DRI O.S. SHARED UTILITIES THE VERSION IS TESTED
AND A NUMBER OF CONDITIONALLY EXECUTED STATEMENTS
HAVE BEEN ADDED FOR COMPATIBILITY BETWEEN MP/M 2
AND CP/M. THIS INCLUDES HANDLING BOTH R/O (UNDER
CP/M AND RO).
*/
DECLARE
BDOS3VER LITERALLY '30H'; /* TESTS FOR 3.0 CP/M BDOS */
/* SPLH */ DCL MEMORY(1028) BYTE EXT;
/* SPLH */
DECLARE
/*SPLH*/ /* LIT LITERALLY 'LITERALLY',
DCL LIT 'DECLARE',
PROC LIT 'PROCEDURE',
ADDR LIT 'ADDRESS', */
TRUE LIT '0FFH',
FALSE LIT '0',
/* BOOLEAN LIT 'BYTE', */
FOREVER LIT 'WHILE TRUE',
CR LIT '13',
LF LIT '10',
TAB LIT '9',
FF LIT '12',
SECTORLEN LIT '128';
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
MON1:
PROCEDURE (FUNC,INFO) EXTERNAL;
DECLARE FUNC BYTE;
DECLARE INFO ADDRESS;
END MON1;
MON2:
PROCEDURE (FUNC,INFO) BYTE EXTERNAL;
DECLARE FUNC BYTE;
DECLARE INFO ADDRESS;
END MON2;
MON3:
PROCEDURE (FUNC,INFO) ADDRESS EXTERNAL;
DECLARE FUNC BYTE;
DECLARE INFO ADDRESS;
END MON3;
MON5 : PROC(FN,IN) EXT;
DCL FN BYTE; DCL IN POINTER;
END;
MON6 : PROC(FN,IN) BYTE EXT;
DCL FN BYTE; DCL IN POINTER;
END;
MON7 : PROC(FN,IN) ADDR EXT;
DCL FN BYTE; DCL IN POINTER;
END;
BASE$DPB: PROCEDURE EXTERNAL; /* SET UP BASE OF DPB IN DPB86 */
END BASE$DPB; /* OR IN DPB80 MODULE */
DPB$WORD: PROCEDURE (DPBINDEX) ADDRESS EXTERNAL;
DECLARE DPBINDEX BYTE;
END DPB$WORD;
DPB$BYTE: PROCEDURE (DPBINDEX) BYTE EXTERNAL;
DECLARE DPBINDEX BYTE;
END DPB$BYTE;
/*SPLH*/
/* INDICES INTO DISK PARAMETER BLOCK, USED AS PARAMETERS TO DPB PROCEDURE */
DCL SPT$W LIT '0',
BLKSHF$B LIT '2',
BLKMSK$B LIT '3',
EXTMSK$B LIT '4',
BLKMAX$W LIT /*'5', */ '6',
DIRMAX$W LIT /*'7', */ '8',
DIRBLK$W LIT /*'9', */ '10',
CHKSIZ$W LIT /*'11',*/ '12',
OFFSET$W LIT /*'13';*/ '14';
/* RETURNS THE NUMBER OF ALLOCATED BLOCKS IN THE
ALLOCATION VECTOR */
/*GET$ALL: PROCEDURE (DSM) ADDRESS EXTERNAL;
DECLARE DSM ADDRESS;
END GET$ALL; */ /* S-PL/H */
/* RETURNS THE NUMBER OF CRT COLUMNS */
COLUMNS: PROCEDURE BYTE EXTERNAL;
END COLUMNS;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * GLOBAL DATA * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* BDOS INTERFACE */
/* DECLARE CMDRV BYTE EXTERNAL; /* COMMAND DRIVE */
/* */ DECLARE FCB (100) BYTE EXTERNAL; /* 1ST DEFAULT FCB */
/* */ DECLARE FCB16 (100) BYTE EXTERNAL; /* 2ND DEFAULT FCB */
/* DECLARE PASS0 ADDRESS EXTERNAL; /* 1ST PASSWORD PTR */
/* DECLARE LEN0 BYTE EXTERNAL; /* 1ST PASSWD LENGTH */
/* DECLARE PASS1 ADDRESS EXTERNAL; /* 2ND PASSWORD PTR */
/* DECLARE LEN1 BYTE EXTERNAL; /* 2ND PASSWD LENGTH */
/* */ DECLARE TBUFF (100) BYTE EXTERNAL; /* DEFAULT DMA BUFFER */
DECLARE
MAXB POINTER EXT , /*68K*/ /* ADDR FIELD OF JMP BDOS */
MAXBL LONG AT(@MAXB), /*68K*/
BUFF(128)BYTE EXTERNAL, /* DEFAULT BUFFER */
BUFFA LITERALLY '@BUFF', /* DEFAULT BUFFER */
FCBA LITERALLY '@FCB', /* DEFAULT FILE CONTROL BLOCK */
DOLLA LITERALLY '@FCB(6DH-5CH)', /* DOLLAR SIGN POSITION */
PARMA LITERALLY '@FCB(6DH-5CH)', /* PARAMETER, IF SENT */
RRECA LITERALLY '@FCB(7DH-5CH)', /* RANDOM RECORD 7D,7E,7F */
RRECO LITERALLY '@FCB(7FH-5CH)', /* HIGH BYTE OF RANDOM OVERFLOW */
MEMSIZE LITERALLY 'MAXB', /* END OF MEMORY */
RREC ADDRESS AT(RRECA), /* RANDOM RECORD ADDRESS */
ROVF BYTE AT(RRECO), /* OVERFLOW ON GETFILE */
DOLL BYTE AT(DOLLA), /* DOLLAR PARAMETER */
PARM BYTE AT(PARMA); /* PARAMETER */
/* SEARCH AND SEARCH NEXT FCB */
DECLARE
/*68K*/ CHAKI (6) BYTE INIT (1,2,3,4,5,6),
DCNT BYTE,
UFCB(14) BYTE DATA('?????????????',0), /* 68K */
BFCBA POINTER, /* INDEX INTO DIR BUFFER */
/*68K*/ BFCBAL LONG AT(@BFCBA),
BFCBUSER BASED BFCBA BYTE,
BFCB BASED BFCBA (32) BYTE; /* TEMPLATE OVER DIRBUFF */
/* GENERAL GLOBALS */
DECLARE
FCBMAX LITERALLY '512', /* MAX FCB COUNT */
SPKSHF LITERALLY '3', /* 2**N SECTORS PER KBYTE */
IOVAL BYTE, /* IO BYTE */
SIZESET BYTE INITIAL(0), /* TRUE IF DISPLAYING SIZE FIELD */
SET$ATTRIBUTE BYTE INITIAL(0), /* TRUE IF SETTING FILE ATTRIBUTES */
USER$CODE BYTE, /* CURRENT USER CODE */
VER ADDRESS, /* OS VERSION NUMBER */
KPB ADDRESS, /* KBYTES PER BLOCK */
ALL$BLKS ADDRESS, /* NUMBER OF ALLOCATED BLOCKS */
BDOS3 BYTE, /* IS IT BDOS VERSION 3 ? */
RODISK ADDRESS, /* READ ONLY DISK VECTOR */
CDISK BYTE; /* CURRENT DISK */
DECLARE
BYTE3 STRUCTURE (
LWORD ADDRESS,
HBYTE BYTE);
/* SCANNER */
DECLARE
ACCUM(4) BYTE, /* ACCUMULATOR */
IBP BYTE INITIAL(1); /* INPUT BUFFER POINTER */
DECLARE
DRIVENAME (*) BYTE DATA
(' DRIVE ',0),
READONLY (*) BYTE DATA
('READ ONLY (RO)',0),
READWRITE (*) BYTE DATA
('READ WRITE (RW)',0),
SYSTEM (*) BYTE DATA
('SYSTEM (SYS)',0),
DIRECTORY (*) BYTE DATA
('DIRECTORY (DIR)',0),
ENTRIES (*) BYTE DATA
(' DIRECTORY ENTRIES',0),
FILENAME (*) BYTE DATA
('D:FILENAME.TYP ',0),
USE (*) BYTE DATA
('USE: STAT ',0),
INVALID (*) BYTE DATA
('INVALID ASSIGNMENT',0),
SET$TO (*) BYTE DATA
(' SET TO ',0),
RECORD$MSG (*) BYTE DATA
('128 BYTE RECORD',0),
ATTRIBUTES (*) BYTE DATA
('[RO] [RW] [SYS] OR [DIR]',0),
DEVL (*) BYTE DATA
('CON:AXI:AXO:LST:DEV:VAL:USR:DSK:'),
ATTRIBL (*) BYTE DATA
('RO RW SYS DIR SIZE');
/* PRINT A 3 BYTE NUMBER */
DECLARE
VAL (7) BYTE INITIAL(0,0,0,0,0,0,0), /* BCD DIGITS */
FAC (7) BYTE INITIAL(0,0,0,0,0,0,0), /* HIBYTE FACTOR */
/*68K*/F0 (7) BYTE DATA(6,3,5,5,6,0,0), /* 65,536 */
/*68K*/F1 (7) BYTE DATA(2,7,0,1,3,1,0), /* 131,072 */
/*68K*/F2 (7) BYTE DATA(4,4,1,2,6,2,0), /* 262,144 */
/*68K*/F3 (7) BYTE DATA(8,8,2,4,2,5,0), /* 524,288 */
/*68K*/F4 (7) BYTE DATA(6,7,5,8,4,0,1), /* 1,048,576 */
/*68K*/F5 (7) BYTE DATA(2,5,1,7,9,0,2), /* 2,097,152 */
/*68K*/F6 (7) BYTE DATA(4,0,3,4,9,1,4), /* 4,194,304 */
/*68K*/PTR (7) POINTER DATA(@F0,@F1,@F2,@F3,@F4,@F5,@F6);
/* DISPLAY FILES */
DECLARE /* DUPLICATE BLOCK DETECTION */
LB BYTE INITIAL(1), /* NUMBER OF BYTES PER BLOCK # */
FIRST$ERROR BYTE INITIAL(TRUE); /* DUPLICATE BLOCK ERROR */
DECLARE /* TOTALS */
KBLKS ADDRESS INITIAL(0), /* TOTAL NUMBER OF 1K BLKS */
NFCBS ADDRESS INITIAL(0), /* TOTAL NUMBER OF FCBS */
NXFCBS ADDRESS INITIAL(0), /* TOTAL NUMBER OF XFCBS */
TALL ADDRESS INITIAL(0); /* TOTAL ALLOCATION */
/* END OF DATA SEGMENT */
DECLARE
LAST$DSEG$BYTE BYTE INITIAL (0);
/* 68K */
DCL DUMMYP POINTER,
DUMMYL LONG AT(@DUMMYP);
DCL DUM1P POINTER,
DUM1L LONG AT(@DUM1P);
DCL DUM2P POINTER,
DUM2L LONG AT(@DUM2P);
/* */
PLM: PROCEDURE PUBLIC;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * PRIMITIVE FUNCTIONS * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
BOOT: PROCEDURE;
CALL MON1 (0,0); /* SYSTEM RESET */
END BOOT;
PRINTCHAR: PROCEDURE(CHAR);
DECLARE CHAR BYTE;
CALL MON1(2,CHAR);
END PRINTCHAR;
PRINTB: PROCEDURE;
/* PRINT BLANK CHARACTER */
CALL PRINTCHAR(' ');
END PRINTB;
BLANKS: PROCEDURE(B);
DECLARE B BYTE;
DO WHILE (B:=B-1) <> -1;
CALL PRINTB;
END;
END BLANKS;
PRINTX: PROCEDURE(A);
DECLARE A POINTER;
DECLARE S BASED DUMMYP BYTE;
/*68K*/ DUMMYP=A;
DO WHILE S <> 0;
CALL PRINTCHAR(S);
/*68K*/ DUMMYL=DUMMYL+1;
END;
END PRINTX;
IOVALF: PROCEDURE BYTE;
RETURN MON2(7,0); /* GET I/O BYTE */
END IOVALF;
SIOVALF: PROCEDURE(VALUE);
DECLARE VALUE BYTE;
CALL MON1(8,VALUE); /* SET IOBYTE */
END SIOVALF;
BREAK: PROCEDURE BYTE;
RETURN MON2(11,0); /* CONSOLE READY */
END BREAK;
TEST$BREAK: PROCEDURE;
IF BREAK THEN
DO;
CALL MON1 (1,0); /* READ CHARACTER */
CALL PRINTX(@(CR,LF,'** ABORTED **',0));
CALL BOOT;
END;
END TEST$BREAK;
CRLF: PROCEDURE;
CALL PRINTCHAR(CR);
CALL PRINTCHAR(LF);
CALL TEST$BREAK;
END CRLF;
PRINT: PROCEDURE(A);
DECLARE A POINTER;
/* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
NEXT 0 IS ENCOUNTERED */
CALL CRLF;
CALL PRINTX(A);
END PRINT;
VERSION: PROCEDURE ADDRESS;
/* RETURNS CURRENT CP/M VERSION # */
RETURN MON3(12,0);
END VERSION;
GETRODISK: PROCEDURE ADDRESS;
/* GET THE READ-ONLY DISK VECTOR */
RETURN MON3(29,0);
END GETRODISK;
SELECT: PROCEDURE(D);
DECLARE D BYTE;
RODISK = GETRODISK; /* READ ONLY DISK VECTOR SET */
CDISK = D;
CALL MON1(14,D);
END SELECT;
OPEN: PROCEDURE(FCB);
DECLARE FCB POINTER;
DCNT = MON6(15,FCB);
END OPEN;
SEARCH: PROCEDURE(FCB);
DECLARE FCB POINTER;
DECLARE FCB0 BASED FCB BYTE;
DCNT = MON6(17,FCB);
END SEARCH;
SEARCHN: PROCEDURE;
DCNT = MON2(18,0);
END SEARCHN;
CSELECT: PROCEDURE BYTE;
/* RETURN CURRENT DISK NUMBER */
RETURN MON2(25,0);
END CSELECT;
SETDMA: PROCEDURE(DMA);
DECLARE DMA POINTER;
CALL MON5(26,DMA);
END SETDMA;
GETLOGIN: PROCEDURE ADDRESS;
/* GET THE LOGIN VECTOR */
RETURN MON3(24,0);
END GETLOGIN;
WRITEPROT: PROCEDURE;
/* WRITE PROTECT THE CURRENT DISK */
CALL MON1(28,0);
END WRITEPROT;
SETIND: PROCEDURE(A);
DECLARE A POINTER;
/* SET FILE INDICATORS FOR CURRENT FCB */
CALL MON5(30,A);
END SETIND;
GETUSER: PROCEDURE BYTE;
/* RETURN CURRENT USER NUMBER */
RETURN MON2(32,0FFH);
END GETUSER;
SETUSER: PROCEDURE(USER);
DECLARE USER BYTE;
CALL MON1(32,USER);
END SETUSER;
GETFILESIZE: PROCEDURE(FCB);
DECLARE FCB POINTER;
CALL MON5(35,FCB);
END GETFILESIZE;
GETFREESP: PROCEDURE(D);
DECLARE D BYTE;
CALL MON1(46,D);
END GETFREESP;
/* WE WANT KPB (KBYTES PER BLOCK) SO THAT EACH TIME WE FIND
A BLOCK ADDRESS WE CAN ADD KPB K TO THE KILOBYTE ACCUMULATOR
FOR FILE SIZE. WE DERIVE KPB AS FOLLOWS:
BLKSHF RECS/BLK K/BLK BLKSHF-3
3 8 1 0
4 16 2 1
5 32 4 2
6 64 8 3
7 128 16 4
*/
SET$KPB: PROCEDURE;
DECLARE KSHF BYTE;
CALL BASE$DPB; /* DISK PARAMETERS SET */
IF (KSHF:=DPB$BYTE(BLKSHF$B)-SPKSHF) < 1 THEN
KPB = 1;
ELSE
KPB = SHL(DOUBLE(1),DPB$BYTE(BLKSHF$B)-SPKSHF);
END SET$KPB;
SELECT$DISK: PROCEDURE(D);
DECLARE D BYTE;
/* SELECT DISK AND SET KPB */
CALL SELECT(D);
CALL SET$KPB; /* BYTES PER BLOCK */
END SELECT$DISK;
/* 68K*/
MOVE : PROC(C,S,D);
DCL C BYTE,(S,D) POINTER;
DCL A BASED DUM1P BYTE,B BASED DUM2P BYTE;
DUM1P=S; DUM2P=D;
DO WHILE (C:=C-1)<>255;
B=A;
DUM1L=DUM1L+1; DUM2L=DUM2L+1;
END;
END;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * SCANNER * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* FILL STRING @ S FOR C BYTES WITH F */
FILL: PROC(S,F,C);
DCL S POINTER,C ADDR,
F BYTE,
A BASED DUMMYP BYTE;
/*68K*/ DUMMYP=S;
DO WHILE (C:=C-1)<>0FFFFH;
A = F;
/*S8K*/ DUMMYL=DUMMYL+1;
END;
END FILL;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* GET NEXT INPUT VALUE INTO ACCUM */
SCAN: PROCEDURE;
/* FILL ACCUM WITH NEXT INPUT VALUE */
DECLARE (I,B) BYTE;
SETACC: PROCEDURE(B);
DECLARE B BYTE;
IF I < 4 THEN
ACCUM(I) = B;
I = I + 1;
END SETACC;
/* DEBLANK INPUT */
DO WHILE (B:=BUFF(IBP)) = ' ';
IBP = IBP + 1;
END;
/* SKIP OPTION DELIMITER */
IF B = '[' THEN
IBP = IBP + 1;
/* INITIALIZE ACCUM LENGTH (0-3) */
I = 0;
CALL FILL(@ACCUM,' ',4);
DO WHILE (B := BUFF(IBP)) > 1;
IF B < '!' OR B = ',' OR B = ':' OR
B = '[' OR B = '=' THEN BUFF(IBP) = 1;
ELSE
IBP = IBP + 1;
IF B <> '/' AND B <> '$' AND B <> ']' AND B <> ','
THEN CALL SETACC(B);
END;
IF B <> 0 THEN
IBP = IBP + 1;
END SCAN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PARSE AN ASSIGNMENT INTO ACCUMULATOR */
PARSE$ASSIGN: PROCEDURE BYTE;
DCL B BYTE;
CALL SCAN;
IF ACCUM(0) <> '=' THEN
RETURN FALSE;
CALL SCAN;
RETURN TRUE;
END PARSE$ASSIGN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PARSE NEXT ITEM INTO ACCUMULATOR */
PARSE$NEXT: PROCEDURE BYTE;
CALL SCAN;
IF ACCUM(0) = ' ' THEN DO;
CALL SCAN;
IF ACCUM(0) = ' ' THEN
RETURN FALSE;
END;
RETURN TRUE;
END PARSE$NEXT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT A DECIMAL NUMBER FROM 2 BYTE BINARY
IN A FIXED FIELD (PRECISION) */
PDECIMAL: PROCEDURE(V,PREC);
/* PRINT VALUE V WITH PRECISION PREC (10,100,1000)
WITH LEADING ZERO SUPPRESSION */
DECLARE
V ADDRESS, /* VALUE TO PRINT */
PREC ADDRESS, /* PRECISION */
ZEROSUP BYTE, /* ZERO SUPPRESSION FLAG */
D BYTE; /* CURRENT DECIMAL DIGIT */
ZEROSUP = TRUE;
DO WHILE PREC <> 0;
D = V / PREC ; /* GET NEXT DIGIT */
V = V MOD PREC;/* GET REMAINDER BACK TO V */
PREC = PREC / 10; /* READY FOR NEXT DIGIT */
IF PREC <> 0 AND ZEROSUP AND D = 0 THEN CALL PRINTB; ELSE
DO; ZEROSUP = FALSE; CALL PRINTCHAR('0'+D);
END;
END;
END PDECIMAL;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * PRINT A NUMBER * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* BCD - CONVERT 16 BIT BINARY TO
7 ONE BYTE BCD DIGITS */
BCD: PROCEDURE(VALUE);
DECLARE
(VALUE,PREC) ADDRESS,
I BYTE;
PREC = 10000;
I = 5; /* DIGITS: 4,3,2,1,0 */
DO WHILE PREC <> 0;
/* S-PL/H */ I=I-1;
VAL(I) = VALUE / PREC; /* GET NEXT DIGIT */
VALUE = VALUE MOD PREC; /* REMAINDER IN VALUE */
PREC = PREC / 10;
END;
END BCD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT BCD NUMBER IN VAL ARRAY */
PRINTBCD: PROCEDURE(FIXED);
DECLARE
(FIXED, ZEROSUP, I) BYTE;
PCHAR: PROCEDURE(C);
DECLARE C BYTE;
IF VAL(I) = 0 THEN
IF ZEROSUP THEN
IF I <> 0 THEN DO;
IF FIXED THEN
CALL PRINTB;
RETURN;
END;
/* ELSE */
CALL PRINTCHAR(C);
ZEROSUP = FALSE;
END PCHAR;
ZEROSUP = TRUE;
I = 7;
DO WHILE (I:=I-1) <> -1;
CALL PCHAR('0'+VAL(I));
IF I = 6 OR I = 3 THEN
CALL PCHAR(',');
END;
END PRINTBCD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* ADD TWO BCD NUMBERS RESULT IN SECOND */
ADD: PROCEDURE(AP,BP);
DECLARE
(AP,BP) POINTER,
A BASED AP (7) BYTE,
B BASED BP (7) BYTE,
(C,I) BYTE;
C = 0; /* CARRY */
DO I = 0 TO 6; /* 0 = LSB */
B(I) = A(I) + B(I) + C;
C = B(I) / 10;
B(I) = B(I) MOD 10;
END;
END ADD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
P3BYTEL : PROC(BYTE3ADR,FIXED); /* S-PL/H */
DCL BYTE3ADR POINTER,
FIXED BYTE,
B3 BASED BYTE3ADR (3) BYTE, L1 LONG,PREC LONG,
I BYTE;
L1=(LINT(B3(0))*256+LINT(B3(1)))*256+LINT(B3(2));
PREC=1000000; I=7;
DO WHILE PREC<>0;
I=I-1;
VAL(I)=L1/PREC; L1=L1 MOD PREC; PREC=PREC/10;
END;
CALL PRINTBCD(FIXED);
END; /* S-PL/H */
/* PRINT 3 BYTE VALUE BASED AT BYTE3ADR */
P3BYTE: PROCEDURE(BYTE3ADR,FIXED);
DECLARE
FIXED BYTE,
I BYTE,
HIGH$BYTE BYTE,
BYTE3ADR POINTER,
B3 BASED BYTE3ADR STRUCTURE (
LWORD ADDRESS,
HBYTE BYTE);
CALL FILL(@VAL,0,7);
CALL FILL(@FAC,0,7);
CALL BCD(B3.LWORD); /* PUT 16 BIT VALUE IN VAL */
HIGH$BYTE = B3.HBYTE;
DO I = 0 TO 6; /* FACTOR FOR BIT I */
IF HIGH$BYTE THEN /* LSB IS 1 */
CALL ADD(PTR(I),@FAC); /* ADD IN FACTOR */
HIGH$BYTE = SHR(HIGH$BYTE,1); /* GET NEXT BIT */
END;
CALL ADD(@FAC,@VAL); /* ADD FACTOR TO VALUE */
CALL PRINTBCD(FIXED); /* PRINT VALUE */
END P3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DIVIDE 3 BYTE VALUE BY 8 */
SHR3BYTE: PROCEDURE(BYTE3ADR);
DCL BYTE3ADR POINTER,
B3 BASED BYTE3ADR STRUCTURE (
LWORD ADDRESS,
HBYTE BYTE),
TEMP1 BASED BYTE3ADR (2) BYTE,
TEMP2 BYTE;
/* TEMP2 = ROR(B3.HBYTE,3) AND 11100000B; /* GET 3 BITS */
/* B3.HBYTE = SHR(B3.HBYTE,3);
B3.LWORD = SHR(B3.LWORD,3);
TEMP1(1) = TEMP1(1) OR TEMP2; /* OR IN 3 BITS FROM HBYTE */
/* 68K */
B3.LWORD=B3.LWORD/8 OR SHL(UNSIGN(B3.HBYTE) AND 7, 13);
B3.HBYTE=SHR(B3.HBYTE,3);
END SHR3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* MULTIPLY 3 BYTE VALUE BY #RECORDS PER BLOCK */
SHL3BYTE: PROCEDURE(BYTE3ADR);
DCL BYTE3ADR POINTER,
B3 BASED BYTE3ADR STRCT(
LWORD ADDRESS,
HBYTE BYTE),
TEMP1 BASED BYTE3ADR (2) BYTE;
/* B3.HBYTE = (ROL(TEMP1(1),DPB$BYTE(BLKSHF$B)) AND DPB$BYTE(BLKMSK$B))
OR SHL(B3.HBYTE,DPB$BYTE(BLKSHF$B));
B3.LWORD = SHL(B3.LWORD,DPB$BYTE(BLKSHF$B)); */
/* 68K */
B3.HBYTE=SHR(B3.LWORD,16-DPB$BYTE(BLKSHF$B));
B3.LWORD=SHL(B3.LWORD,DPB$BYTE(BLKSHF$B));
END SHL3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY CURRENT DRIVE */
SHOW$DRV: PROCEDURE;
CALL PRINTCHAR(CDISK+'A');
CALL PRINTCHAR(':');
END SHOW$DRV;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY CURRENT DRIVE WITH SPACE */
SHOW$DRIVE: PROCEDURE;
CALL SHOW$DRV;
CALL PRINTB;
END SHOW$DRIVE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT USER NUMBER */
SHOW$USR: PROCEDURE(USER);
DCL USER BYTE;
CALL PRINTX(@('USER :',0));
CALL PDECIMAL(USER,100);
END SHOW$USR;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * CP/M 2 BLOCK COUNTING ROUTINES * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* ADD # OF KILOBYTES IN ONE BLOCK
KPB = KILOBYTES PER BLOCK */
ADD$BLOCK: PROCEDURE(AK);
DECLARE AK POINTER;
/* ADD ONE BLOCK TO THE KILOBYTE ACCUMULATOR */
DECLARE KACCUM BASED AK ADDRESS; /* KILOBYTE ACCUM */
KACCUM = KACCUM + KPB;
END ADD$BLOCK;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* RETURNS THE NUMBER OF K REMAINING */
COUNT: PROCEDURE ADDRESS;
DECLARE
KA ADDRESS, /* KB ACCUMULATOR */
(I, MAXALL) ADDRESS; /* LOCAL INDEX */
DCL LCOUNT LONG; /* 68K */
/* KA = 0;
ALL$BLKS = GETALL(DPB$WORD(BLKMAX$W));
IF (MAXALL:=DPB$WORD(BLKMAX$W)) > ALL$BLKS THEN
DO I = 0 TO MAXALL-ALL$BLKS;
CALL ADD$BLOCK(@KA);
END;
RETURN KA; */
/* 68K */
CALL SETDMA(@LCOUNT);
CALL MON1(46,UNSIGN(CDISK)) ; /* GET DISK FREE SPACE */
RETURN LCOUNT/8; /* K BYTE */
END COUNT;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * STATUS ROUTINES * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* DISPLAY DRIVE CHARACTERISTICS */
DRIVESTATUS: PROCEDURE;
DCL B3A POINTER,
B3 BASED B3A STRUCTURE (
LWORD ADDRESS,
HBYTE BYTE);
/* PRINT 3 BYTE VALUE */
PV3: PROCEDURE;
CALL CRLF;
CALL P3BYTE(B3A,TRUE);
CALL PRINTCHAR(':');
CALL PRINTB;
END PV3;
/* PRINT ADDRESS VALUE V */
PV: PROCEDURE(V);
DCL V ADDRESS;
B3.HBYTE = 0;
B3.LWORD = V;
CALL PV3;
END PV;
/* PRINT THE CHARACTERISTICS OF THE CURRENTLY SELECTED DRIVE */
B3A = @BYTE3;
CALL PRINT(@(' ',0));
CALL SHOW$DRIVE;
CALL PRINTX(@('DRIVE CHARACTERISTICS',0));
B3.HBYTE = 0;
B3.LWORD = DPB$WORD(BLKMAX$W) + 1; /* = # BLOCKS */
CALL SHL3BYTE(B3A); /* # BLOCKS * RECORDS/BLOCK */
CALL PV3;
CALL PRINTX(@RECORD$MSG);
CALL PRINTX(@(' CAPACITY',0));
CALL SHR3BYTE(B3A); /* DIVIDE BY 8 */
CALL PV3;
CALL PRINTX(@('KILOBYTE DRIVE CAPACITY',0));
CALL PV(DPB$WORD(DIRMAX$W)+1);
CALL PRINTX(@('32 BYTE',0));
CALL PRINTX(@ENTRIES);
CALL PV(SHL(DPB$WORD(CHKSIZ$W),2));
CALL PRINTX(@('CHECKED',0));
CALL PRINTX(@ENTRIES);
CALL PV((DPB$BYTE(EXTMSK$B)+1) * 128);
CALL PRINTX(@RECORD$MSG);
CALL PRINTX(@('S / DIRECTORY ENTRY',0));
CALL PV(SHL(DOUBLE(1),DPB$BYTE(BLKSHF$B)));
CALL PRINTX(@RECORD$MSG);
CALL PRINTX(@('S / BLOCK',0));
CALL PV(DPB$WORD(SPT$W));
CALL PRINTX(@RECORD$MSG);
CALL PRINTX(@('S / TRACK',0));
CALL PV(DPB$WORD(OFFSET$W));
CALL PRINTX(@('RESERVED TRACKS',0));
CALL CRLF;
END DRIVESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY ACTIVE USER NUMBERS */
USERSTATUS: PROCEDURE;
/* DISPLAY ACTIVE USER NUMBERS */
DECLARE I BYTE;
DECLARE USER(16) BYTE;
CALL CRLF;
CALL SHOW$DRIVE;
CALL PRINTX(@('ACTIVE ',0));
CALL SHOW$USR(USER$CODE);
CALL CRLF;
CALL SHOW$DRIVE;
CALL PRINTX(@('ACTIVE FILES:',0));
DO I = 0 TO LAST(USER);
USER(I) = FALSE;
END;
CALL SETDMA(@MEMORY);
CALL SEARCH(@UFCB);
DO WHILE DCNT <> 255;
IF (I := MEMORY(SHL(DCNT AND 11B,5))) <> 0E5H THEN
USER(I AND 0FH) = TRUE;
CALL SEARCHN;
END;
DO I = 0 TO LAST(USER);
IF USER(I) THEN CALL PDECIMAL(I,100);
END;
CALL CRLF;
END USERSTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY STATUS OF LOGGED IN DISKETTES */
DISKSTATUS: PROCEDURE;
/* DISPLAY DISK STATUS */
DECLARE LOGIN ADDRESS, D BYTE;
LOGIN = GETLOGIN; /* LOGIN VECTOR SET */
D = 0;
DO WHILE LOGIN <> 0;
IF LOW(LOGIN) THEN
DO; CALL SELECT$DISK(D);
CALL DRIVESTATUS;
END;
LOGIN = SHR(LOGIN,1);
D = D + 1;
END;
END DISKSTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* TRY TO MATCH 4 CHARACTER DEVICE IN
ACCUM WITH DEVICE IN LIST
VA = ADDRESS OF LIST
V1 = # OF DEVICES IN LIST */
MATCH: PROCEDURE(VA,VL) BYTE;
/* RETURN INDEX+1 TO VECTOR AT VA IF MATCH */
DECLARE VA POINTER,
V BASED VA (16) BYTE,
VL BYTE;
DECLARE (I,J,MATCH,SYNC) BYTE;
J,SYNC = 0;
DO SYNC = 1 TO VL;
MATCH = TRUE;
DO I = 0 TO 3;
IF V(J) <> ACCUM(I) THEN MATCH=FALSE;
J = J + 1;
END;
IF MATCH THEN RETURN SYNC;
END;
RETURN 0; /* NO MATCH */
END MATCH;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PROCESS A DEVICE REQUEST VALID DEVICES
ARE LISTED ABOVE */
DEVREQ: PROCEDURE BYTE;
/* PROCESS DEVICE REQUEST, RETURN TRUE IF FOUND */
/* DEVICE TABLES */
DECLARE
DEVR(*) BYTE DATA
(/* CONSOLE */ 'TTY:CRT:BAT:UC1:',
/* READER */ 'TTY:PTR:UR1:UR2:',
/* PUNCH */ 'TTY:PTP:UP1:UP2:',
/* LISTING */ 'TTY:CRT:LPT:UL1:');
DECLARE
(I,J,IOBYTE,ITEMS,IOVAL) BYTE;
PRNAME: PROCEDURE(A);
DECLARE A POINTER,
X BASED DUMMYP BYTE;
/*68K*/ DUMMYP=A;
/* PRINT DEVICE NAME AT A */
DO WHILE X <> ':';
CALL PRINTCHAR(X); DUMMYL=DUMMYL+1;
END;
CALL PRINTCHAR(':');
END PRNAME;
DEVSTATUS: PROC;
IOBYTE = IOVALF; J = 0;
/*68K*/ CALL CRLF;
DO I = 0 TO 3;
CALL PRNAME(@DEVL(SHL(I,2)));
CALL PRINTX(@(' IS ',0));
CALL PRNAME(@DEVR(SHL(IOBYTE AND 11B,2)+J));
J = J + 16; IOBYTE = SHR(IOBYTE,2);
CALL CRLF;
END;
END DEVSTATUS;
VALUES: PROCEDURE;
CALL PRINT(@('STAT 2.2',0));
CALL CRLF;
CALL PRINT(@('READ ONLY DISK: D:=RO',0));
CALL PRINT(@('SET ATTRIBUTE: ',0));
CALL PRINTX(@FILENAME);
CALL PRINTX(@ATTRIBUTES);
CALL PRINT(@('DISK STATUS : DSK: D:DSK:',0));
CALL PRINT(@('USER STATUS : USR: D:USR:',0));
CALL PRINT(@('IOBYTE ASSIGN:',0));
DO I = 0 TO 3; /* EACH LINE SHOWS ONE DEVICE */
CALL CRLF;
CALL PRNAME(@DEVL(SHL(I,2)));
CALL PRINTX(@(' =',0));
DO J = 0 TO 12 BY 4;
CALL PRINTCHAR(' ');
CALL PRNAME(@DEVR(SHL(I,4)+J));
END;
END;
CALL CRLF;
END VALUES;
ITEMS = 0;
DO FOREVER;
IF (I:=MATCH(@DEVL,8)) = 0 THEN DO;
IF ITEMS<>0 THEN
GO TO ERROR;
RETURN FALSE;
END;
ITEMS = ITEMS+1; /* FOUND FIRST/NEXT ITEM */
IF I = 5 THEN /* DEVICE STATUS REQUEST */
CALL DEVSTATUS;
ELSE IF I = 6 THEN /* LIST POSSIBLE ASSIGNMENT */
CALL VALUES;
ELSE IF I = 7 THEN /* LIST USER STATUS VALUES */
CALL USERSTATUS;
ELSE IF I = 8 THEN /* SHOW THE DISK DEVICE STATUS */
CALL DISKSTATUS;
ELSE /* SCAN ITEM I-1 IN DEVICE TABLE */
DO; /* FIND BASE OF DESTINATION */
J = SHL(I:=I-1,4);
IF NOT PARSE$ASSIGN THEN
GO TO ERROR;
IF (J:=MATCH(@DEVR(J),4)-1) = 255 THEN
GO TO ERROR;
IOBYTE = 1111$1100B; /* CONSTRUCT MASK */
DO WHILE (I:=I-1) <> 255;
IOBYTE = ROL(IOBYTE,2);
J = SHL(J,2);
END;
IOVAL = (IOVALF AND IOBYTE) OR J;
CALL SIOVALF(IOVAL);
END;
/* END OF CURRENT ITEM, LOOK FOR MORE */
IF NOT PARSE$NEXT THEN
RETURN TRUE;
END; /* OF DO FOREVER */
ERROR:
CALL PRINT(@INVALID);
RETURN TRUE;
END DEVREQ;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT THE ACTUAL BYTE COUNT */
PRCOUNT: PROCEDURE(FIXED);
DECLARE FIXED BYTE;
IF BDOS3 THEN DO;
CALL SETDMA(@BYTE3);
CALL GETFREESP(CDISK);
CALL SHR3BYTE(@BYTE3);
END;
ELSE DO;
BYTE3.HBYTE = 0;
BYTE3.LWORD = COUNT;
END;
CALL P3BYTE(@BYTE3,FIXED);
CALL PRINTCHAR('K');
END PRCOUNT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT ALLOCATION FOR CURRENT DISK */
PRALLOC: PROCEDURE;
DCL
RO ADDRESS;
CALL CRLF;
CALL SHOW$DRIVE;
CALL PRINTCHAR('R');
IF CDISK <> 0 THEN
RO = SHR(RODISK,CDISK);
ELSE
RO = RODISK;
IF LOW(RO) THEN
CALL PRINTCHAR('O');
ELSE
CALL PRINTCHAR('W');
CALL PRINTX(@(', FREE SPACE: ',0));
CALL PRCOUNT(TRUE);
END PRALLOC;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT THE STATUS OF THE DISK SYSTEM */
PRSTATUS: PROCEDURE;
DECLARE LOGIN ADDRESS;
DECLARE D BYTE;
LOGIN = GETLOGIN; /* LOGIN VECTOR SET */
D = 0;
DO WHILE LOGIN <> 0;
IF LOW(LOGIN) THEN
DO;
CALL SELECT$DISK(D);
CALL PRALLOC;
END;
LOGIN = SHR(LOGIN,1);
D = D + 1;
END;
CALL CRLF;
END PRSTATUS;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * DISPLAY FILES * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* PROCESS FILE DISPLAY OR ATTRIBUTE
ASSIGNMENT */
GETFILE: PROCEDURE;
/* PROCESS FILE REQUEST */
DECLARE
FNAM LITERALLY '11',
FEXT LITERALLY '12',
FS1 LITERALLY '13',
FMOD LITERALLY '14',
FRC LITERALLY '15',
FTYP LITERALLY '9',
ROFILE LITERALLY '9', /* READ/ONLY FILE */
INFILE LITERALLY '10', /* INVISIBLE FILE */
ARCHIV LITERALLY '11', /* ARCHIVED FILE */
ATTRB1 LITERALLY '1', /* ATTRIBUTE F1' */
ATTRB2 LITERALLY '2', /* ATTRIBUTE F2' */
ATTRB3 LITERALLY '3', /* ATTRIBUTE F3' */
ATTRB4 LITERALLY '4'; /* ATTRIBUTE F4' */
DECLARE
/*68K*/ MEMBASE POINTER, /* BASE FOR COLLECTING FCBS */
/*68K*/ MEMBASEL LONG AT(@MEMBASE),
FCBS BASED MEMBASE (1) BYTE,
FCBN ADDRESS, /* NUMBER OF FCB'S COLLECTED SO FAR */
FINX(FCBMAX) ADDRESS, /* INDEX VECTOR USED DURING SORT */
FCBR(FCBMAX) ADDRESS, /* RECORD COUNT */
/*68K*/ FCBSA POINTER, /* INDEX INTO FCBS */
/*68K*/ FCBSAL LONG AT(@FCBSA),
/*68K*/ FCBEA POINTER, /* EXT BYTE OF FCBV */
/*68K*/ FCBEAL LONG AT(@FCBEA),
/*68K*/ FCBS1 POINTER, /* S1 BYTE OF FCBV */
/*68K*/ FCBS1L LONG AT(@FCBS1),
/*68K*/ FCBMA POINTER, /* MOD BYTE OF FCBV */
/*68K*/ FCBMAL LONG AT(@FCBMA),
FCBE BASED FCBEA ADDRESS, /* EXTENT COUNT IN FCBS ENTRY */
FCBK BASED FCBMA ADDRESS, /* KBYTE COUNT IN FCBS ENTRY */
XFCB BASED FCBS1 BYTE, /* BIT 7 = XFCB FOR FCBS ENTRY */
FCBV BASED FCBSA (16) BYTE; /* TEMPLATE OVER FCBS ENTRY */
DECLARE
I ADDRESS, /* FCB COUNTER DURING COLLECTION AND DISPLAY */
L ADDRESS, /* USED DURING SORT AND DISPLAY */
K ADDRESS, /* " */
M ADDRESS, /* " */
KB BYTE, /* BYTE COUNTER */
LB BYTE, /* BYTE COUNTER */
MB BYTE, /* BYTE COUNTER */
(B,F) BYTE, /* COUNTERS */
XFCBFOUND BYTE,/* TRUE MEANS XFCB FOUND */
WORD$BLKS BYTE, /* 2 BYTE BLOCK ADDRESSES */
MATCHED BYTE; /* USED DURING FCBS SEARCH */
DECLARE
(SCASE1,SCASE2) BYTE; /* STATUS CASE # */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY A LINE OF B DASHES */
DOTS: PROCEDURE(I);
DECLARE I BYTE;
CALL CRLF;
DO WHILE (I:=I-1) <> -1;
CALL PRINTCHAR('-');
END;
END DOTS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT CURRENT FILE NAME */
PRINTFN: PROCEDURE(A);
DECLARE
A POINTER,
FCBV BASED A (16) BYTE,
(K, LB) BYTE;
CALL SHOW$DRV;
DO K = 1 TO FNAM;
IF K = FTYP THEN
CALL PRINTCHAR('.');
CALL PRINTCHAR(FCBV(K) AND 7FH);
END;
END PRINTFN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* TEST IF ATTRIBUTE FCBV(I) IS ON */
ATTRIBUTE: PROCEDURE(I) BYTE;
DECLARE I BYTE;
IF ROL(FCBV(I),1) THEN
RETURN TRUE;
RETURN FALSE;
END ATTRIBUTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PRINT CHARACTER C IF ATTRIBUTE(B) IS TRUE */
PRNT$ATTRIB: PROCEDURE(B,C);
DECLARE (B,C) BYTE;
IF ATTRIBUTE(B) THEN
CALL PRINTCHAR(C);
ELSE
CALL PRINTB;
END PRNT$ATTRIB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* BUILD AN ALLOCATION VECTOR CHECK FOR DUPPLICATE
BLOCKS IN THE DIRECTORY
RETURN TRUE IF NO ERROR, FALSE OTHERWISE */
ALLOCATE: PROCEDURE(BLOCK$PTR) BYTE;
DECLARE
BLOCK$PTR POINTER,
BLOCK$WORD BASED BLOCK$PTR ADDRESS,
BLOCK$BYTE BASED BLOCK$PTR BYTE,
(VBYTE, VBIT) WORD,
AMASK BYTE;
IF WORD$BLKS THEN DO;
VBYTE = SHR(BLOCK$WORD,11) OR SHL(BLOCK$WORD AND 0FFH, 5);
VBIT = SHR(BLOCK$WORD,8) AND 7;
END;
ELSE DO;
VBYTE = SHR(BLOCK$BYTE,3);
VBIT = BLOCK$BYTE MOD 8;
END;
AMASK = 1000$0000B;
IF VBIT <> 0 THEN
AMASK = SHR(1000$0000B,VBIT);
IF (AMASK AND MEMORY(VBYTE)) = AMASK THEN DO;
IF FIRST$ERROR THEN DO;
FIRST$ERROR = FALSE;
CALL PRINT(@('BAD DIRECTORY ON ',0));
CALL SHOW$DRV;
CALL PRINT(@('SPACE ALLOCATION CONFLICT:',0));
END;
CALL CRLF;
CALL SHOW$USR(BFCBUSER);
CALL BLANKS(8);
CALL PRINTFN(BFCBA);
RETURN FALSE;
END;
MEMORY(VBYTE) = MEMORY(VBYTE) OR AMASK;
RETURN TRUE;
END ALLOCATE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* CHECK FOR MATCHING FILE NAMES */
FILE$MATCH: PROCEDURE(A) BYTE;
DECLARE
I BYTE,
A POINTER,
FCB BASED A (16) BYTE;
DO I=1 TO 11;
IF FCB(I) <> '?' THEN
IF (FCB(I) AND 7FH) <> (BFCB(I) AND 7FH) THEN
RETURN FALSE;
END;
RETURN TRUE;
END FILE$MATCH;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* EXAMINE BLOCK NUMBERS :
ALLOC = TRUE => CHECK FOR DUPLICATE BLOCK NUMBERS
ALLOC = FALSE => COUNT KBYTES MAPPED BY FCB */
COUNT$BLKS: PROCEDURE(ALLOC);
DCL (I,ALLOC, NO$ERROR) BYTE;
NO$ERROR = TRUE;
I = 32;
DO WHILE NO$ERROR AND ((I:=I-LB) >= 16);
MB = BFCB(I);
IF WORD$BLKS THEN /* DOUBLE PRECISION INX */
MB = MB OR BFCB(I+1);
IF MB <> 0 THEN DO; /* ALLOCATED */
IF ALLOC THEN
NO$ERROR = ALLOCATE(@BFCB(I));
ELSE
FCBK = FCBK + KPB; /* KPB = KBYTES PER BLOCK */
END;
END;
END COUNT$BLKS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* CHECK NEXT FCB IN SEARCH / SEARCHN */
CHECK$USER: PROCEDURE;
DCL I BYTE;
DO FOREVER;
IF DCNT = 255 THEN
RETURN;
/* BFCBA = SHL(DCNT,5)+BUFFA; */
/*68K*/ BFCBA =BUFFA;
/*68K*/ BFCBAL=BFCBAL+LINT(SHL(DCNT,5));
IF BFCBUSER < 20H THEN DO;
CALL COUNT$BLKS(TRUE); /* CHECK FOR DUPLICATE BLOCK */
IF FILE$MATCH(@FCB) THEN
IF (BFCBUSER AND 0FH) = USER$CODE
THEN RETURN; /* PICK UP XFCBS AND FCBS */
END;
CALL SEARCHN;
END;
END CHECK$USER;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* SET FCBSA TO THE ITH 16 BYTE FCB IN MEMORY
SET FCBEA TO THE EXTENT BYTE OF THAT FCB */
MULTI16: PROCEDURE;
/* UTILITY TO COMPUTE FCBS ADDRESS FROM I */
/* FCBEA = (FCBSA:=SHL(I,4)+MEMBASE) + FEXT;
FCBMA = FCBSA + FMOD;
FCBS1 = FCBSA + FS1; */
/*68K*/
FCBSAL=MEMBASEL+LINT(SHL(I,4));
FCBEAL=FCBSAL+FEXT;
FCBMAL=FCBSAL+FMOD;
FCBS1L=FCBSAL+FS1;
/* 68K END */
END MULTI16;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* PARSE FILE ATTRIBUTE ASSIGNMENT */
SETFILESTATUS: PROCEDURE BYTE;
/* EVENTUALLY, SCASE1 & SCASE2
SET TO R/O=1, R/W=2, DIR=3, SYS=4, SIZE=5
SCASE1 IS FIRST ATTRIBUTE ASSIGNMENT
SCASE2 IS SECOND ATTRIBUTE ASSIGNMENT */
ERROR: PROCEDURE;
CALL PRINT(@INVALID);
CALL PRINT(@USE);
CALL PRINTX(@FILENAME);
CALL PRINTX(@('[SIZE] ',0));
CALL PRINTX(@ATTRIBUTES);
END ERROR;
IF NOT PARSE$NEXT THEN
RETURN FALSE;
IF ACCUM(0) = '=' THEN
CALL SCAN;
IF (SCASE1 := MATCH(@ATTRIBL,5)) = 5 THEN
RETURN NOT (SIZESET := TRUE);
/* MUST BE A PARAMETER */
IF SCASE1 = 0 THEN
CALL ERROR;
ELSE IF PARSE$NEXT THEN
IF (SCASE2 := MATCH(@ATTRIBL,5)) = 0 THEN
CALL ERROR;
RETURN TRUE;
END SETFILESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* SET THE ATTRIBUTE BITS */
SET$ATTRIBUTES: PROCEDURE(SCASE);
DECLARE SCASE BYTE;
DO CASE SCASE;
/* SET TO R/O */
DO;
FCBV(ROFILE) = FCBV(ROFILE) OR 80H;
CALL PRINTX(@READONLY);
END;
/* SET TO R/W */
DO;
FCBV(ROFILE) = FCBV(ROFILE) AND 7FH;
CALL PRINTX(@READWRITE);
END;
/* SET TO SYS */
DO;
FCBV(INFILE) = FCBV(INFILE) OR 80H;
CALL PRINTX(@SYSTEM);
END;
/* SET TO DIR */
DO;
FCBV(INFILE) = FCBV(INFILE) AND 7FH;
CALL PRINTX(@DIRECTORY);
END;
/* INVALID CASE */
DO;
CALL PRINT(@INVALID);
RETURN;
END;
END;
END SET$ATTRIBUTES;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* CHECK FOR DRIVE STATUS ASSIGNMENT */
COMPARE$FCB: PROC;
MATCHED = FALSE; I = 0;
DO WHILE NOT MATCHED AND I < FCBN;
/* COMPARE CURRENT ENTRY */
CALL MULTI16;
MATCHED = FILE$MATCH(FCBSA);
I = I + 1;
END;
END COMPARE$FCB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* COPY NEXT FCB INTO FCBS ARRAY */
COPY$FCB: PROC;
/* COPY TO NEW POSITION IN FCBS */
FCBN = (I := FCBN) + 1;
CALL MULTI16;
/* FCBSA SET TO NEXT TO FILL */
/* 68K MEMSIZE=@DCHAKI; */
/*68K*/ IF (FCBN > FCBMAX) OR (FCBSAL+ 16) >= MAXBL THEN
DO;
CALL PRINT(@('TOO MANY FILES',0));
CALL BOOT; /* ABORT */
END;
/* SAVE INDEX TO ELEMENT FOR LATER SORT */
FINX(I) = I;
DO KB = 0 TO FNAM;
FCBV(KB) = BFCB(KB);
END;
FCBE,FCBK,FCBR(I) = 0;
END COPY$FCB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* UPDATE STATISTICS WITH CURRENT FCB BLOCKS */
ADD$FCB$BLKS: PROC;
IF BFCB(0) < 10H THEN DO;
/* NOT AN XFCB */
/* SET ANY ATTRIBUTE THAT IS ON */
DO KB=1 TO FNAM;
IF (BFCB(KB) AND 80H) = 80H THEN
FCBV(KB) = FCBV(KB) OR 80H; /* SET */
END;
/* RESET ARCHIVED ATTRIBUTE IF IT IS OFF */
IF (BFCB(ARCHIV) AND 80H) <> 80H THEN
FCBV(ARCHIV) = FCBV(ARCHIV) AND 7FH; /* RESET */
FCBE = FCBE + 1; /* EXTENT INCREMENTED */
NFCBS = NFCBS + 1;
/* RECORD COUNT */
FCBR(I) = FCBR(I) + BFCB(FRC)
+ (BFCB(FEXT) AND DPB$BYTE(EXTMSK$B)) * 128;
/* COUNT KILOBYTES */
CALL COUNT$BLKS(FALSE);
END;
ELSE IF BFCB(0) < 20H THEN DO;
/* XFCB */
XFCB = XFCB OR 80H; /* BIT 7 = XFCB EXISTS FLAG */
NXFCBS = NXFCBS + 1;
END;
END ADD$FCB$BLKS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* SORT THE FILE NAMES IN ASCENDING ORDER */
SORT: PROCEDURE;
IF FCBN > 1 THEN /* REQUIRES AT LEAST TWO TO SORT */
DO; L = 1;
DO WHILE L > 0; /* BUBBLE SORT */
CALL TEST$BREAK;
L = 0;
DO M = 0 TO FCBN - 2;
I = FINX(M+1); CALL MULTI16; BFCBA = FCBSA; I = FINX(M);
CALL MULTI16; /* SETS FCBSA, BASING FCBV */
DO KB = 1 TO FNAM; /* COMPARE FOR LESS OR EQUAL */
IF (B:=(BFCB(KB) AND 7FH))
< (F:=(FCBV(KB) AND 7FH))
THEN /* SWITCH */
DO; K = FINX(M); FINX(M) = FINX(M + 1);
FINX(M + 1) = K; L = L + 1; KB = FNAM;
END;
ELSE IF B > F THEN KB = FNAM; /* STOP COMPARE */
END;
END;
END;
END;
END SORT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* DISPLAY THE FCBS */
DISPLAY: PROC;
DCL (WIDE, ADD, SIZECOLS) BYTE;
ADD, SIZECOLS = 0;
IF (WIDE := (COLUMNS > 48)) THEN
ADD = 7;
IF SIZESET THEN
ADD = ADD + (SIZECOLS := 10);
CALL PRINT(@DRIVENAME);
CALL SHOW$DRIVE;
CALL BLANKS(17+ADD);
CALL SHOW$USR(USER$CODE);
IF SIZESET THEN
CALL PRINT(@(' SIZE ',0));
ELSE
CALL CRLF;
CALL PRINTX(@(' RECS BYTES FCBS ATTRIB',0));
IF WIDE THEN
CALL PRINTX(@('UTES ',0));
CALL PRINTX(@(' NAME',0));
L = 0;
DO WHILE L < FCBN;
I = FINX(L); /* I IS THE INDEX TO NEXT IN ORDER */
CALL MULTI16; CALL CRLF; /* SET FCBV,FCBK,FCBE */
/* PRINT THE FILE LENGTH */
CALL MOVE(16,@FCBV(0),FCBA);
FCB(0) = 0;
/* DISPLAY SIZE */
IF SIZESET THEN
DO;
CALL GETFILESIZE(FCBA);
/* 68K CALL P3BYTE(RRECA,TRUE);*/ CALL P3BYTEL(RRECA,TRUE);
CALL PRINTB;
END;
/* DISPLAY RECORDS */
CALL PDECIMAL(FCBR(I),10000); /* RRRRR */
CALL PRINTB;
/* DISPLAY KBYTES INCREMENT 1-KBLOCKS (KBLKS) */
KBLKS = (FCBR(I) / 8) + KBLKS;
IF FCBR(I) MOD 8 <> 0 THEN
KBLKS = KBLKS + 1;
CALL PDECIMAL(FCBK,10000); /* BBBBBK */
TALL = TALL + FCBK;
CALL PRINTCHAR('K'); CALL PRINTB;
/* IS THERE AN XFCB ? (CHECK HI-BIT OF S1 BYTE) */
XFCBFOUND = ATTRIBUTE(FS1); /* SAVE FOR XFCB COLUMN */
XFCB = XFCB AND 7FH; /* CLEAR BIT7 */
/* DISPLAY # FCBS */
CALL PDECIMAL(FCBE,1000); /* EEEE */
CALL PRINTB;
/* DISPLAY ATTRIBUTES: SYS,RO,X,A,F1-F4 */
IF ATTRIBUTE(INFILE) THEN
CALL PRINTX(@('SYS',0));
ELSE
CALL PRINTX(@('DIR',0));
CALL PRINTB;
CALL PRINTCHAR('R');
IF ATTRIBUTE(ROFILE) THEN
CALL PRINTCHAR('O');
ELSE
CALL PRINTCHAR('W');
CALL PRINTB;
IF WIDE THEN DO;
/* DISPLAY # XFCBS (0 OR 1) */
IF XFCBFOUND THEN
CALL PRINTCHAR('X');
ELSE
CALL PRINTB;
CALL PRNT$ATTRIB(ARCHIV,'A');
CALL PRNT$ATTRIB(ATTRB1,'1');
CALL PRNT$ATTRIB(ATTRB2,'2');
CALL PRNT$ATTRIB(ATTRB3,'3');
CALL PRNT$ATTRIB(ATTRB4,'4');
CALL PRINTB;
END;
/* DISPLAY FILENAME */
/* PRINT FILENAME.TYP */
CALL PRINTFN(FCBSA);
/* INCREMENT FCBS COUNTER */
L = L + 1;
END;
/* SKIP PAST SIZE AND RECS FIELDS */
CALL DOTS(39+ADD);
CALL PRINT(@('TOTAL:',0));
CALL BLANKS(SIZECOLS);
CALL PDECIMAL(TALL,10000); /* TOTAL KBYTES */
CALL PRINTCHAR('K');
CALL PDECIMAL(NFCBS,10000); /* TOTAL # FCBS */
/* CALL BLANKS(2);
CALL PRINTCHAR('(');
CALL PVALUE(FCBN);
CALL PRINTX(@(' FILE',0));
IF FCBN < 2 THEN
CALL PRINTX(@(', ',0));
ELSE
CALL PRINTX(@('S, ',0));
CALL PVALUE(KBLKS);
CALL PRINTX(@('-1K BLOCKS',0));
CALL PRINTCHAR(')'); */
END DISPLAY;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* SET FILE ATTRIBUTES */
SETFILEATT: PROC;
L = 0;
DO WHILE L < FCBN;
I = L;
CALL MULTI16;
CALL CRLF;
CALL PRINTFN(FCBSA);
CALL PRINTX(@SET$TO);
CALL SET$ATTRIBUTES(SCASE1-1);
IF SCASE2 <> 0 THEN DO;
CALL PRINTX(@(', ',0));
CALL SET$ATTRIBUTES(SCASE2-1);
END;
FCBV(0) = 0; /* INCASE MATCHED USER # > 0 */
CALL SETIND(FCBSA);
L = L + 1;
END;
END SETFILEATT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* MAIN ROUTINE */
IF (SET$ATTRIBUTE := SETFILESTATUS) THEN
IF SCASE1 = 0 THEN
RETURN;
/* READ THE DIRECTORY, COLLECT ALL COMMON FILE NAMES */
/* SKIP ALLOCATION VECTOR AT THE BASE OF FREE MEMORY
USED BY THE DUPLICATE BLOCK CHECKING ROUTINES */
/* 68K */ I=SHR(DPB$WORD(BLKMAX$W)+7,3) ;
/* 68K */ IF (I MOD 2)=1 THEN I=I+1;
/* 68K */ MEMBASE = @MEMORY;
/* 68K*/ MEMBASEL=MEMBASEL+LINT(I);
CALL FILL(@MEMORY,0,I); /* CLEAR ALLOCATION VECTOR */
LB = 1;
IF (WORD$BLKS := (DPB$WORD(BLKMAX$W) > 255)) THEN
LB = 2; /* DOUBLE PRECISION BLOCK INDICES */
FCBN,FCB(0) = 0;
FCB(FEXT),FCB(FMOD) = '?'; /* QUESTION MARK MATCHES ALL */
CALL SEARCH(@UFCB); /* FILL DIRECTORY BUFFER */
CALL CHECK$USER;
/* COLLECT FCBS FOR DISPLAY */
COLLECT: /* LABEL FOR DEBUG */
DO WHILE DCNT <> 255;
/* ANOTHER ITEM FOUND, COMPARE IT FOR COMMON ENTRY */
/*68K BFCBA = SHL(DCNT AND 11B,5)+BUFFA; /* DCNT MOD 4 * 32 */
/*68K*/
DUMMYP=BUFFA;
DUMMYL=DUMMYL+LINT(SHL(DCNT AND 11B,5));
BFCBA=DUMMYP;
/* END 68K*/
CALL COMPARE$FCB;
IF MATCHED THEN
I = I - 1;
ELSE
CALL COPY$FCB;
/* ENTRY IS AT, OR WAS PLACED AT LOCATION I IN FCBS
FCBSA = FINX(I) */
CALL ADD$FCB$BLKS;
CALL SEARCHN; /* TO NEXT ENTRY IN DIRECTORY */
CALL CHECK$USER;
END; /* OF DO WHILE DCNT <> 255 */
IF NOT FIRST$ERROR THEN
CALL BOOT; /* ABORT IF DUPLICATE BLOCK ERROR */
IF FCBN = 0 THEN
CALL PRINT(@('FILE NOT FOUND',0));
ELSE IF NOT SET$ATTRIBUTE THEN
/* DISPLAY COLLECTED DATA */
DO;
CALL SORT;
CALL DISPLAY;
CALL PRALLOC;
END;
ELSE
CALL SETFILEATT;
END GETFILE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* RESET DRIVE (D:=RW) */
RESET$DRV: PROCEDURE BYTE;
DCL B ADDRESS;
B = 1;
IF CDISK <> 0 THEN
B = SHL(DOUBLE(1),CDISK);
RETURN MON2(37,B);
END RESET$DRV;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* CHECK FOR DRIVE STATUS ASSIGNMENT */
SETDRIVESTATUS: PROCEDURE;
DECLARE I BYTE;
PRDRIVE: PROC(A);
DCL A POINTER;
CALL PRINT(@DRIVENAME(1));
CALL SHOW$DRV;
CALL PRINTX(@SET$TO);
CALL PRINTX(A);
END PRDRIVE;
IF (I := MATCH(@ATTRIBL,2)) = 1 THEN DO;
CALL WRITEPROT;
CALL PRDRIVE(@READONLY);
END;
ELSE IF I = 2 THEN DO;
IF RESET$DRV <> 0 THEN
CALL PRINT(@('DISK RESET DENIED',0));
ELSE
CALL PRDRIVE(@READWRITE);
END;
ELSE DO;
CALL PRINT(@INVALID);
CALL PRINT(@USE);
CALL PRINTX(@('D:=RO',0));
END;
END SETDRIVESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* RESET DRIVE (D:=RW) */
PARSE$IT: PROCEDURE;
DCL I BYTE;
IF (I:=MATCH(@DEVL,8)) = 8 THEN
CALL DRIVESTATUS;
ELSE IF I = 7 THEN
CALL USERSTATUS;
ELSE
CALL GETFILE;
END PARSE$IT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* MAIN */
/*68K*/
/* INIT GLOBAL DATA FOR 68K(BUG OF LINKER)*/
/* */
SIZESET=0;
SET$ATTRIBUTE=0;
IBP=1;
DO LB=0 TO 6;
VAL(LB) =0;
FAC(LB) =0;
END;
LB=1;
FIRST$ERROR=TRUE;
KBLKS=0;
NFCBS=0;
NXFCBS=0;
TALL=0;
LAST$DSEG$BYTE=0;
/* INIT END */
/* 68K */ CALL SETDMA(@BUFF);
/* VER = VERSION; */ /*SPLH*/
CDISK = CSELECT;
USER$CODE = GETUSER;
/* BDOS3 = (HIGH(VER) = BDOS3VER); */ BDOS3=FALSE; /*SPLH*/
/* SIZE DISPLAY IF $S SET IN COMMAND */
IF NOT PARSE$NEXT THEN
CALL PRSTATUS;
ELSE IF ACCUM(1) = ':' THEN DO;
CALL SELECT$DISK(ACCUM(0)-'A');
IF NOT PARSE$NEXT THEN
CALL PRALLOC;
ELSE IF ACCUM(0) = '=' THEN
CALL PRINT(@('ERROR-READ ONLY STATUS NOT ALLOWED',0));
ELSE
CALL PARSE$IT;
END;
ELSE DO;
CALL SET$KPB;
IF NOT DEVREQ THEN
CALL GETFILE;
END;
/* SPLH */ CALL BOOT;
RETURN;
END PLM;
/* SPLH MAIN START */
CALL PLM;
END;
Reference in New Issue View Git Blame Copy Permalink