STAT:
DO;
	/* C P / M  S T A T U S  C O M M A N D  (S T A T)
	   
	   COPYRIGHT(C) 1975/1976 DIGITAL RESEARCH
	   
	   */
	
	STATUS: PROCEDURE PUBLIC;
		DECLARE COPYRIGHT(*) BYTE DATA (
			'   COPYRIGHT (C) 1976, DIGITAL RESEARCH');
		DECLARE
		BUFFA	LITERALLY   '80H',	/* DEFAULT BUFFER */
		FCBA	LITERALLY   '5CH',	/* DEFAULT FC9 */
		IOBA	LITERALLY   '3H';	/* I0BYTE ADDRESS */
		
		DECLARE MALM LITERALLY '241';	/* MAX BLOCK NUMBER - 1 */
		/* DUMMY OUTER PROCEDURE 'STATUS' WILL START AT 10BH */
		/* DETERMINE STATUS OF CURRENTLY SELECTED DISK */
		DECLARE ALLOCA ADDRESS;
		/* ALLOCA IS THE ADDRESS OF THE DISK ALLOCATION VECTOR */
		ALLOC BASED ALLOCA (32) BYTE; /* ALLOCATION VECTOR */
		
		MON1: PROCEDURE(F,A);
			DECLARE F BYTE;
			A ADDRESS;
			/* PATCH TO JMP 0005 */
			BDOSE: GO TO BDOSE;
			END MON1;
		
		MON2: PROCEDURE(F,A) BYTE;
			DECLARE F BYTE;
			A ADDRESS;
			/* PATCH TO JMP 0005 */
			BDOSE: GO TO BDOSE:
			RETURN 0;
			END MON2;
		
		MON3: PROCEDURE(FUNC, INFO) ADDRESS;
			DECLARE FUNC BYTE, INFO ADDRESS;
			/* PATCH TO CALL 0005 */
			BDOSE: GO TO BDOSE;
			
			/* PATCH TO MOV H,B MOV L,C */
			RETURN 0;
			END MON3;
		
		DECLARE
		TRUE LITERALLY '1';
		FALSE LITERALLY '0';
		FOREVER LITERALLY 'WHILE TRUE';
		CR LITERALLY '13';
		LF LITERALLY '10';
		WHAT LITERALLY '63';
		
		PRINTCHAR: PROCEDURE(CHAR);
			DECLARE CHAR BYTE;
			CALL MON1(2, CHAR);
			END PRINTCHAR;
		
		CRLF: PROCEDURE;
			CALL PRINTCHAR(CR);
			CALL PRINTCHAR(LF);
			END CRLF;
		
		PRINTB: PROCEDURE;
			/* PRINT BLANK CHARACTER */
			CALL PRINTCHAR(' ');
			END PRINTB;
		
		PRINT: PROCEDURE (A);
			DECLARE A ADDRESS;
			/* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
			   NEXT DOLLAR SIGN IS ENCOUNTERED */
			CALL CRLF;
			CALL MON1(9,A);
			END PRINT;
		
		PRINTX: PROCEDURE(A);
			DECLARE A ADDRESS#
				CALL MON1(9,A);
			END PRINTX;
		
		DECLARE DCNT BYTE;
		SELECT: PROCEDURE(D);
			DECLARE D BYTE;
			CALL MON I(14,D) ;
			END SELECT;
		
		OPEN: PROCEDURE(FCB);
			DECLARE FCB ADDRESS;
			DCNT = MON2(15,FCB);
			END OPEN;
		
		SEARCH: PROCEDURE(FCB);
			DECLARE FCB ADDRESS;
			DCNT = MON2(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;
		
		GETALLOCA: PROCEDURE ADDRESS;
			/* GET BASE ADDRESS OF ALLOC VECTOR */
			RETURN MON3(27,0);
			END GETALLOCA;
		
		DECLARE OLDSP ADDRESS;       /*  SP ON ENTRY */
		STACK(16) ADDRESS;      /*  THIS PROGRAM'S STACK */
		DECLARE
		FCB(33) BYTE AT (FCBA);                  /* DEFAULT  FILE  CONTROL  BLOCK */
		BUFF(128) BYTE AT (BUFFA);               /* DEFAULT BUFFER */
		IOVAL BYTE AT (IOBA);                    /* IO BYTE */
		
		
		GETALLOC: PROCEDURE (I) BYTE;
			/* RETURN THE ITH BIT OF THE ALLOC VECTOR */
			DECLARE I BYTE;
			RETURN;
			ROL(ALLOC(SHR(I,3)), (I AND 111B) + 1);
			END GETALLOC;
		
		DEVREQ: PROCEDURE BYTE;
			/* PROCESS DEVICE REQUEST, RETURN TRUE IF FOUND */
			/* DEVICE TABLES */
			DECLARE DEVL(*) BYTE DATA
				('CON:PDR:PUN:LST:DEV:VAL:');
			DEVR(*) BYTE DATA
			(/* CONSOLE */ 'TTY:CRT:BAT:UC1:',
			/* READER  */ 'TTY:PTR:UR1:UR2:',
			/* PUNCH   */ 'TTY:PTP:UP1:UP2:',
			/* LISTING */ 'TTY:CRT:LPT:UL1:');
			
			DECLARE ACCUM(4) BYTE,
				(ISP,I,J,IOBYTE, ITEMS) BYTE;
			
			SCAN: PROCEDURE;
				/* FILL ACCUM WITH NEXT INPUT VALUE */
				DECLARE (I,B) BYTE;
				SETACC: PROCEDURE(B);
					DECLARE B BYTE;
					ACCUM(I) * B; I=I+1;
					END SETACC;
				
				/* DEBLANK INPUT */
				DO WHILE BUFF(IBP) = ' '; IBP-IBP+1;
					END;
				/* INITIALIZE ACCUM LENGTH */
				I = 0;
				DO WHILE I < 4;
					IF (B := BUFF(IBP)) > 1 THEN /* VALID */
						CALL SETACC(B); ELSE /* BLANK FILL */
						CALL SETACC(' ');
					IF B3 <= 1 OR
						B = ';' OR
					B = ',' OR
					B = '=' OR
					B = '*' OR
					B = '.' OR
					B = '>' OR
					B = '<' THEN BUFF(IBP) = 1;
					ELSE
						IBP = IBP + 1;
					END;
				IBP = IBP + 1;
				END SCAN;
			
			MATCH: PROCEDURE(VA,VL) BYTE;
				/* RETURN INDEX+1 TO VECTOR AT VA IF MATCH */
				DECLARE VA ADDRESS;
				V BASED VA (16) BYTE;
				YL 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;
			
			PRNAME: PROCEDURE(A);
				DECLARE A ADDRESS,
					X BASED A BYTE;
				/* PRINT DEVICE NAME AT A */
				DO WHILE X <> ':';
					CALL PRINTCHAR(X); A=A+l;
					END;
				CALL PRINTCHAR(':');
				END PRNAME;
			
			IBP=1; ITEMS = 0;
			DO FOREVER;
				CALL SCAN;
				IF (1:=MATCH(.DEVL,6)) = 3 THEN RETURN ITEMS<>0;
				ITEMS = ITEMS+1; /* FOUND FIRST/NEXT ITEM */
				IF I = 5 THEN /* DEVICE STATUS REQUEST */
					DO;
					IOBYTE = IOVAL; J = 0;
					DO I = 0 TO 3;
						CALL PRNAME(.DEVL(SHL(I,2)));
						CALL PRINTX(.(' IS $')) ;
						CALL PRNAME(.DEVR(SHL(IOBYTE AND 11B,2)+J));
						J = J + 16; IOBYTE = SHR(IOBYTE,2);
						CALL CRLF;
						END;
					END; ELSE /* NOT DEV: */
					IF I = 6 THEN /* LIST POSSIBLE ASSIGNMENT */
					DO I = 0 TO 3; /* EACH LINE SHOWS ONE DEVICE */
					CALL CRLF;
					CALL PRNAME(.DEVL(SHL(I,2)));
					CALL PRINTX(.(' =$'));
					DO J = 0 TO 12 BY 4;
						CALL PRINTCHAR(' ');
						CALL PRNAME(.DEVR(SHL(I,4)+J));
						END;
					END; ELSE
					/* SCAN ITEM I-1 IN DEVICE TABLE */
				DO; /* FIND BASE OF DESTINATION */
					J = SHL(I:=I-1,4) ;
					CALL SCAN;
					IF ACCUM(0) <> '=' THEN
						DO; CALL PRINT(.('BAD DELIMITER$'));
						RETURN TRUE;
						END;
					CALL SCAN;
					IF (J:=MATCH(.DEVR(J),4)-l) = 255 THEN
						DO; CALL PRINT(.('INVALID ASSIGNMENT$'));
						RETURN TRUE;
						END;
					IOBYTE = 1111$1100B; /* CONSTRUCT MASK */
					DO WHILE (I:=I-1) <> 255;
						IOBYTE = ROL(IOBYTE,2);
						J = SHL(J,2);
						END;
					IOVAL = (IOVAL AND IOBYTE) OR J;
					END;
				/* END OF CURRENT ITEM, LOOK FOR MORE */
				CALL SCAN;
				IF ACCUM(0) = ' ' THEN RETURN TRUE;
				IF ACCUM(0) <> ',' THEN
					DO; CALL PRINT(.('BAD DELIMITER$'));
					RETURN TRUE;
					END;
				END; /* OF DO FOREVER */
			END DEVREQ;
		
		COUNT: PROCEDURE BYTE;
			/* COUNT RETURNS THE NUMBER OF BLOCKS REMAINING */
			DECLARE C BYTE; /* COUNT */
			I BYTE; /* SEARCH */
			C = 0;
			DO I - 0 TO MALM;
				IF NOT GETALLOC(I) THEN C = C + I;
				END;
			RETURN C;
			END COUNT;
		
		PVALUE: PROCEDURE(V);
			DECLARE (K,V,D,ZERO) BYTE;
			K = 180;
			ZERO = FALSE;
			DC WHILE K <> 0;
			D = V / K;  V = V MOD K;
			K = K / 10;
			IF ZERO OR  K <> 3 THEN
				DO; ZERO - TRUE; CALL PRINTCHAR('0'+D);
				END;
			END;
		CALL DOCHAR('K');
		CALL CRLF;
		END PVALUE;
	
	PRALLOC: PROCEDURE;
		/* PRINT ALLOCATION FOR CURRENT DISK */
		CALL PRINT (.('BYTES REMAINING ON $'));
		ALLOCA = GETALLOCA;
		CALL PRINTCHAR(CSELECT+'A');
		CALL PRINTX(.(', $'));
		CALL PVALUE(COUNT);
		END PRALLOC;
	
	GETFILE: PROCEDURE;
		/* PROCESS FILE REQUEST */
		
		DECLARE
		FNAM LITERALLY '11',    FEXT LITERALLY  '12',
		FRC  LITERALLY '15',    FLN   LITERALLY '15',
		FDM  LITERALLY '16',    FDL   LITERALLY '31',
		FTYP LITERALLY '9';
		
		DECLARE
			FCBN BYTE,						/* NUMBER OF FCB'S COLLECTED SO FAR */
			FCBS(3840) BYTE,				/* FCB STORAGE = 16*253*3846 */
			FINX(255) BYTE,					/* INDEX VECTOR USED DURING SORT */
			FCBE(255) BYTE,					/* EXTENT COUNTS */
			FCBK(255) BYTE,					/*  KILOBYTE COUNT */
			FCBR(255) ADDRESS;				/* RECORD COUNT */
			DECLARE
			BFCBA ADDRESS,					/* INDEX INTO DIRECTORY BUFFER */
			FCBSA ADDRESS,					/* INDEX INTO FCBS */
			BFCB BASED BFCBA (32) BYTE,		/* TEMPLATE OVER DIRECTORY */
			FCBV BASED FCBSA (16) BYTE;		/* TEMPLATE OVER FCBS ENTRY */
			DECLARE
			I BYTE,							/* FCB COUNTER DURING COLLECTION AND DISPLAY */
			(K,L,M) BYTE,					/* LOOP COUNTERS */
			(B,F) BYTE,						/* TEMPS USED DURING SORT */
			MATCHED BYTE;					/*  USED DURING FCBS SEARCH */
		
		MULTI16: PROCEDURE;
			/* UTILITY TO COMPUTE FCBS ADDRESS FROM I */
			FCBSA = SHL(DOUBLE(I),4 ) + FCBS;
			END MULTI16;
		
		PDECIMAL: PROCEDURE(V,PREC);
			/* PRINT VALUE V WITH PRECISION PREC (10,100,1000)
			   WITH LEADING 2ER0 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;
		
		/* READ THE DIRECTORY/ COLLECT ALL COMMON FILE NAMES */
		FCBN,FCB(0) = 0;
		FCB(FEXT) = 63;						/* QUESTION MARK MATCHES ALL */
		CALL SEARCH(FCBA);					/* FILL DIRECTORY BUFFER */
		DO WHILE DCNT <> 255;
			/* ANOTHER ITEM FOUND, COMPARE IT FOR COMMON ENTRY */
			BFCBA = SHL(DCNT AND 11B,5)+BUFFA; /* DCNT MOD 4 * 32 */
			MATCHED = FALSE; I = 0;
			DO WHILE NOT MATCHED AND I < FCBN;
				/* COMPARE CURRENT ENTRY */
				CALL MULTI16;
				DO K = 1 TO FNAM;
					IF BFCB(K) <> FCBV(K) THEN K = FNAM; ELSE
					/* COMPLETE MATCH IF AT END */
					MATCHED = K = FNAM;
					END;
				I = I + 1;
				END;
			
			IF MATCHED THEN I = I - 1; ELSE
			DO;										/* COPY TO NEW POSITION IN FCBS */
				FCBN = (I := FCBN) +  1 ;
				CALL MULTI16;
				/* SAVE INDEX TO ELEMENT FOR LATER SORT */
				FINX(I) = I;
				DO K = 0 TO FNAM;
					FCBV(K) = BFCB(K);
					END;
				FCBE(I),FCBK(I),FCBR(I) = 0;
				END;
			/* ENTRY IS AT, OR WAS PLACED AT LOCATION I IN FCBS
			   FCBE(I) = FCBE(I) + I;				/* EXTENT INCREMENTED  */
			FCBR(I) = FCBR(I) + BFCB(FRC);			/* RECORD COUNT */
			/* COUNT KILOBYTES */
			DO K = FDM TO FDL;
				IF BFCB(K) <> 0 THEN
					FCBK(I) = FCBK(I) + 1;
				END;
			CALL SEARCHN;							/* TO NEXT ENTRY IN DIRECTORY */
			END; /* OF DO WHILE DCNT () 255 */
		
		/* NOW DISPLAY THE COLLECTED DATA */
		IF FCBN = 0 THEN CALL PRINT(.('FILE NOT FOUND$')); ELSE
		DO;
			/* SORT THE FILE NAMES IN ASCENDING ORDER */
			IF FCBN > 1 THEN						/* REQUIRES AT LEAST TWO TO SORT */
				DO; L = 1;
				DO WHILE L > 0;						/* BUBBLE SORT */
					L = 0;
					DO M = 0 TO FCBN - 2;
						I * FINX(M+l); CALL MULTI16; BFCBA = FCBSA; I = FINX(M);
						CALL MULTI16; /* SETS FCBSA, BASING FCBV */
						DO K = 1 TO FNAM; /* COMPARE FOR LESS OR EQUAL */
							IF (B:=BFCB(K)) < (F:=FCBV(K)) THEN /* SWITCH */
								DO; K = FINX(M); FINX(M) = FINX(M + 1);
								FINX(M + 1) = K; L = L + 1; K = FNAM;
								END;
							ELSE IF B > F THEN K := FNAM; /* STOP COMPARE */
							END;
						END;
					END;
				END;
			CALL PRINT(.('RECS BYTS EX D:FILENAME.TYP$')) ;
			L = 0;
			DO WHILE L < FCBN;
				I = FINX(L);						/* I IS THE INDEX TO NEXT IN ORDER */
				CALL MULTI16; CALL CRLF;
				CALL PDECIMAL(FCBR(I), 1000);		/* RRRR */
				CALL PRINTB; /* BLANK */
				CALL PDECIMAL(FCBK(!),100);			/* BBB  */
				CALL PRINTCHAR('K'); CALL PRINTB;
				CALL PDECIMAL(FCBE(I),10);			/* EE */
				CALL PRINTB;
				CALL PRINTCHAR('A'+CSELECT); CALL PRINTCHAR(':');
				/* PRINT FILENAME.TYP */
				DO K = 1 TO FNAM;
					IF FCSV(K) <> ' ' THEN
						DO; IF K = FTYP THEN CALL PRINTCHAR('.');
						CALL PRINTCHAR(FCBV(K));
						END;
					END;
				L = L + 1;
				END;
			IF FCB(1) = 63 OR FCB(FTYP) = 63 THEN CALL PRALLOC;
			END;
		END GETFILE;
	
	/* SAVE STACK POINTER AND RESET */
	OLDSP = STACKPTR;
	STACKPTR = STACK(LENGTH(STACK));
	
	/* PROCESS REQUEST */
	IF FCB(0) <> 0 THEN CALL SELECT(FCB(0)-1);
	IF FCB(1) = ' ' THEN CALL PRALLOC; /* PRINT ALLOCATION */
	ELSE
		IF NOT DEVREQ THEN /* MUST BE FILE NAME */
		CALL GETFILE;
	/* RESTORE OLD STACK BEFORE EXIT */
	STACKPTR = OLDSP;
	END STATUS;
END;
