Upload

Digital Research

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as0com.asm

@@ -0,0 +1,52 @@
+	TITLE	'ASM COMMON DATA AREA'
+;
+;	COPYRIGHT (C) 1977, 1978, 1979, 1980, 1981
+;	DIGITAL RESEARCH
+;	BOX 579, PACIFIC GROVE
+;	CALIFORNIA, 93950
+;
+;	Revised:
+;	  14 Sept 81  by Thomas Rolander
+;
+;	COMMON DATA FOR MP/M ASSEMBLER MODULE
+	org	0
+base	equ	$
+
+	ORG	100H
+ENDA	EQU	base+20F0H	;END OF ASSEMBLER PROGRAM
+BDOS	EQU	base+5H	;ENTRY TO DOS, USED TO COMPUTE END MEMORY
+	LXI	SP,ENDMOD
+	LHLD	BDOS+1
+	SHLD	SYMAX	;COMPUTE END OF MEMORY
+	JMP	ENDMOD
+COPY:	DB	' COPYRIGHT(C) 1981, DIGITAL RESEARCH '
+	org	10ch
+;
+;	PRINT BUFFER AND PRINT BUFFER POINTER
+PBMAX	EQU	90	;MAX PRINT BUFFER
+PBUFF:	DS	PBMAX
+PBP:	DS	1	;PRINT BUFFER POINTER
+;
+;	SCANNER PARAMETERS
+TOKEN:	DS	1	;CURRENT TOKEN
+VALUE:	DS	2	;BINARY VALUE FOR NUMBERS
+ACCLEN:	DS	1	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;LENGTH OF ACCUMULATOR
+ACCUM:	DS	ACMAX	;ACCUMULATOR (MUST FOLLLOW ACCLEN)
+;
+;	OPERAND EXPRESSION EVALUATOR PARAMETERS
+EVALUE:	DS	2	;VALUE OF EXPRESSION AFTER EVALUATION
+;
+;	SYMBOL TABLE  MODULE PARAMETERS
+SYTOP:	DW	ENDA	;FIRST LOCATION AVAILABLE FOR SYMBOL TABLE
+SYMAX:	DS	2	;LAST AVAILABLE LOCATION FOR SYMBOL TABLE
+;
+;	MISCELLANEOUS DATA AREAS
+PASS:	DS	1	;PASS # 0,1
+FPC:	DS	2	;FILL ADDRESS FOR NEXT HEX RECORD
+ASPC:	DS	2	;ASSEMBLER'S PSEUDO PC
+SYBAS:	DW	ENDA	;SYMBOL TABLE BASE
+SYADR:	DS	2	;CURRENT SYMBOL BASE
+ENDMOD	EQU	($ AND 0FF00H)+100H
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as1io.asm

@@ -0,0 +1,730 @@
+	TITLE	'ASM IO MODULE'
+;	I/O MODULE FOR MP/M ASSEMBLER
+;
+	org	0
+base	equ	$
+
+	ORG	200H
+BOOT	EQU	base+00H	;REBOOT LOCATION
+;	I/O MODULE ENTRY POINTS
+	JMP	INIT	;INITIALIZE, START ASSEMBLER
+	JMP	SETUP	;FILE SETUP
+	JMP	GNC	;GET NEXT CHARACTER
+	JMP	PNC	;PUT NEXT OUTPUT CHARACTER
+	JMP	PNB	;PUT NEXT HEX BYTE
+	JMP	PCHAR	;PRINT CONSOLE CHARACTER
+	JMP	PCON	;PRINT CONSOLE BUFFER TO CRLF
+	JMP	WOBUFF	;WRITE OUTBUFFER
+	JMP	PERR	;PLACE ERROR CHARACTER INTO PBUFF
+	JMP	DHEX	;PLACE HEX BYTE INTO OUTPUT BUFFER
+	JMP	EOR	;END OF ASSEMBLY
+;	DATA FOR I/O MODULE
+BPC:	DS	2	;BASE PC FOR CURRENT HEX RECORD
+DBL:	DS	1	;HEX BUFFER LENGTH
+DBUFF:	DS	16	;HEX BUFFER
+;
+;	DISK NAMES
+CDISK:	DS	1	;CURRENTLY SELECTED DISK
+ADISK:	DS	1	;.ASM DISK
+PDISK:	DS	1	;.PRN DISK
+HDISK:	DS	1	;.HEX DISK
+;
+;
+;
+;	COMMON EQUATES
+QBMAX	EQU	90	;MAX PRINT SIZE
+QBUFF	EQU	base+10CH	;PRINT BUFFER
+QBP	EQU	QBUFF+QBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	QBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR DHEX ROUTINE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+;
+CR	EQU	0DH	;CARRIAGE RETURN
+LF	EQU	0AH	;LINE FEED
+EOF	EQU	1AH	;END OF FILE MARK
+;
+;
+;	DOS ENTRY POINTS
+BDOS	EQU	base+5H	;DOS ENTRY POINT
+READC	EQU	1	;READ CONSOLE DEVICE
+WRITC	EQU	2	;WRITE CONSOLE DEVICE
+REDYC	EQU	11	;CONSOLE CHARACTER READY
+SELECT	EQU	14	;SELECT DISK SPECIFIED BY REGISTER E
+OPENF	EQU	15	;OPEN FILE
+CLOSF	EQU	16	;CLOSE FILE
+DELEF	EQU	19	;DELETE FILE
+READF	EQU	20	;READ FILE
+WRITF	EQU	21	;WRITE FILE
+MAKEF	EQU	22	;MAKE A FILE
+CSEL	EQU	25	;RETURN CURRENTLY SELECTED DISK
+SETDM	EQU	26	;SET DMA ADDRESS
+;
+;	FILE AND BUFFERING PARAMETERS
+NSB	EQU	8	;NUMBER OF SOURCE BUFFERS
+NPB	EQU	6	;NUMBER OF PRINT BUFFERS
+NHB	EQU	6	;NUMBER OF HEX BUFFERS
+;
+SSIZE	EQU	NSB*128
+PSIZE	EQU	NPB*128
+HSIZE	EQU	NHB*128
+;
+;	FILE CONTROL BLOCKS
+SCB:	DS	9	;FILE NAME
+	DB	'ASM'	;FILE TYPE
+SCBR:	DS	1	;REEL NUMBER (ZEROED IN SETUP)
+	DS	19	;MISC AND DISK MAP
+SCBCR:	DS	1	;CURRENT RECORD (ZEROED IN SETUP)
+;
+PCB:	DS	9
+	DB	'PRN',0
+	DS	19
+	DB	0	;RECORD TO WRITE NEXT
+;
+HCB:	DS	9
+	DB	'HEX',0
+	DS	19
+	DB	0
+;
+;	POINTERS AND BUFFERS
+SBP:	DW	SSIZE	;NEXT CHARACTER POSITION TO READ
+SBUFF:	DS	SSIZE
+;
+PBP:	DW	0
+PBUFF:	DS	PSIZE
+;
+HBP:	DW	0
+HBUFF:	DS	HSIZE
+FCB	EQU	base+5CH	;FILE CONTROL BLOCK ADDRESS
+FNM	EQU	1	;POSITION OF FILE NAME
+FLN	EQU	9	;FILE NAME LENGTH
+BUFF	EQU	base+80H	;INPUT DISK BUFFER ADDRESS
+;
+SEL:	;SELECT DISK IN REG-A
+	LXI	H,CDISK
+	CMP	M	;SAME?
+	RZ
+	MOV	M,A	;CHANGE CURRENT DISK
+	MOV	E,A
+	MVI	C,SELECT
+	CALL	BDOS
+	RET
+;
+SCNP:	;SCAN THE NEXT PARAMETER
+	INX	H
+	MOV	A,M
+	CPI	' '
+	JZ	SCNP0
+	SBI	'A'	;NORMALIZE
+	RET
+SCNP0:	LDA	CDISK
+	RET
+;
+PCON:	;PRINT MESSAGE AT H,L TO CONSOLE DEVICE
+	MOV	A,M
+	CALL	PCHAR
+	MOV	A,M
+	INX	H
+	CPI	CR
+	JNZ	PCON
+	MVI	A,LF
+	CALL	PCHAR
+	RET
+;
+FNAME:	;FILL NAME FROM DEFAULT FILE CONTROL BLOCK
+	LXI	D,FCB
+	MVI	B,FLN
+FNAM0:	LDAX	D	;GET NEXT FILE CHARACTER
+	CPI	'?'
+	JZ	FNERR	;FILE NAME ERROR
+	MOV	M,A	;STORE TO FILE CNTRL BLOCK
+	INX	H
+	INX	D
+	DCR	B
+	JNZ	FNAM0	;FOR NEXT CHARACTER
+	RET
+;
+INIT:	;SET UP STACK AND FILES, START ASSEMBLER
+	LXI	H,TITL
+	CALL	PCON
+	JMP	SET0
+;
+OPEN:	;OPEN FILE ADDRESSED BY D,E
+	MVI	C,OPENF
+	CALL	BDOS
+	CPI	255
+	RNZ
+;	OPEN ERROR
+	LXI	H,ERROP
+	CALL	PCON
+	JMP	BOOT
+;
+CLOSE:	;CLOSE FILE ADDRESSED BY D,E
+	MVI	C,CLOSF
+	CALL	BDOS
+	CPI	255
+	RNZ		;CLOSE OK
+	LXI	H,ERRCL
+	CALL	PCON
+	JMP	BOOT
+;
+DELETE:	;DELETE FILE ADDRESSED BY D,E
+	MVI	C,DELEF
+	JMP	BDOS
+;
+MAKE:	;MAKE FILE ADDRESSED BY D,E
+	MVI	C,MAKEF
+	CALL	BDOS
+	CPI	255
+	RNZ
+;	MAKE ERROR
+	LXI	H,ERRMA
+	CALL	PCON
+	JMP	BOOT
+;
+SELA:	LDA	ADISK
+	CALL	SEL
+	RET
+;
+NPR:	;RETURN ZERO FLAG IF NO PRINT FILE
+	LDA	PDISK
+	CPI	'Z'-'A'
+	RZ
+	CPI	'X'-'A'	;CONSOLE
+	RET
+;
+SELP:	LDA	PDISK
+	CALL	SEL
+	RET
+;
+SELH:	LDA	HDISK
+	CALL	SEL
+	RET
+;
+SET0:	;SET UP FILES FOR INPUT AND OUTPUT
+	LDA	FCB	;GET FIRST CHARACTER
+	CPI	' '	;MAY HAVE FORGOTTEN NAME
+	JZ	FNERR	;FILE NAME ERROR
+	MVI	C,CSEL	;CURRENT DISK?
+	CALL	BDOS	;GET IT TO REG-A
+	STA	CDISK
+;
+;	SCAN PARAMETERS
+	LXI	H,FCB+FLN-1
+	CALL	SCNP
+	STA	ADISK
+	CALL	SCNP
+	STA	HDISK
+	CALL	SCNP
+	STA	PDISK
+;
+	LXI	H,SCB	;ADDRESS SOURCE FILE CONTROL BLOCK
+	CALL	FNAME		;FILE NAME OBTAINED FROM DEFAULT FCB
+;
+	CALL	NPR	;Z OR X?
+	JZ	NOPR
+	LXI	H,PCB	;ADDRESS PRINT FILE CONTROL BLOCK
+	PUSH	H	;SAVE A COPY FOR OPEN
+	PUSH	H	;SAVE A COPY FOR DELETE
+	CALL	FNAME	;FILL PCB
+	CALL	SELP
+	POP	D	;FCB ADDRESS
+	CALL	DELETE
+	POP	D	;FCB ADDRESS
+	CALL	MAKE
+;
+NOPR:	;TEST FOR HEX FILE
+	LDA	HDISK
+	CPI	'Z'-'A'
+	JZ	NOHEX
+	LXI	H,HCB
+	PUSH	H
+	PUSH	H
+	CALL	FNAME
+	CALL	SELH
+	POP	D
+	CALL	DELETE
+	POP	D
+	CALL	MAKE
+;
+;	FILES SET UP, CALL ASSEMBLER
+NOHEX:	JMP	ENDMOD
+;
+SETUP:	;SETUP INPUT FILE FOR SOURCE PROGRAM
+	LXI	H,SSIZE
+	SHLD	SBP	;CAUSE IMMEDIATE READ
+	XRA	A	;ZERO VALUE
+	STA	SCBR	;CLEAR REEL NUMBER
+	STA	SCBCR		;CLEAR CURRENT RECORD
+	STA	DBL		;CLEAR HEX BUFFER LENGTH
+	CALL	SELA
+	LXI	D,SCB
+	CALL	OPEN
+;
+	RET
+;
+FNERR:	;FILE NAME ERROR
+	LXI	H,ERRFN
+	CALL	PCON
+	JMP	BOOT
+;
+;
+GCOMP:	;COMPARE D,E AGAINS H,L
+	MOV	A,D
+	CMP	H
+	RNZ
+	MOV	A,E
+	CMP	L
+	RET
+;
+GNC:	;GET NEXT CHARACTER FROM SOURCE BUFFER
+	PUSH	B
+	PUSH	D
+	PUSH	H	;ENVIRONMENT SAVED
+	LHLD	SBP
+	LXI	D,SSIZE
+	CALL	GCOMP
+	JNZ	GNC2
+;
+;	READ ANOTHER BUFFER
+	CALL	SELA
+	LXI	H,0
+	SHLD	SBP
+	MVI	B,NSB	;NUMBER OF SOURCE BUFFERS
+	LXI	H,SBUFF
+GNC0:	;READ 128 BYTES
+	PUSH	B	;SAVE COUNT
+	PUSH	H	;SAVE BUFFER ADDRESS
+	MVI	C,READF
+	LXI	D,SCB
+	CALL	BDOS	;PERFORM THE READ
+	POP	H	;RESTORE BUFFER ADDRESS
+	POP	B	;RESTORE BUFFER COUNT
+	ORA	A	;SET FLAGS
+	MVI	C,128
+	JNZ	GNC1
+;	NORMAL READ OCCURRED
+	LXI	D,BUFF	;SOURCE BUFFER ADDRESS
+	MVI	C,128
+MOV0:	LDAX	D	;GET CHARACTER
+	MOV	M,A	;STORE CHARACTER
+	INX	D
+	INX	H
+	DCR	C
+	JNZ	MOV0
+;	BUFFER LOADED, TRY NEXT BUFFER
+;
+	DCR	B
+	JNZ	GNC0
+	JMP	GNC2
+;
+GNC1:	;EOF OR ERROR
+	CPI	3	;ALLOW 0,1,2
+	JNC	FRERR	;FILE READ ERROR
+GNCE:	MVI	M,EOF	;STORE AND END OF FILE CHARACTER
+	INX	H
+	DCR	C
+	JNZ	GNCE	;FILL CURRENT BUFFER WITH EOF'S
+;
+GNC2:	;GET CHARACTER TO ACCUMULATOR AND RETURN
+	LXI	D,SBUFF
+	LHLD	SBP
+	PUSH	H	;SAVE CURRENT SBP
+	INX	H	;READY FOR NEXT READ
+	SHLD	SBP
+	POP	H	;RESTORE PREVIOUS SBP
+	DAD	D	;ABSOLUTE ADDRESS OF CHARACTER
+	MOV	A,M	;GET IT
+	POP	H
+	POP	D
+	POP	B
+	RET
+;
+FRERR:	LXI	H,ERRFR
+	CALL	PCON	;PRINT READ ERROR MESSAGE
+	JMP	BOOT
+;
+PNC:	;SAME AT PNCF, BUT ENVIRONMENT IS SAVED FIRST
+	PUSH	B
+;	CHECK FOR CONSOLE OUTPUT / NO OUTPUT
+	MOV	B,A	;SAVE CHARACTER
+	LDA	PDISK	;Z OR X?
+	CPI	'Z'-'A'	;Z NO OUTPUT
+	JZ	PNRET
+;
+	CPI	'X'-'A'
+	MOV	A,B	;RECOVER CHAR FOR CON OUT
+	JNZ	PNGO
+	CALL	PCHAR
+	JMP	PNRET
+;
+;	NOT X OR Z, SO PRINT IT
+PNGO:	PUSH	D
+	PUSH	H
+	CALL	PNCF
+	POP	H
+	POP	D
+PNRET:	POP	B
+	RET
+;
+PNCF:	;PRINT NEXT CHARACTER
+	LHLD	PBP
+	XCHG
+	LXI	H,PBUFF
+	DAD	D
+	MOV	M,A	;CHARACTER STORED AT PBP IN PBUFF
+	XCHG		;PBP TO H,L
+	INX	H	;POINT TO NEXT CHARACTER
+	SHLD	PBP	;REPLACE IT
+	XCHG
+	LXI	H,PSIZE
+	CALL	GCOMP	;AT END OF BUFFER?
+	RNZ		;RETURN IF NOT
+;
+;	OVERFLOW, WRITE BUFFER
+	CALL	SELP
+	LXI	H,0
+	SHLD	PBP
+	LXI	H,PBUFF
+	LXI	D,PCB	;D,E ADDRESS FILE CONTROL BLOCK
+	MVI	B,NPB	;NUMBER OF BUFFERS TO B
+;	(DROP THROUGH TO WBUFF)
+;
+WBUFF:	;WRITE BUFFERS STARTING AT H,L FOR B BUFFERS
+;	CHECK FOR EOF'S
+	MOV	A,M
+	CPI	EOF
+	RZ		;DON'T DO THE WRITE
+;
+	PUSH	B	;SAVE NUMBER OF BUFFERS
+	PUSH	D	;SAVE FCB ADDRESS
+	MVI	C,128	;READY FOR MOVE
+	LXI	D,BUFF
+WBUF0:	;MOVE TO BUFFER
+	MOV	A,M	;GET CHARACTER
+	STAX	D	;PUT CHARACTER
+	INX	H
+	INX	D
+	DCR	C
+	JNZ	WBUF0
+;
+;	WRITE BUFFER
+	POP	D	;RECOVER FCB ADDRESS
+	PUSH	D	;SAVE IT AGAIN FOR LATER
+	PUSH	H	;SAVE BUFFER ADDRESS
+	MVI	C,WRITF	;DOS WRITE FUNCTION
+	CALL	BDOS
+	POP	H	;RECOVER BUFFER ADDRESS
+	POP	D	;RECOVER FCB ADDRESS
+	POP	B	;RECOVER BUFFER COUNT
+	ORA	A	;SET ERROR RETURN FLAGS
+	JNZ	FWERR
+;
+;	WRITE OK
+	DCR	B
+	RZ		;RETURN IF NO MORE BUFFERS TO WRITE
+	JMP	WBUFF
+;
+FWERR:	;ERROR IN WRITE
+	LXI	H,ERRFW
+	CALL	PCON	;ERROR MESSAGE OUT
+	JMP	EORC	;TO CLOSE AND REBOOT
+;
+;
+PNB:	;PUT NEXT HEX BYTE
+	PUSH	B
+	PUSH	D
+	PUSH	H
+	CALL	PNBF
+	POP	H
+	POP	D
+	POP	B
+	RET
+;
+PNBF:	;PUT NEXT BYTE
+;	(SIMILAR TO THE PNCF SUBROUTINE)
+	LHLD	HBP
+	XCHG
+	LXI	H,HBUFF
+	DAD	D
+	MOV	M,A	;CHARACTER STORED AT HBP IN HBUFF
+	XCHG
+	INX	H	;HBP INCREMENTED
+	SHLD	HBP
+	XCHG		;BACK TO D,E
+	LXI	H,HSIZE
+	CALL	GCOMP	;EQUAL?
+	RNZ
+;
+;	OVERFLOW, WRITE BUFFERS
+	CALL	SELH
+	LXI	H,0
+	SHLD	HBP
+	LXI	H,HBUFF
+	LXI	D,HCB	;FILE CONTROL BLOCK FOR HEX FILE
+	MVI	B,NHB
+	JMP	WBUFF	;WRITE BUFFERS
+;
+PCHAR:	;PRINT CHARACTER IN REGISTER A
+	PUSH	B
+	PUSH	D
+	PUSH	H
+	MVI	C,WRITC
+	MOV	E,A
+	CALL	BDOS
+	POP	H
+	POP	D
+	POP	B
+	RET
+;
+WOCHAR:	;WRITE CHARACTER IN REG-A WITH REFLECT AT CONSOLE IF ERROR
+	MOV	C,A	;SAVE THE CHAR
+	CALL	PNC	;PRINT CHAR
+	LDA	QBUFF
+	CPI	' '
+	RZ
+;	ERROR IN LINE
+	LDA	PDISK
+	CPI	'X'-'A'
+	RZ		;ALREADY PRINTED IF 'X'
+;
+	MOV	A,C	;RECOVER CHARACTER
+	CALL	PCHAR	;PRINT IT
+	RET
+;
+WOBUFF:	;WRITE THE OUTPUT BUFFER TO THE PRINT FILE
+	LDA	QBP	;GET CHARACTER COUNT
+	LXI	H,QBUFF	;BASE OF BUFFER
+WOB0:	ORA	A	;ZERO COUNT?
+	JZ	WOBE
+;	NOT END, SAVE COUNT AND GET CHARACTER
+	MOV	B,A	;SAVE COUNT
+	MOV	A,M
+	CALL	WOCHAR	;WRITE CHARACTER
+	INX	H	;ADDRESS NEXT CHARACTER OF BUFFER
+	MOV	A,B	;GET COUNT
+	DCR	A
+	JMP	WOB0
+;
+WOBE:	;END OF PRINT - ZERO QBP
+	STA	QBP
+;	FOLLOW BY CR LF
+	MVI	A,CR
+	CALL	WOCHAR
+	MVI	A,LF
+	CALL	WOCHAR
+	LXI	H,QBUFF
+	MVI	A,QBMAX	;READY TO BLANK OUT
+WOB2:	MVI	M,' '
+	INX	H
+	DCR	A
+	JNZ	WOB2
+	RET
+;
+;
+PERR:	;FILL QBUFF ERROR MESSAGE POSITION
+	MOV	B,A	;SAVE CHARACTER
+	LXI	H,QBUFF
+	MOV	A,M
+	CPI	' '
+	RNZ	;DON'T CHANGE IT IF ALREADY SET
+	MOV	M,B	;STORE ERROR CHARACTER
+	RET
+;
+EOR:	;END OF ASSEMBLER
+	CALL	NPR	;Z OR A?
+	JZ	EOPR
+;	FILL OUTPUT FILES WITH EOF'S
+EOR2:	LHLD	PBP
+	MOV	A,L
+	ORA	H	;VALUE ZERO?
+	JZ	EOPR
+	MVI	A,EOF	;CTL-Z IS END OF FILE
+	CALL	PNC	;PUT ENDFILES IN PRINT BUFFER
+	JMP	EOR2	;EVENTUALLY BUFFER IS WRITTEN
+;
+EOPR:	;END OF PRINT FILE, CHECK HEX
+	LDA	HDISK
+	CPI	'Z'-'A'
+	JZ	EORC
+EOR0:	;WRITE TERMINATING RECORD INTO HEX FILE
+	LDA	DBL	;MAY BE ZERO ALREADY
+	ORA	A
+	CNZ	WHEX	;WRITE HEX BUFFER IF NOT ZERO
+	LHLD	FPC	;GET CURRENT FPC AS LAST ADDRESS
+	SHLD	BPC	;RECORD LENGTH ZERO, BASE ADDRESS 0000
+	CALL	WHEX	;WRITE HEX BUFFER
+;
+;	NOW CLEAR OUTPUT BUFFER FOR HEX FILE
+EOR1:	LHLD	HBP
+	MOV	A,L
+	ORA	H
+	JZ	EORC
+	MVI	A,EOF
+	CALL	PNB
+	JMP	EOR1
+;
+;	CLOSE FILES AND TERMINATE
+EORC:
+	CALL	NPR
+	JZ	EORPC
+	CALL	SELP
+	LXI	D,PCB
+	CALL	CLOSE
+EORPC:
+	LDA	HDISK
+	CPI	'Z'-'A'
+	JZ	EORHC
+	CALL	SELH
+	LXI	D,HCB
+	CALL	CLOSE
+;
+EORHC:
+	LXI	H,ENDA
+	CALL	PCON
+	JMP	BOOT
+;
+TITL:	DB	'MP/M ASSEMBLER - VER 2.0',CR
+ERROP:	DB	'NO SOURCE FILE PRESENT',CR
+ERRMA:	DB	'NO DIRECTORY SPACE',CR
+ERRFN:	DB	'SOURCE FILE NAME ERROR',CR
+ERRFR:	DB	'SOURCE FILE READ ERROR',CR
+ERRFW:	DB	'OUTPUT FILE WRITE ERROR',CR
+ERRCL:	DB	'CANNOT CLOSE FILES',CR
+ENDA:	DB	'END OF ASSEMBLY',CR
+;
+DHEX:	;DATA TO HEX BUFFER (BYTE IN REG-A)
+	PUSH	B
+	MOV	B,A	;HOLD CHARACTER FOR 'Z' TEST
+	LDA	HDISK
+	CPI	'Z'-'A'
+	MOV	A,B	;RECOVER CHARACTER
+	JZ	DHRET
+	PUSH	D	;ENVIRONMENT SAVED
+	PUSH	PSW	;SAVE DATA BYTE
+	LXI	H,DBL	;CURRENT LENGTH
+	MOV	A,M	;TO ACCUM
+	ORA	A	;ZERO?
+	JZ	DHEX3
+;
+;	LENGTH NOT ZERO, MAY BE FULL BUFFER
+	CPI	16
+	JC	DHEX1	;BR IF LESS THAN 16 BYTES
+;	BUFFER FULL, DUMP IT
+	CALL	WHEX	;DBL = 0 UPON RETURN
+	JMP	DHEX3	;SET BPC AND DATA BYTE
+;
+DHEX1:	;PARTIAL BUFFER IN PROGRESS, CHECK FOR SEQUENTIAL BYTE LOAD
+	LHLD	FPC
+	XCHG
+	LHLD	BPC	;BASE PC IN H,L
+	MOV	C,A	;CURRENT LENGTH OF BUFFER
+	MVI	B,0	;IS IN B,C
+	DAD	B	;BPC+DBL TO H,L
+	MOV	A,E	;READY FOR COMPARE
+	CMP	L	;EQUAL?
+	JNZ	DHEX2	;BR IF NOT
+	MOV	A,D	;CHECK HO BYTE
+	CMP	H
+	JZ	DHEX4	;BR IF SAME ADDRESS
+;
+DHEX2:	;NON SEQUENTIAL ADDRESS, DUMP AND CHANGE BASE ADDRESS
+	CALL	WHEX
+DHEX3:	;SET NEW BASE
+	LHLD	FPC
+	SHLD	BPC
+;
+DHEX4:	;STORE DATA BYTE AND INC DBL
+	LXI	H,DBL
+	MOV	E,M	;LENGTH TO REG-E
+	INR	M	;DBL=DBL+1
+	MVI	D,0	;HIGH ORDER ZERO FOR DOUBLE ADD
+	LXI	H,DBUFF
+	DAD	D	;DBUFF+DBL TO H,L
+	POP	PSW	;RESTORE DATA BYTE
+	MOV	M,A	;INTO DATA BUFFER
+	POP	D
+DHRET:	POP	B	;ENVIRONMENT RESTORED
+	RET
+;
+WRC:	;WRITE CHARACTER WITH CHECK SUM IN D
+	PUSH	PSW
+	RRC
+	RRC
+	RRC
+	RRC
+	ANI	0FH
+	CALL	HEXC	;OUTPUT HEX CHARACTER
+	POP	PSW	;RESTORE BYTE
+	PUSH	PSW	;SAVE A VERSION
+	ANI	0FH
+	CALL	HEXC	;WRITE LOW NIBBLE
+	POP	PSW	;RESTORE BYTE
+	ADD	D	;COMPUTE CHECKSUM
+	MOV	D,A	;SAVE CS
+	RET
+;
+HEXC:	;WRITE CHARACTER
+	ADI	90H
+	DAA
+	ACI	40H
+	DAA
+	JMP	PNB	;PUT BYTE
+;
+WHEX:	;WRITE CURRENT HEX BUFFER
+	MVI	A,':'	;RECORD HEADER
+	CALL	PNB	;PUT BYTE
+	LXI	H,DBL	;RECORD LENGTH ADDRESS
+	MOV	E,M	;LENGTH TO REG-E
+	XRA	A	;ZERO TO REG-A
+	MOV	D,A	;CLEAR CHECKSUM
+	MOV	M,A	;LENGTH IS ZEROED FOR NEXT WRITE
+	LHLD	BPC	;BASE ADDRESS FOR RECORD
+	MOV	A,E	;LENGTH TO A
+	CALL	WRC	;WRITE HEX VALUE
+	MOV	A,H	;HIGH ORDER BASE ADDR
+	CALL	WRC	;WRITE HO BYTE
+	MOV	A,L	;LOW ORDER BASE ADDR
+	CALL	WRC	;WRITE LO BYTE
+	XRA	A	;ZERO TO A
+	CALL	WRC	;WRITE RECORD TYPE 00
+	MOV	A,E	;CHECK FOR LENGTH 0
+	ORA	A
+	JZ	WHEX1
+;
+;	NON - ZERO, WRITE DATA BYTES
+	LXI	H,DBUFF
+WHEX0:	MOV	A,M	;GET BYTE
+	INX	H
+	CALL	WRC	;WRITE DATA BYTE
+	DCR	E	;END OF BUFFER?
+	JNZ	WHEX0
+;
+;	END OF DATA BYTES, WRITE CHECK SUM
+WHEX1:	XRA	A
+	SUB	D	;COMPUTE CHECKSUM
+	CALL	WRC
+;
+;	SEND CRLF AT END OF RECORD
+	MVI	A,CR
+	CALL	PNB
+	MVI	A,LF
+	CALL	PNB
+	RET
+;
+;
+;
+ENDMOD	EQU	($ AND 0FFE0H)+20H
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as2scan.asm

@@ -0,0 +1,412 @@
+	TITLE	'ASM SCANNER MODULE'
+	org	0
+base	equ	$
+
+	ORG	1100H
+	JMP	ENDMOD	;END OF THIS MODULE
+	JMP	INITS	;INITIALIZE THE SCANNER
+	JMP	SCAN	;CALL THE SCANNER
+;
+;
+;	ENTRY POINTS IN I/O MODULE
+IOMOD	EQU	base+200H
+GNCF	EQU	IOMOD+6H
+WOBUFF	EQU	IOMOD+15H
+PERR	EQU	IOMOD+18H
+;
+LASTC:	DS	1	;LAST CHAR SCANNED
+NEXTC:	DS	1	;LOOK AHEAD CHAR
+STYPE:	DS	1	;RADIX INDICATOR
+;
+;	COMMON EQUATES
+PBMAX	EQU	90	;MAX PRINT SIZE
+PBUFF	EQU	base+10CH	;PRINT BUFFER
+PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+;
+;	GLOBAL EQUATES
+IDEN	EQU	1	;IDENTIFIER
+NUMB	EQU	2	;NUMBER
+STRNG	EQU	3	;STRING
+SPECL	EQU	4	;SPECIAL CHARACTER
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL
+;
+BINV	EQU	2
+OCTV	EQU	8
+DECV	EQU	10
+HEXV	EQU	16
+CR	EQU	0DH
+LF	EQU	0AH
+EOF	EQU	1AH
+TAB	EQU	09H	;TAB CHARACTER
+;
+;
+;	UTILITY SUBROUTINES
+GNC:	;GET NEXT CHARACTER AND ECHO TO PRINT FILE
+	CALL	GNCF
+	PUSH	PSW
+	CPI	CR
+	JZ	GNC0
+	CPI	LF	;IF LF THEN DUMP CURRENT BUFFER
+	JZ	GNC0
+;
+	;NOT A CR OR LF, PLACE INTO BUFFER IF THERE IS ENOUGH ROOM
+	LDA	PBP
+	CPI	PBMAX
+	JNC	GNC0
+;	ENOUGH ROOM, PLACE INTO BUFFER
+	MOV	E,A
+	MVI	D,0	;DOUBLE PRECISION PBP IN D,E
+	INR	A
+	STA	PBP	;INCREMENTED PBP IN MEMORY
+	LXI	H,PBUFF
+	DAD	D	;PBUFF(PBP)
+	POP	PSW
+	MOV	M,A	;PBUFF(PBP) = CHAR
+	RET
+GNC0:	;CHAR NOT PLACED INTO BUFFER
+	POP	PSW
+	RET
+;
+INITS:	;INITIALIZE THE SCANNER
+	CALL	ZERO
+	STA	NEXTC	;CLEAR NEXT CHARACTER
+	STA	PBP
+	MVI	A,LF	;SET LAST CHAR TO LF
+	STA	LASTC
+	CALL	WOBUFF	;CLEAR BUFFER
+	MVI	A,16	;START OF PRINT LINE
+	STA	PBP
+	RET
+;
+ZERO:	XRA	A
+	STA	ACCLEN
+	STA	STYPE
+	RET
+;
+SAVER:	;STORE THE NEXT CHARACTER INTO THE ACCUMULATOR AND UPDATE ACCLEN
+	LXI	H,ACCLEN
+	MOV	A,M
+	CPI	ACMAX
+	JC	SAV1	;JUMP IF NOT UP TO LAST POSITION
+	MVI	M,0
+	CALL	ERRO
+SAV1:	MOV	E,M	;D,E WILL HOLD INDEX
+	MVI	D,0
+	INR	M	;ACCLEN INCREMENTED
+	INX	H	;ADDRESS ACCUMULATOR
+	DAD	D	;ADD INDEX TO ACCUMULATOR
+	LDA	NEXTC	;GET CHARACTER
+	MOV	M,A	;INTO ACCUMULATOR
+	RET
+;
+TDOLL:	;TEST FOR DOLLAR SIGN, ASSUMING H,L ADDRESS NEXTC
+	MOV	A,M
+	CPI	'$'
+	RNZ
+	XRA	A	;TO GET A ZERO
+	MOV	M,A	;CLEARS NEXTC
+	RET		;WITH ZERO FLAG SET
+;
+NUMERIC:	;CHECK NEXTC FOR NUMERIC, RETURN ZERO FLAG IF NOT NUMERIC
+	LDA	NEXTC
+	SUI	'0'
+	CPI	10
+;	CARRY RESET IF NUMERIC
+	RAL
+	ANI	1B	;ZERO IF NOT NUMERIC
+	RET
+;
+HEX:	;RETURN ZERO FLAG IF NEXTC IS NOT HEXADECIMAL
+	CALL	NUMERIC
+	RNZ		;RETURNS IF 0-9
+	LDA	NEXTC
+	SUI	'A'
+	CPI	6
+;	CARRY SET IF OUT OF RANGE
+	RAL
+	ANI	1B
+	RET
+;
+LETTER:	;RETURN ZERO FLAG IF NEXTC IS NOT A LETTER
+	LDA	NEXTC
+	SUI	'A'
+	CPI	26
+	RAL
+	ANI	1B
+	RET
+;
+ALNUM:	;RETURN ZERO FLAG IF NOT ALPHANUMERIC
+	CALL	LETTER
+	RNZ
+	CALL	NUMERIC
+	RET
+;
+TRANS:	;TRANSLATE TO UPPER CASE
+	LDA	NEXTC
+	CPI	'A' OR 1100000B	;LOWER CASE A
+	RC				;CARRY IF LESS THAN LOWER A
+	CPI	('Z' OR 1100000B)+1	;LOWER CASE Z
+	RNC				;NO CARRY IF GREATER THAN LOWER Z
+	ANI	1011111B		;CONVERT TO UPPER CASE
+	STA	NEXTC
+	RET
+;
+GNCN:	;GET CHARACTER AND STORE TO NEXTC
+	CALL	GNC
+	STA	NEXTC
+	push	psw	;*** Patch ***
+	lda	token	;Fixes upper case conversion
+	cpi	strng	;of characters in a string
+	cnz	TRANS	;TRANSLATE TO UPPER CASE
+	pop	psw
+	RET
+;
+EOLT:	;END OF LINE TEST FOR COMMENT SCAN
+	CPI	CR
+	RZ
+	CPI	EOF
+	RZ
+	CPI	'!'
+	RET
+;
+SCAN:	;FIND NEXT TOKEN IN INPUT STREAM
+	XRA	A
+	STA	TOKEN
+	CALL	ZERO
+;
+;	DEBLANK
+DEBL:	LDA	NEXTC
+	CPI	TAB	;TAB CHARACTER TREATED AS BLANK OUTSIDE STRING
+	JZ	DEB0
+	CPI	';'	;MAY BE A COMMENT
+	JZ	DEB1	;DEBLANK THROUGH COMMENT
+	CPI	'*'	;PROCESSOR TECH COMMENT
+	JNZ	DEB2	;NOT *
+	LDA	LASTC
+	CPI	LF	;LAST LINE FEED?
+	JNZ	DEB2	;NOT LF*
+;	COMMENT FOUND, REMOVE IT
+DEB1:	CALL	GNCN
+	CALL	EOLT	;CR, EOF, OR !
+	JZ	FINDL	;HANDLE END OF LINE
+	JMP	DEB1	;OTHERWISE CONTINUE SCAN
+DEB2:	ORI	' '	;MAY BE ZERO
+	CPI	' '
+	JNZ	FINDL
+DEB0:	CALL	GNCN	;GET NEXT AND STORE TO NEXTC
+	JMP	DEBL
+;
+;	LINE DEBLANKED, FIND TOKEN TYPE
+FINDL:	;LOOK FOR LETTER, DECIMAL DIGIT, OR STRING QUOTE
+	CALL	LETTER
+	JZ	FIND0
+	MVI	A,IDEN
+	JMP	STOKEN
+;
+FIND0:	CALL	NUMERIC
+	JZ	FIND1
+	MVI	A,NUMB
+	JMP	STOKEN
+;
+FIND1:	LDA	NEXTC
+	CPI	''''
+	JNZ	FIND2
+	XRA	A
+	STA	NEXTC	;DON'T STORE THE QUOTE
+	MVI	A,STRNG
+	JMP	STOKEN
+;
+FIND2:	;ASSUME IT IS A SPECIAL CHARACTER
+	CPI	LF	;IF LF THEN DUMP THE BUFFER
+	JNZ	FIND3
+;	LF FOUND
+	LDA	PASS
+	ORA	A
+	CNZ	WOBUFF
+	LXI	H,PBUFF	;CLEAR ERROR CHAR ON BOTH PASSES
+	MVI	M,' '
+	MVI	A,16
+	STA	PBP	;START NEW LINE
+FIND3:	MVI	A,SPECL
+;
+STOKEN:	STA	TOKEN
+;
+;
+;	LOOP WHILE CURRENT ITEM IS ACCUMULATING
+SCTOK:	LDA	NEXTC
+	STA	LASTC	;SAVE LAST CHARACTER
+	ORA	A
+	CNZ	SAVER	;STORE CHARACTER INTO ACCUM IF NOT ZERO
+	CALL	GNCN	;GET NEXT TO NEXTC
+	LDA	TOKEN
+	CPI	SPECL
+	RZ		;RETURN IF SPECIAL CHARACTER
+	CPI	STRNG
+	CNZ	TRANS	;TRANSLATE TO UPPER CASE IF NOT IN STRING
+	LXI	H,NEXTC
+	LDA	TOKEN
+;
+	CPI	IDEN
+	JNZ	SCT2
+;
+;	ACCUMULATING AN IDENTIFIER
+	CALL	TDOLL	;$?
+	JZ	SCTOK	;IF SO, SKIP IT
+	CALL	ALNUM	;ALPHA NUMERIC?
+	RZ		;RETURN IF END
+;	NOT END OF THE IDENTIFIER
+	JMP	SCTOK
+;
+SCT2:	;NOT SPECIAL OR IDENT, CHECK NUMBER
+	CPI	NUMB
+	JNZ	SCT3
+;
+;	ACCUMULATING A NUMBER, CHECK FOR $
+	CALL	TDOLL
+	JZ	SCTOK	;SKIP IF FOUND
+	CALL	HEX	;HEX CHARACTER?
+	JNZ	SCTOK	;STORE IT IF FOUND
+;	END OF NUMBER, LOOK FOR RADIX INDICATOR
+;
+	LDA	NEXTC
+	CPI	'O'	;OCTAL INDICATOR
+	JZ	NOCT
+	CPI	'Q'	;OCTAL INDICATOR
+	JNZ	NUM2
+;
+NOCT:	;OCTAL
+	MVI	A,OCTV
+	JMP	SSTYP
+;
+NUM2:	CPI	'H'
+	JNZ	NUM3
+	MVI	A,HEXV
+SSTYP:	STA	STYPE
+	XRA	A
+	STA	NEXTC	;CLEARS THE LOOKAHEAD CHARACTER
+	JMP	NCON
+;
+;	RADIX MUST COME FROM ACCUM
+NUM3:	LDA	LASTC
+	CPI	'B'
+	JNZ	NUM4
+	MVI	A,BINV
+	JMP	SSTY1
+;
+NUM4:	CPI	'D'
+	MVI	A,DECV
+	JNZ	SSTY2
+SSTY1:	LXI	H,ACCLEN
+	DCR	M	;ACCLEN DECREMENTED TO REMOVE RADIX INDICATOR
+SSTY2:	STA	STYPE
+;
+NCON:	;NUMERIC CONVERSION OCCURS HERE
+	LXI	H,0
+	SHLD	VALUE	;VALUE ACCUMULATES BINARY EQUIVALENT
+	LXI	H,ACCLEN
+	MOV	C,M	;C=ACCLEN
+	INX	H	;ADDRESSES ACCUM
+CLOP:	;NEXT DIGIT IS PROCESSED HERE
+	MOV	A,M
+	INX	H	;READY FOR NEXT LOOP
+	CPI	'A'
+	JNC	CLOP1	;NOT HEX A-F
+	SUI	'0'	;NORMALIZE
+	JMP	CLOP2
+;
+CLOP1:	;HEX A-F
+	SUI	'A'-10
+CLOP2:	;CHECK SIZE AGAINST RADIX
+	PUSH	H	;SAVE ACCUM ADDR
+	PUSH	B	;SAVE CURRENT POSITION
+	MOV	C,A
+	LXI	H,STYPE
+	CMP	M
+	CNC	ERRV	;VALUE ERROR IF DIGIT>=RADIX
+	MVI	B,0	;DOUBLE PRECISION DIGIT
+	MOV	A,M	;RADIX TO ACCUMULATOR
+	LHLD	VALUE
+	XCHG		;VALUE TO D,E - ACCUMULATE RESULT IN H,L
+	LXI	H,0	;ZERO ACCUMULATOR
+CLOP3:	;LOOP UNTIL RADIX GOES TO ZERO
+	ORA	A
+	JZ	CLOP4
+	RAR		;TEST LSB
+	JNC	TTWO	;SKIP SUMMING OPERATION IF LSB=0
+	DAD	D	;ADD IN VALUE
+TTWO:	;MULTIPLY VALUE * 2 FOR SHL OPERATION
+	XCHG
+	DAD	H
+	XCHG
+	JMP	CLOP3
+;
+;
+CLOP4:	;END OF NUMBER CONVERSION
+	DAD	B	;DIGIT ADDED IN
+	SHLD	VALUE
+	POP	B
+	POP	H
+	DCR	C	;MORE DIGITS?
+	JNZ	CLOP
+	RET		;DONE WITH THE NUMBER
+;
+SCT3:	;MUST BE A STRING
+	LDA	NEXTC
+	CPI	CR	;END OF LINE?
+	JZ	ERRO	;AND RETURN
+	CPI	''''
+	JNZ	SCTOK
+	CALL	GNCN
+	CPI	''''
+	RNZ		;RETURN IF SINGLE QUOTE ENCOUNTERED
+	JMP	SCTOK	;OTHERWISE TREAT AS ONE QUOTE
+;
+;	END OF SCANNER
+;
+;	ERROR MESSAGE ROUTINES
+ERRV:	;'V' VALUE ERROR
+	PUSH	PSW
+	MVI	A,'V'
+	JMP	ERR
+;
+ERRO:	;'O' OVERFLOW ERROR
+	PUSH	PSW
+	MVI	A,'O'
+	JMP	ERR
+;
+ERR:	;PRINT ERROR MESSAGE
+	PUSH	B
+	PUSH	H
+	CALL	PERR
+	POP	H
+	POP	B
+	POP	PSW
+	RET
+;
+ENDMOD	EQU	($ AND 0FFE0H) + 20H
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as3sym.asm

@@ -0,0 +1,385 @@
+	TITLE	'ASM SYMBOL TABLE MODULE'
+;	SYMBOL TABLE MANIPULATION MODULE
+;
+	org	0
+base	equ	$
+
+	ORG	1340H
+IOMOD	EQU	base+200H	;IO MODULE ENTRY POINT
+PCON	EQU	IOMOD+12H
+EOR	EQU	IOMOD+1EH
+;
+;
+;	ENTRY POINTS TO SYMBOL TABLE MODULE
+	JMP	ENDMOD
+	JMP	INISY
+	JMP	LOOKUP
+	JMP	FOUND
+	JMP	ENTER
+	JMP	SETTY
+	JMP	GETTY
+	JMP	SETVAL
+	JMP	GETVAL
+;
+;	COMMON EQUATES
+PBMAX	EQU	90	;MAX PRINT SIZE
+PBUFF	EQU	base+10CH	;PRINT BUFFER
+PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+SYBAS	EQU	ASPC+2	;BASE OF SYMBOL TABLE
+SYADR	EQU	SYBAS+2	;CURRENT SYMBOL BEING ACCESSED
+;
+;	GLOBAL EQUATES
+IDEN	EQU	1	;IDENTIFIER
+NUMB	EQU	2	;NUMBER
+STRNG	EQU	3	;STRING
+SPECL	EQU	4	;SPECIAL CHARACTER
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL
+;
+;
+CR	EQU	0DH
+;
+;	DATA AREAS
+;	SYMBOL TABLE BEGINS AT THE END OF THIS MODULE
+FIXD	EQU	5	;5 BYTES OVERHEAD WITH EACH SYMBOL ENTRY
+;			2BY COLLISION, 1BY TYPE/LEN, 2BY VALUE
+HSIZE	EQU	128	;HASH TABLE SIZE
+HMASK	EQU	HSIZE-1	;HASH MASK FOR CODING
+HASHT:	DS	HSIZE*2	;HASH TABLE
+HASHC:	DS	1	;HASH CODE AFTER CALL ON LOOKUP
+;
+;	SYMBOL TABLE ENTRY FORMAT IS
+;		-----------------
+;		: HIGH VAL BYTE	:
+;		-----------------
+;		: LOW  VAL BYTE	:
+;		-----------------
+;		: CHARACTER N	:
+;		-----------------
+;		:    ... 	:
+;		-----------------
+;		: CHARACTER 1	:
+;		-----------------
+;		: TYPE  : LENG	:
+;		-----------------
+;		: HIGH COLLISION:
+;		-----------------
+;	SYADR=	: LOW COLLISION :
+;		-----------------
+;
+;	WHERE THE LOW/HIGH COLLISION FIELD ADDRESSES ANOTHER ENTRY WITH
+;	THE SAME HASH CODE (OR ZERO IF THE END OF CHAIN), TYPE DESCRIBES
+;	THE ENTRY TYPE (GIVEN BELOW), LENG IS THE NUMBER OF CHARACTERS IN
+;	THE SYMBOL PRINTNAME -1 (I.E., LENG=0 IS A SINGLE CHARACTER PRINT-
+;	NAME, WHILE LENG=15 INDICATES A 16 CHARACTER NAME).  CHARACTER 1
+;	THROUGH N GIVE THE PRINTNAME CHARACTERS IN ASCII UPPER CASE (ALL
+;	LOWER CASE NAMES ARE TRANSLATED ON INPUT), AND THE LOW/HIGH VALUE
+;	GIVE THE PARTICULAR ADDRESS OR CONSTANT VALUE ASSOCIATED WITH THE
+;	NAME.  THE REPRESENTATION OF MACROS DIFFERS IN THE FIELDS WHICH
+;	FOLLOW THE VALUE FIELD (MACROS ARE NOT CURRENTLY IMPLEMENTED).
+;
+;	THE TYPE FIELD CONSISTS OF FOUR BITS WHICH ARE ASSIGNED AS
+;	FOLLOWS:
+;
+;		0000	UNDEFINED SYMBOL
+;		0001	LOCAL	LABELLED PROGRAM
+;		0010	LOCAL	LABELLED DATA
+;		0011	(UNUSED)
+;		0100		EQUATE
+;		0101		SET
+;		0110		MACRO
+;		0111		(UNUSED)
+;
+;		1000		(UNUSED)
+;		1001	EXTERN	LABELLED PROGRAM
+;		1010	EXTERN	LABELLED DATA
+;		1011		REFERENCE TO MODULE
+;		1100		(UNUSED)
+;		1101	GLOBAL	UNDEFINED SYMBOL
+;		1110	GLOBAL	LABELLED PROGRAM
+;		1111		(UNUSED)
+;
+;	TYPE DEFINITIONS
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL ATTRIBUTE
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL ATTRIBUTE
+;
+;
+INISY:	;INITIALIZE THE SYMBOL TABLE
+	LXI	H,HASHT	;ZERO THE HASH TABLE
+	MVI	B,HSIZE
+	XRA	A	;CLEAR ACCUM
+INI0:
+	MOV	M,A
+	INX	H
+	MOV	M,A	;CLEAR DOUBLE WORD
+	INX	H
+	DCR	B
+	JNZ	INI0
+;
+;	SET SYMBOL TABLE POINTERS
+	LXI	H,0
+	SHLD	SYADR
+;
+	RET
+;
+CHASH:	;COMPUTE HASH CODE FOR CURRENT ACCUMULATOR
+	LXI	H,ACCLEN
+	MOV	B,M	;GET ACCUM LENGTH
+	XRA	A	;CLEAR ACCUMULATOR
+CH0:	INX	H	;MOVE TO FIRST/NEXT CHARACTER POSITION
+	ADD	M	;ADD WITH OVERFLOW
+	DCR	B
+	JNZ	CH0
+	ANI	HMASK	;MASK BITS FOR MODULO HZISE
+	STA	HASHC	;FILL HASHC WITH RESULT
+	RET
+;
+SETLN:	;SET THE LENGTH FIELD OF THE CURRENT SYMBOL
+	MOV	B,A	;SAVE LENGTH IN B
+	LHLD	SYADR
+	INX	H
+	INX	H
+	MOV	A,M	;GET TYPE/LENGTH FIELD
+	ANI	0F0H	;MASK OUT TYPE FIELD
+	ORA	B	;MASK IN LENGTH
+	MOV	M,A
+	RET
+;
+GETLN:	;GET THE LENGTH FIELD TO REG-A
+	LHLD	SYADR
+	INX	H
+	INX	H
+	MOV	A,M
+	ANI	0FH
+	INR	A	;LENGTH IS STORED AS VALUE - 1
+	RET
+;
+FOUND:	;FOUND RETURNS TRUE IF SYADR IS NOT ZERO (TRUE IS NZ FLAG HERE)
+	LHLD	SYADR
+	MOV	A,L
+	ORA	H
+	RET
+;
+LOOKUP:	;LOOK FOR SYMBOL IN ACCUMULATOR
+	CALL	CHASH	;COMPUTE HASH CODE
+;	NORMALIZE IDENTIFIER TO 16 CHARACTERS
+	LXI	H,ACCLEN
+	MOV	A,M
+	CPI	17
+	JC	LENOK
+	MVI	M,16
+LENOK:
+;	LOOK FOR SYMBOL THROUGH HASH TABLE
+	LXI	H,HASHC
+	MOV	E,M
+	MVI	D,0	;DOUBLE HASH CODE IN D,E
+	LXI	H,HASHT	;BASE OF HASH TABLE
+	DAD	D
+	DAD	D	;HASHT(HASHC)
+	MOV	E,M	;LOW ORDER ADDRESS
+	INX	H
+	MOV	H,M
+	MOV	L,E	;HEADER TO LIST OF SYMBOLS IS IN H,L
+LOOK0:	SHLD	SYADR
+	CALL	FOUND
+	RZ		;RETURN IF SYADR BECOMES ZERO
+;
+;	OTHERWISE EXAMINE CHARACTER STRING FOR MATCH
+	CALL	GETLN	;GET LENGTH TO REG-A
+	LXI	H,ACCLEN
+	CMP	M
+	JNZ	LCOMP
+;
+;	LENGTH MATCH, TRY TO MATCH CHARACTERS
+	MOV	B,A	;STRING LENGTH IN B
+	INX	H	;HL ADDRESSES ACCUM
+	XCHG		;TO D,E
+	LHLD	SYADR
+	INX	H
+	INX	H
+	INX	H	;ADDRESSES CHARACTERS
+LOOK1:	LDAX	D	;NEXT CHARACTER FROM ACCUM
+	CMP	M	;NEXT CHARACTER IN SYMBOL TABLE
+	JNZ	LCOMP
+;	CHARACTER MATCHED, INCREMENT TO NEXT
+	INX	D
+	INX	H
+	DCR	B
+	JNZ	LOOK1
+;
+;	COMPLETE MATCH AT CURRENT SYMBOL, SYADR IS SET
+	RET
+;
+LCOMP:	;NOT FOUND, MOVE SYADR DOWN ONE COLLISION ADDRESS
+	LHLD	SYADR
+	MOV	E,M
+	INX	H
+	MOV	D,M	;COLLISION ADDRESS IN D,E
+	XCHG
+	JMP	LOOK0
+;
+;
+ENTER:	;ENTER SYMBOL IN ACCUMULATOR
+;	ENSURE THERE IS ENOUGH SPACE IN THE TABLE
+	LXI	H,ACCLEN
+	MOV	E,M
+	MVI	D,0	;DOUBLE PRECISION ACCLEN IN D,E
+	LHLD	SYTOP
+	SHLD	SYADR	;NEXT SYMBOL LOCATION
+	DAD	D	;SYTOP+ACCLEN
+	LXI	D,FIXD	;FIXED DATA/SYMBOL
+	DAD	D	;HL HAS NEXT TABLE LOCATION FOR SYMBOL
+	XCHG		;NEW SYTOP IN D,E
+	LHLD	SYMAX	;MAXIMUM SYMTOP VALUE
+	MOV	A,E
+	SUB	L	;COMPUTE 16-BIT DIFFERENCE
+	MOV	A,D
+	SBB	H
+	XCHG		;NEW SYTOP IN H,L
+	JNC	OVERER	;OVERFLOW IN TABLE
+;
+;	OTHERWISE NO ERROR
+	SHLD	SYTOP	;SET NEW TABLE TOP
+	LHLD	SYADR	;SET COLLISION FIELD
+	XCHG		;CURRENT SYMBOL ADDRESS TO D,E
+	LXI	H,HASHC	;HASH CODE FOR CURRENT SYMBOL TO H,L
+	MOV	C,M	;LOW BYTE
+	MVI	B,0	;DOUBLE PRECISION VALUE IN B,C
+	LXI	H,HASHT	;BASE OF HASH TABLE
+	DAD	B
+	DAD	B	;HASHT(HASHC) IN H,L
+;	D,E ADDRESSES CURRENT SYMBOL - CHANGE LINKS
+	MOV	C,M	;LOW ORDER OLD HEADER
+	INX	H
+	MOV	B,M	;HIGH ORDER OLD HEADER
+	MOV	M,D	;HIGH ORDER NEW HEADER TO HASH TABLE
+	DCX	H
+	MOV	M,E	;LOW ORDER NEW HEADER TO HASH TABLE
+	XCHG		;H,L HOLDS SYMBOL TABLE ADDRESS
+	MOV	M,C	;LOW ORDER OLD HEADER TO COLLISION FIELD
+	INX	H
+	MOV	M,B	;HIGH ORDER OLD HEADER TO COLLISION FIELD
+;
+;	HASH CHAIN NOW REPAIRED FOR THIS ENTRY, COPY THE PRINTNAME
+	LXI	D,ACCLEN
+	LDAX	D	;GET SYMBOL LENGTH
+	CPI	17	;LARGER THAN 16 SYMBOLS?
+	JC	ENT1
+	MVI	A,16	;TRUNCATE TO 16 CHARACTERS
+;	COPY LENGTH FIELD, FOLLOWED BY PRINTNAME CHARACTERS
+ENT1:	MOV	B,A	;COPY LENGTH TO B
+	DCR	A	;1-16 CHANGED TO 0-15
+	INX	H	;FOLLOWING COLLISION FIELD
+	MOV	M,A	;STORE LENGTH WITH UNDEFINED TYPE (0000)
+ENT2:	INX	H
+	INX	D
+	LDAX	D
+	MOV	M,A	;STORE NEXT CHARACTER OF PRINTNAME
+	DCR	B	;LENGTH=LENGTH-1
+	JNZ	ENT2	;FOR ANOTHER CHARACTER
+;
+;	PRINTNAME COPIED, ZERO THE VALUE FIELD
+	XRA	A	;ZERO A
+	INX	H	;LOW ORDER VALUE
+	MOV	M,A
+	INX	H
+	MOV	M,A	;HIGH ORDER VALUE
+	RET
+;
+OVERER:	;OVERFLOW IN SYMBOL TABLE
+	LXI	H,ERRO
+	CALL	PCON
+	JMP	EOR	;END OF EXECUTION
+ERRO:	DB	'SYMBOL TABLE OVERFLOW',CR
+;
+SETTY:	;SET CURRENT SYMBOL TYPE TO VALUE IN REG-A
+	RAL
+	RAL
+	RAL
+	RAL
+	ANI	0F0H	;TYPE MOVED TO HIGH ORDER 4-BITS
+	MOV	B,A	;SAVE IT IN B
+	LHLD	SYADR	;BASE OF SYMBOL TO ACCESS
+	INX	H
+	INX	H	;ADDRESS OF TYPE/LENGTH FIELD
+	MOV	A,M	;GET IT AND MASK
+	ANI	0FH	;LEAVE LENGTH
+	ORA	B	;MASK IN TYPE
+	MOV	M,A	;STORE IT
+	RET
+;
+GETTY:	;RETURN THE TYPE OF THE VALUE IN CURRENT SYMBOL
+	LHLD	SYADR
+	INX	H
+	INX	H
+	MOV	A,M
+	RAR
+	RAR
+	RAR
+	RAR
+	ANI	0FH	;TYPE MOVED TO LOW 4-BITS OF REG-A
+	RET
+;
+VALADR:	;GET VALUE FIELD ADDRESS FOR CURRENT SYMBOL
+	CALL	GETLN	;PRINTNAME LENGTH TO ACCUM
+	LHLD	SYADR	;BASE ADDRESS
+	MOV	E,A
+	MVI	D,0
+	DAD	D	;BASE(LEN)
+	INX	H
+	INX	H	;FOR COLLISION FIELD
+	INX	H	;FOR TYPE/LEN FIELD
+	RET		;WITH H,L ADDRESSING VALUE FIELD
+;
+SETVAL:	;SET THE VALUE FIELD OF THE CURRENT SYMBOL
+;	VALUE IS SENT IN H,L
+	PUSH	H	;SAVE VALUE TO SET
+	CALL	VALADR
+	POP	D	;POP VALUE TO SET, HL HAS ADDRESS TO FILL
+	MOV	M,E
+	INX	H
+	MOV	M,D	;FIELD SET
+	RET
+;
+GETVAL:	;GET THE VALUE FIELD OF THE CURRENT SYMBOL TO H,L
+	CALL	VALADR	;ADDRESS OF VALUE FIELD TO H,L
+	MOV	E,M
+	INX	H
+	MOV	D,M
+	XCHG
+	RET
+;
+ENDMOD	EQU	($ AND 0FFE0H) + 20H
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as4sear.asm

@@ -0,0 +1,418 @@
+	TITLE	'ASM TABLE SEARCH MODULE'
+	org	0
+base	equ	$
+
+	ORG	15A0H
+	JMP	ENDMOD	;TO NEXT MODULE
+	JMP	BSEAR
+	JMP	BGET
+;
+;	COMMON EQUATES
+PBMAX	EQU	90	;MAX PRINT SIZE
+PBUFF	EQU	base+10CH	;PRINT BUFFER
+PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+;
+;	GLOBAL EQUATES
+IDEN	EQU	1	;IDENTIFIER
+NUMB	EQU	2	;NUMBER
+STRNG	EQU	3	;STRING
+SPECL	EQU	4	;SPECIAL CHARACTER
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL
+;
+;
+CR	EQU	0DH	;CARRIAGE RETURN
+;
+;
+;	TABLE DEFINITIONS
+;
+;	TYPES
+XBASE	EQU	0	;START OF OPERATORS
+;	O1 THROUGH O15 DENOTE OPERATIONS
+RT	EQU	16
+PT	EQU	RT+1	;RT IS REGISTER TYPE, PT IS PSEUDO OPERATION
+OBASE	EQU	PT+1
+O1	EQU	OBASE+1	;SIMPLE
+O2	EQU	OBASE+2	;LXI
+O3	EQU	OBASE+3	;DAD
+O4	EQU	OBASE+4	;PUSH/POP
+O5	EQU	OBASE+5	;JMP/CALL
+O6	EQU	OBASE+6	;MOV
+O7	EQU	OBASE+7	;MVI
+O8	EQU	OBASE+8	;ACC IMMEDIATE
+O9	EQU	OBASE+9	;LDAX/STAX
+O10	EQU	OBASE+10	;LHLD/SHLD/LDA/STA
+O11	EQU	OBASE+11	;ACCUM REGISTER
+O12	EQU	OBASE+12	;INC/DEC
+O13	EQU	OBASE+13	;INX/DCX
+O14	EQU	OBASE+14	;RST
+O15	EQU	OBASE+15	;IN/OUT
+;
+;	X1 THROUGH X15 DENOTE OPERATORS
+X1	EQU	XBASE	;*
+X2	EQU	XBASE+1	;/
+X3	EQU	XBASE+2	;MOD
+X4	EQU	XBASE+3	;SHL
+X5	EQU	XBASE+4	;SHR
+X6	EQU	XBASE+5	;+
+X7	EQU	XBASE+6	;-
+X8	EQU	XBASE+7	;UNARY -
+X9	EQU	XBASE+8	;NOT
+X10	EQU	XBASE+9	;AND
+X11	EQU	XBASE+10;OR
+X12	EQU	XBASE+11;XOR
+X13	EQU	XBASE+12;(
+X14	EQU	XBASE+13;)
+X15	EQU	XBASE+14;,
+X16	EQU	XBASE+15;CR
+;
+;
+;
+;
+;	RESERVED WORD TABLES
+;
+;	BASE ADDRESS VECTOR FOR CHARACTERS
+CINX:	DW	CHAR1	;LENGTH 1 BASE
+	DW	CHAR2	;LENGTH 2 BASE
+	DW	CHAR3	;LENGTH 3 BASE
+	DW	CHAR4	;LENGTH 4 BASE
+	DW	CHAR5	;LENGTH 5 BASE
+	DW	CHAR6	;LENGTH 6 BASE
+;
+CMAX	EQU	($-CINX)/2-1	;LARGEST STRING TO MATCH
+;
+CLEN:	;LENGTH VECTOR GIVES THE NUMBER OF ITEMS IN EACH TABLE
+	DB	CHAR2-CHAR1
+	DB	(CHAR3-CHAR2)/2
+	DB	(CHAR4-CHAR3)/3
+	DB	(CHAR5-CHAR4)/4
+	DB	(CHAR6-CHAR5)/5
+;
+TVINX:	;TABLE OF TYPE,VALUE PAIRS FOR EACH RESERVED SYMBOL
+	DW	TV1
+	DW	TV2
+	DW	TV3
+	DW	TV4
+	DW	TV5
+;
+;	CHARACTER VECTORS FOR 1,2,3,4, AND 5 CHARACTER NAMES
+CHAR1:	DB	CR,'()*'
+	DB	'+'
+	DB	',-/A'
+	DB	'BCDE'
+	DB	'HLM'
+;
+CHAR2:	DB	'DBDIDSDW'
+	DB	'EIIFINOR'
+	DB	'SP'
+;
+CHAR3:	DB	'ACIADCADDADI'
+	DB	'ANAANDANICMA'
+	DB	'CMCCMPCPIDAA'
+	DB	'DADDCRDCXEND'
+	DB	'EQUHLTINRINX'
+	DB	'JMPLDALXIMOD'
+	DB	'MOVMVINOPNOT'
+	DB	'ORAORGORIOUT'
+	DB	'POPPSWRALRAR'
+	DB	'RETRLCRRCRST'
+	DB	'SBBSBISETSHL'
+	DB	'SHRSTASTCSUB'
+	DB	'SUIXORXRAXRI'
+;
+CHAR4:	DB	'CALLENDMLDAXLHLDPCHL'
+	DB	'PUSHSHLDSPHLSTAX'
+	DB	'XCHGXTHL'
+;
+CHAR5:	DB	'ENDIFMACROTITLE'
+;
+CHAR6:	;END OF CHARACTER VECTOR
+;
+TV1:	;TYPE,VALUE PAIRS FOR CHAR1 VECTOR
+	DB	X16,10,		X13,20		;CR (
+	DB	X14,30,		X1,80		;) *
+	DB	X6,70				;+
+	DB	X15,10,		X7,70		;, -
+	DB	X2,80,		RT,7		;/ A
+	DB	RT,0,		RT,1		;B C
+	DB	RT,2,		RT,3		;D E
+	DB	RT,4,		RT,5		;H L
+	DB	RT,6				;M
+;
+TV2:	;TYPE,VALUE PAIRS FOR CHAR2 VECTOR
+	DB	PT,1,		O1,0F3H		;DB DI
+	DB	PT,2,		PT,3		;DS DW
+	DB	O1,0FBH,	PT,8		;EI IF
+	DB	O15,0DBH,	X11,40		;IN OR
+	DB	RT,6				;SP
+;
+;
+TV3:	;TYPE,VALUE PAIRS FOR CHAR3 VECTOR
+	DB	O8,0CEH,	O11,88H		;ACI ADC
+	DB	O11,80H,	O8,0C6H		;ADD ADI
+	DB	O11,0A0H,	X10,50		;ANA AND
+	DB	O8,0E6H,	O1,2FH		;ANI CMA
+	DB	O1,3FH,		O11,0B8H	;CMC CMP
+	DB	O8,0FEH,	O1,27H		;CPI DAA
+	DB	O3,09H,		O12,05H		;DAD DCR
+	DB	O13,0BH,	PT,4		;DCX END
+	DB	PT,7,		O1,76H		;EQU HLT
+	DB	O12,04H,	O13,03H		;INR INX
+	DB	O5,0C3H,	O10,3AH		;JMP LDA
+	DB	O2,01H,		X3,80		;LXI MOD
+	DB	O6,40H,		O7,06H		;MOV MVI
+	DB	O1,00H,		X9,60		;NOP NOT
+	DB	O11,0B0H,	PT,10		;ORA ORG
+	DB	O8,0F6H,	O15,0D3H	;ORI OUT
+	DB	O4,0C1H,	RT,6		;POP PSW
+	DB	O1,17H,		O1,1FH		;RAL RAR
+	DB	O1,0C9H,	O1,07H		;RET RLC
+	DB	O1,0FH,		O14,0C7H	;RRC RST
+	DB	O11,098H,	O8,0DEH		;SBB SBI
+	DB	PT,11,		X4,80		;SET SHL
+	DB	X5,80,		O10,32H		;STA STC
+	DB	O1,37H,		O11,90H		;STC SUB
+	DB	O8,0D6H,	X12,40		;SUI XOR
+	DB	O11,0A8H,	O8,0EEH		;XRA XRI
+;
+;
+TV4:	;TYPE,VALUE PAIRS FOR CHAR4 VECTOR
+	DB	O5,0CDH				;CALL
+	DB	PT,6,		O9,0AH		;ENDM LDAX
+	DB	O10,02AH,	O1,0E9H		;LHLD PCHL
+	DB	O4,0C5H,	O10,22H		;PUSH SHLD
+	DB	O1,0F9H,	O9,02H		;SPHL STAX
+	DB	O1,0EBH,	O1,0E3H		;XCHG XTHL
+;
+TV5:	;TYPE,VALUE PAIRS FOR CHAR5 VECTOR
+	DB	PT,5,		PT,9		;ENDIF MACRO
+	DB	PT,12				;TITLE
+;
+SUFTAB:	;TABLE OF SUFFIXES FOR J C AND R OPERATIONS
+	DB	'NZZ NCC POPEP M '
+;
+BSEAR:	;BINARY SEARCH MNEMONIC TABLE
+;	INPUT: UR = UPPER BOUND OF TABLE (I.E., TABLE LENGTH-1)
+;		SR = SIZE OF EACH TABLE ELEMENT
+;		H,L ADDRESS BASE OF TABLE TO SEARCH
+;	OUTPUT: ZERO FLAG INDICATES MATCH WAS FOUND, IN WHICH CASE
+;		THE ACCUMULATOR CONTAINS AN INDEX TO THE ELEMENT
+;		NOT ZERO FLAG INDICATES NO MATCH FOUND IN TABLE
+;
+UR	EQU	B	;UPPER BOUND REGISTER
+LR	EQU	C	;LOWER BOUND REGISTER
+SR	EQU	D	;SIZE REGISTER
+MR	EQU	E	;MIDDLE POINTER REGISTER
+SP1	EQU	B	;SIZE PRIME, USED IN COMPUTING MIDDLE POSITON
+SP1P	EQU	C	;ANOTHER COPY OF SIZE PRIME
+KR	EQU	H	;K
+;
+	MVI	MR,255	;MARK M <> OLD M
+	INR	UR	;U=U+1
+	MVI	LR,0	;L = 0
+;
+;	COMPUTE M' = (U+L)/2
+NEXT:	XRA	A
+	MOV	A,UR	;CY=0, A=U
+	ADD	LR	;(U+L)
+	RAR	;(U+L)/2
+	CMP	MR	;SAME AS LAST TIME THROUGH?
+	JZ	NMATCH	;JUMP IF = TO NO MATCH
+;
+;	MORE ELEMENTS TO SCAN
+	MOV	MR,A	;NEW MIDDLE VALUE
+	PUSH	H	;SAVE A COPY OF THE BASE ADDRESS
+	PUSH	D	;SAVE S,M
+	PUSH	B	;SAVE U,L
+	PUSH	H	;SAVE ANOTHER COPY OF THE BASE ADDRESS
+	MOV	SP1,SR	;S' = S
+	MOV	SP1P,SP1	;S'' = S'
+	MVI	SR,0	;FOR DOUBLE ADD OPERATION BELOW (DOUBLE M)
+;
+	LXI	KR,0	;K=0
+SUMK:	DAD	D	;K = K + M
+	DCR	SP1	;S' = S' - 1
+	JNZ	SUMK	;DECREMENT IF SP1 <> 0
+;
+;	K IS NOW RELATIVE BYTE POSITION
+	POP	D	;TABLE BASE ADDRESS
+	DAD	D	;H,L CONTAINS ABSOLUTE ADDRESS OF BYTE TO COMPARE
+	LXI	D,ACCUM	;D,E ADDRESS CHARACTERS TO COMPARE
+;
+COMK:	;COMPARE NEXT CHARACTER
+	LDAX	D	;ACCUM CHARACTER TO REG A
+	CMP	M	;SAME AS TABLE ENTRY?
+	INX	D
+	INX	H	;TO NEXT POSITIONS
+	JNZ	NCOM	;JUMP IF NOT THE SAME
+	DCR	SP1P	;MORE CHARACTERS?
+	JNZ	COMK
+;
+;	COMPLETE MATCH AT M
+	POP	B
+	POP	D	;M RESTORED
+	POP	H
+	MOV	A,MR	;VALUE OF M COPIED IN A
+	RET		;WITH ZERO FLAG SET
+;
+NCOM:	;NO MATCH, DETERMINE IF LESS OR GREATER
+	POP	B	;U,L
+	POP	D	;S,M
+	POP	H	;TABLE ADDRESS
+	JC	NCOML
+;	ACCUM IS HIGHER
+	MOV	LR,MR	;L = M
+	JMP	NEXT
+;
+NCOML:	;ACCUMULATOR IS LOW
+	MOV	UR,MR	;U = M
+	JMP	NEXT
+;
+NMATCH:	;NO MATCH
+	XRA	A
+	INR	A	;SETS NOT ZERO FLAG
+	RET
+;
+PREFIX:	;J C OR R PREFIX?
+	LDA	ACCUM
+	LXI	B,(0C2H SHL 8) OR O5	;JNZ OPCODE TO B, TYPE TO C
+	CPI	'J'
+	RZ		;RETURN WITH ZERO FLAG SET IF J
+	MVI	B,0C4H		;CNZ OPCODE TO B, TYPE IS IN C
+	CPI	'C'
+	RZ
+	LXI	B,(0C0H SHL 8) OR O1	;RNZ OPCODE
+	CPI	'R'
+	RET
+;
+SUFFIX:	;J R OR C RECOGNIZED, LOOK FOR SUFFIX
+	LDA	ACCLEN
+	CPI	4	;CHECK LENGTH
+	JNC	NSUFF	;CARRY IF 0,1,2,3 IN LENGTH
+	CPI	3
+	JZ	SUF0	;ASSUME 1 OR 2 IF NO BRANCH
+	CPI	2
+	JNZ	NSUFF	;RETURNS IF 0 OR 1
+	LXI	H,ACCUM+2
+	MVI	M,' '	;BLANK-OUT FOR MATCH ATTEMPT
+SUF0:	;SEARCH 'TIL END OF TABLE
+	LXI	B,8	;B=0, C=8 COUNTS TABLE DOWN TO ZERO OR MATCH
+	LXI	D,SUFTAB
+NEXTS:	;LOOK AT NEXT SUFFIX
+	LXI	H,ACCUM+1	;SUFFIX POSITION
+	LDAX	D		;CHARACTER TO ACCUM
+	CMP	M
+	INX	D		;READY FOR NEXT CHARACTER
+	JNZ	NEXT0		;JMP IF NO MATCH
+	LDAX	D		;GET NEXT CHARACTER
+	INX	H		;READY FOR COMPARE WITH ACCUM
+	CMP	M		;SAME?
+	RZ			;RETURN WITH ZERO FLAG SET, B IS SUFIX
+NEXT0:	INX	D		;MOVE TO NEXT CHARACTER
+	INR	B		;COUNT SUFFIX UP
+	DCR	C		;COUNT TABLE LENGTH DOWN
+	JNZ	NEXTS
+;	END OF TABLE, MARK WITH NON ZERO FLAG
+	INR	C
+	RET
+;
+NSUFF:	;NOT PROPER SUFFIX - SET NON ZERO FLAG
+	XRA	A
+	INR	A
+	RET
+;
+BGET:	;PERFORM BINARY SEARCH, AND EXTRACT TYPE AND VAL FIELDS FOR
+;	THE ITEM.  ZERO FLAG INDICATES MATCH WAS FOUND, WITH TYPE
+;	IN THE ACCUMULATOR, AND VAL IN REGISTER B.  THE SEARCH IS BASED
+;	UPON THE LENGTH OF THE ACCUMULATOR
+	LDA	ACCLEN	;ITEM LENGTH
+	MOV	C,A	;SAVE A COPY
+	DCR	A	;ACCLEN-1
+	MOV	E,A
+	MVI	D,0	;DOUBLE ACCLEN-1 TO D,E
+	PUSH	D	;SAVE A COPY FOR LATER
+	CPI	CMAX	;TOO LONG?
+	JNC	NGET	;NOT IN RANGE IF CARRY
+	LXI	H,CLEN	;LENGTH VECTOR
+	DAD	D
+	MOV	UR,M	;FILL UPPER BOUND FROM MEMORY
+	LXI	H,CINX
+	DAD	D
+	DAD	D	;BASE ADDRESS TO H,L
+	MOV	D,M
+	INX	H
+	MOV	H,M
+	MOV	L,D	;NOW IN H,L
+	MOV	SR,C	;FILL THE SIZE REGISTER
+	CALL	BSEAR	;PERFORM THE BINARY SEARCH
+	JNZ	SCASE	;ZERO IF FOUND
+	POP	D	;RESTORE INDEX
+	LXI	H,TVINX
+	DAD	D
+	DAD	D	;ADDRESSING PROPER TV ELEMENT
+	MOV	E,M
+	INX	H
+	MOV	D,M
+;	D,E IS BASE ADDRESS OF TYPE/VALUE VECTOR, ADD DISPLACEMENT
+	MOV	L,A
+	MVI	H,0
+	DAD	H	;DOUBLED
+	DAD	D	;INDEXED
+	MOV	A,M	;TYPE TO ACC
+	INX	H
+	MOV	B,M	;VALUE TO B
+	RET		;TYPE IN ACC, VALUE IN B
+;
+SCASE:	;NAME NOT TOO LONG, BUT NOT FOUND IN TABLES, MAY BE J C OR R
+	POP	D	;RESTORE INDEX
+	CALL	PREFIX
+	RNZ		;NOT FOUND AS PREFIX J C OR R IF NOT ZERO FLAG
+	PUSH	B	;SAVE VALUE AND TYPE
+	CALL	SUFFIX	;ZERO IF SUFFIX MATCHED
+	MOV	A,B	;READY FOR MASK IF ZERO FLAG
+	POP	B	;RECALL VALUE AND TYPE
+	RNZ		;RETURN IF NOT ZERO FLAG SET
+;	MASK IN THE PROPER BITS AND RETURN
+	ORA	A	;CLEAR CARRY
+	RAL
+	RAL
+	RAL
+	ORA	B	;VALUE SET TO JNZ ...
+	MOV	B,A	;REPLACE
+	MOV	A,C	;RETURN WITH TYPE IN REGISTER A
+	CMP	A	;CLEAR THE ZERO FLAG
+	RET
+;
+NGET:	;CAN'T FIND THE ENTRY, RETURN WITH ZERO FLAG RESET
+	POP	D	;GET THE ELEMENT BACK
+	XRA	A	;CLEAR
+	INR	A	;ZERO FLAG RESET
+	RET
+;
+;
+ENDMOD	EQU	($ AND 0FFE0H) + 20H	;NEXT MODULE ADDRESS
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as5oper.asm

@@ -0,0 +1,597 @@
+	TITLE	'ASM OPERAND SCAN MODULE'
+;	OPERAND SCAN MODULE
+	org	0
+base	equ	$
+
+	ORG	1860H
+;
+;	EXTERNALS
+IOMOD	EQU	base+200H	;I/O MODULE
+SCMOD	EQU	base+1100H	;SCANNER MODULE
+SYMOD	EQU	base+1340H	;SYMBOL TABLE MODULE
+BMOD	EQU	base+15A0H	;BINARY SEARCH MODULE
+;
+;
+PERR	EQU	IOMOD+18H
+SCAN	EQU	SCMOD+6H	;SCANNER ENTRY POINT
+CR	EQU	0DH	;CARRIAGE RETURN
+;
+LOOKUP	EQU	SYMOD+6H	;LOOKUP
+FOUND	EQU	LOOKUP+3	;FOUND SYMBOL IF ZERO FLAG NOT SET
+ENTER	EQU	FOUND+3		;ENTER SYMBOL
+SETTY	EQU	ENTER+3		;SET TYPE FIELD
+GETTY	EQU	SETTY+3		;SET TYPE FIELD
+SETVAL	EQU	GETTY+3		;SET VALUE FIELD
+GETVAL	EQU	SETVAL+3	;GET VALUE FIELD
+;
+BSEAR	EQU	BMOD+3	;BINARY SEARCH ROUTINE
+BGET	EQU	BSEAR+3	;GET VALUES WITH SEARCH
+;
+;	COMMON EQUATES
+PBMAX	EQU	90	;MAX PRINT SIZE
+PBUFF	EQU	base+10CH	;PRINT BUFFER
+PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+;
+;	GLOBAL EQUATES
+IDEN	EQU	1	;IDENTIFIER
+NUMB	EQU	2	;NUMBER
+STRNG	EQU	3	;STRING
+SPECL	EQU	4	;SPECIAL CHARACTER
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL
+;
+;
+;	TABLE DEFINITIONS
+XBASE	EQU	0	;START OF OPERATORS
+OPER	EQU	15	;LAST OPERATOR
+RT	EQU	16
+PT	EQU	RT+1	;RT IS REGISTER TYPE, PT IS PSEUDO OPERATION
+OBASE	EQU	PT+1
+;
+PLUS	EQU	5
+MINUS	EQU	6
+NOTF	EQU	8	;NOT
+LPAR	EQU	12
+RPAR	EQU	13
+OSMAX	EQU	10
+VSMAX	EQU	8*2
+;
+;
+;	BEGINNING OF MODULE
+	JMP	ENDMOD	;PAST THIS MODULE
+	JMP	OPAND	;SCAN OPERAND FIELD
+	JMP	MULF	;MULTIPLY FUNCTION
+	JMP	DIVE	;DIVIDE FUNCTION
+UNARY:	DS	1	;TRUE IF NEXT OPERATOR IS UNARY
+OPERV:	DS	OSMAX	;OPERATOR STACK
+HIERV:	DS	OSMAX	;OPERATOR PRIORITY
+VSTACK:	DS	VSMAX	;VALUE STACK
+OSP:	DS	1	;OPERATOR STACK POINTER
+VSP:	DS	1	;VALUE STACK POINTER
+;
+;
+;
+STKV:	;PLACE CURRENT H,L VALUE AT TOP OF VSTACK
+	XCHG	;HOLD VALUE IN D,E
+	LXI	H,VSP
+	MOV	A,M
+	CPI	VSMAX
+	JC	STKV0
+	CALL	ERREX	;OVERFLOW IN EXPRESSION
+	MVI	M,0	;VSP=0
+STKV0:	MOV	A,M	;GET VSP
+	INR	M	;VSP=VSP+1
+	INR	M	;VSP=VSP+2
+	MOV	C,A	;SAVE VSP
+	MVI	B,0	;DOUBLE VSP
+	LXI	H,VSTACK
+	DAD	B
+	MOV	M,E	;LOW BYTE
+	INX	H
+	MOV	M,D	;HIGH BYTE
+	RET
+;
+STKO:	;STACK OPERATOR (REG-A) AND PRIORITY (REG-B)
+	PUSH	PSW	;SAVE IT
+	LXI	H,OSP
+	MOV	A,M
+	CPI	OSMAX
+	JC	STKO1
+	MVI	M,0
+	CALL	ERREX	;OPERATOR STACK OVERFLOW
+STKO1:	MOV	E,M	;GET OSP
+	MVI	D,0
+	INR	M	;OSP=OSP+1
+	POP	PSW	;RECALL OPERATOR
+	LXI	H,OPERV
+	DAD	D	;OPERV(OSP)
+	MOV	M,A	;OPERV(OSP)=OPERATOR
+	LXI	H,HIERV
+	DAD	D
+	MOV	M,B	;HIERV(OSP)=PRIORITY
+	RET
+;
+LODV1:	;LOAD TOP ELEMENT FROM VSTACK TO H,L
+	LXI	H,VSP
+	MOV	A,M
+	ORA	A
+	JNZ	LODOK
+	CALL	ERREX	;UNDERFLOW
+	LXI	H,0
+	RET
+;
+LODOK:	DCR	M
+	DCR	M	;VSP=VSP-2
+	MOV	C,M	;LOW BYTE
+	MVI	B,0
+	LXI	H,VSTACK
+	DAD	B	;VSTACK(VSP)
+	MOV	C,M	;GET LOW BYTE
+	INX	H
+	MOV	H,M
+	MOV	L,C
+	RET
+;
+LODV2:	;LOAD TOP TWO ELEMENTS DE HOLDS TOP, HL HOLDS TOP-1
+	CALL	LODV1
+	XCHG
+	CALL	LODV1
+	RET
+;
+APPLY:	;APPLY OPERATOR IN REG-A TO TOP OF STACK
+	MOV	L,A
+	MVI	H,0
+	DAD	H	;OPERATOR NUMBER*2
+	LXI	D,OPTAB
+	DAD	D	;INDEXED OPTAB
+	MOV	E,M	;LOW ADDRESS
+	INX	H
+	MOV	H,M	;HIGH ADDRESS
+	MOV	L,E
+	PCHL		;SET PC AND GO TO SUBROUTINE
+;
+OPTAB:	DW	MULOP
+	DW	DIVOP
+	DW	MODOP
+	DW	SHLOP
+	DW	SHROP
+	DW	ADDOP
+	DW	SUBOP
+	DW	NEGOP
+	DW	NOTOP
+	DW	ANDOP
+	DW	OROP
+	DW	XOROP
+	DW	ERREX	;(
+;
+;	SPECIFIC HANDLERS FOLLOW
+SHFT:	;SET UP OPERANDS FOR SHIFT L AND R
+	CALL	LODV2
+	MOV	A,D	;ENSURE 0-15
+	ORA	A
+	JNZ	SHERR
+	MOV	A,E
+	CPI	17
+	RC		;RETURN IF 0-16 SHIFT
+SHERR:	CALL	ERREX
+	MVI	A,16
+	RET
+;
+NEGF:	;COMPUTE 0-H,L TO H,L
+	XRA	A
+	SUB	L
+	MOV	L,A
+	MVI	A,0
+	SBB	H
+	MOV	H,A
+	RET
+;
+DIVF:	CALL	LODV2
+DIVE:	;(EXTERNAL ENTRY FROM MAIN PROGRAM)
+	XCHG		;SWAP D,E WITH H,L FOR DIVIDE FUNCTION
+;	COMPUTE X/Y WHERE X IS IN D,E AND Y IS IN H,L
+;	THE VALUE OF X/Y APPEARS IN D,E AND X MOD Y IS IN H,L
+;
+	SHLD	DTEMP	;SAVE X IN TEMPORARY
+	LXI	H,BNUM	;STORE BIT COUNT
+	MVI	M,11H
+	LXI	B,0	;INTIALIZE RESULT
+	PUSH	B
+	XRA	A	;CLEAR FLAGS
+DLOOP:
+	MOV	A,E	;GET LOW Y BYTE
+	RAL
+	MOV	E,A
+	MOV	A,D
+	RAL
+	MOV	D,A
+	DCR	M	;DECREMENT BIT COUNT
+	POP	H	;RESTORE TEMP RESULT
+	RZ		;ZERO BIT COUNT MEANS ALL DONE
+	MVI	A,0	;ADD IN CARRY
+	ACI	0	;CARRY
+	DAD	H	;SHIFT TEMP RESULT LEFT ONE BIT
+	MOV	B,H	;COPY HA AND L TO A A ND C
+	ADD	L
+	LHLD	DTEMP	;GET ADDRESS OF X
+	SUB	L	;SUBTRACT FROM TEMPORARY RESULT
+	MOV	C,A
+	MOV	A,B
+	SBB	H
+	MOV	B,A
+	PUSH	B	;SAVE TEMP RESULT IN STACK
+	JNC	DSKIP	;NO BORROW FROM SUBTRACT
+	DAD	B	;ADD X BACK IN
+	XTHL	;REPLACE TEMP RESULT ON STACK
+DSKIP:	LXI	H,BNUM	;RESTORE H,L
+	CMC
+	JMP	DLOOP	;REPEAT LOOP STEPS
+;
+DTEMP:	DS	2
+BNUM:	DS	1
+;
+MULF:	;MULTIPLY D,E BY H,L AND REPLACE H,L WITH RESULT
+	MOV	B,H
+	MOV	C,L	;COPY OF 1ST VALUE TO B,C FOR SHIFT AND ADD
+	LXI	H,0	;H,L IS THE ACCUMULATOR
+MUL0:	XRA	A
+	MOV	A,B	;CARRY IS CLEARED
+	RAR
+	MOV	B,A
+	MOV	A,C
+	RAR
+	MOV	C,A
+	JC	MUL1	;SKIP THIS ADD IF LSB IS ZERO
+	ORA	B
+	RZ		;RETURN WITH H,L
+	JMP	MUL2	;SKIP ADD
+MUL1:	DAD	D	;ADD CURRENT VALUE OF D
+MUL2:	XCHG	;READY FOR *2
+	DAD	H
+	XCHG
+	JMP	MUL0
+;
+MULOP:	;MULTIPLY D,E BY H,L
+	CALL	LODV2
+	CALL	MULF
+	JMP	ENDOP
+;
+DIVOP:	;DIVIDE H,L BY D,E
+	CALL	DIVF
+	XCHG		;RESULT TO H,L
+	JMP	ENDOP
+;
+MODOP:	CALL	DIVF
+	JMP	ENDOP
+;
+SHLOP:	CALL	SHFT	;CHECK VALUES
+SHL0:	ORA	A	;DONE?
+	JZ	ENDOP
+	DAD	H	;HL=HL*2
+	DCR	A
+	JMP	SHL0
+;
+SHROP:	CALL	SHFT
+SHR0:	ORA	A	;DONE?
+	JZ	ENDOP
+	PUSH	PSW	;SAVE CURRENT COUNT
+	XRA	A
+	MOV	A,H
+	RAR
+	MOV	H,A
+	MOV	A,L
+	RAR
+	MOV	L,A
+	POP	PSW
+	DCR	A
+	JMP	SHR0
+;
+ADDOP:	CALL	LODV2
+ADD0:	DAD	D
+	JMP	ENDOP
+;
+SUBOP:	CALL	LODV2
+	XCHG		;TREAT AS HL+(-DE)
+	CALL	NEGF	;0-HL
+	JMP	ADD0
+;
+NEGOP:	CALL	LODV1
+NEG0:	CALL	NEGF	;COMPUTE 0-HL
+	JMP	ENDOP
+;
+NOTOP:	CALL	LODV1
+	INX	H	;65536-HL = 65535-(HL+1)
+	JMP	NEG0
+;
+ANDOP:	CALL	LODV2
+	MOV	A,D
+	ANA	H
+	MOV	H,A
+	MOV	A,E
+	ANA	L
+	MOV	L,A
+	JMP	ENDOP
+;
+OROP:	CALL	LODV2
+	MOV	A,D
+	ORA	H
+	MOV	H,A
+	MOV	A,E
+	ORA	L
+	MOV	L,A
+	JMP	ENDOP
+;
+XOROP:	CALL	LODV2
+	MOV	A,D
+	XRA	H
+	MOV	H,A
+	MOV	A,E
+	XRA	L
+	MOV	L,A
+;
+ENDOP:	JMP	STKV
+;
+;
+;
+ENDEXP:	;RETURNS ZERO FLAG IF SYMBOL IS CR, ;, OR ,
+	LDA	TOKEN
+	CPI	SPECL
+	RNZ		;NOT END IF NOT SPECIAL
+;
+	LDA	ACCUM
+	CPI	CR
+	RZ
+	CPI	';'
+	RZ
+	CPI	','
+	RZ
+	CPI	'!'
+	RET
+;
+OPAND:	;SCAN THE OPERAND FIELD OF AN INSTRUCTION
+;	(NOT A DB WITH FIRST TOKEN STRING > 2 OR 0)
+	XRA	A
+	STA	OSP	;ZERO OPERATOR STACK POINTER
+	STA	VSP
+	DCR	A	;255
+	STA	UNARY
+	LXI	H,0
+	SHLD	EVALUE
+;
+OP0:	;ARRIVE HERE WITH NEXT ITEM ALREADY SCANNED
+	CALL	ENDEXP	;DONE?
+	JNZ	OP1
+;	EMPTY THE OPERATOR STACK
+EMPOP:	LXI	H,OSP
+	MOV	A,M	;GET THE OSP AND CHECK FOR EMPTY
+	ORA	A
+	JZ	CHKVAL	;JUMP IF EMPTY
+	DCR	M	;POP ELEMENT
+	MOV	E,A	;COPY FOR DOUBLE ADD
+	DCR	E
+	MVI	D,0
+	LXI	H,OPERV
+	DAD	D	;INDEXED - OPERV(OSP)
+	MOV	A,M	;GET OPERATOR
+	CALL	APPLY	;APPLY OPERATOR
+	JMP	EMPOP
+;
+CHKVAL:
+	LDA	VSP	;MUST HAVE ONE ELEMENT IT THE STACK
+	CPI	2
+	CNZ	ERREX
+	LDA	PBUFF
+	CPI	' '
+	RNZ		;EVALUE REMAINS AT ZERO
+	LHLD	VSTACK	;GET DOUBLE BYTE IN STACK
+	SHLD	EVALUE
+	RET
+;
+OP1:	;MORE TO SCAN
+	LDA	PBUFF
+	CPI	' '
+	JNZ	GETOP
+	LDA	TOKEN
+	CPI	STRNG	;IS THIS A STRING?
+	JNZ	OP3
+;
+;	STRING - CONVERT TO DOUBLE PRECISION
+	LDA	ACCLEN
+	ORA	A
+	CZ	ERREX	;ERROR IF LENGTH=0
+	CPI	3
+	CNC	ERREX	;ERROR IF LENGTH>2
+	MVI	D,0
+	LXI	H,ACCUM
+	MOV	E,M	;LSBYTE
+	INX	H
+	DCR	A	;A HAS THE LENGTH
+	JZ	OP2	;ONE OR TWO BYTES
+	MOV	D,M	;FILL HIGH ORDER
+OP2:	XCHG		;VALUE TO H,L
+	JMP	STNUM	;STORE TO STACK
+;
+OP3:	;NOT A STRING, CHECK FOR NUMBER
+	CPI	NUMB
+	JNZ	OP4
+	LHLD	VALUE	;NUMERIC VALUE
+	JMP	STNUM
+;
+OP4:	;NOT STRING OR NUMBER, MUST BE ID OR SPECL
+	CALL	BGET	;BINARY SEARCH, GET ATTRIBUTES
+	JNZ	OP6	;MATCH?
+;	YES, MAY BE OPERATOR
+	CPI	OPER+1
+	JNC	OP5
+;	OPERATOR ENCOUNTERED MS NIBBLE OF B IS PRIORITY NUMBER LS NIBBLE
+;	IS THE OPERATOR
+;	ACC HAS THE OPERATOR NUMBER, B HAS PRIORITY
+	CPI	LPAR	;(?
+	MOV	C,A	;SAVE COPY OF OPERATOR NUMBER
+	LDA	UNARY
+	JNZ	OPER1	;JUMP IF NOT A (
+;	( ENCOUNTERED, UNARY MUST BE TRUE
+	ORA	A
+	CZ	ERREX
+	MVI	A,0FFH
+	STA	UNARY	;UNARY IS SET TRUE
+	MOV	A,C	;RECOVER OPERATOR
+	JMP	OPER4	;CALLS STKO AND SETS UNARY TO TRUE
+;
+;
+OPER1:	;NOT A LEFT PAREN
+	ORA	A
+	JNZ	OPER6	;MUST BE + OR - SINCE UNARY IS SET
+;
+;	UNARY NOT SET, MUST BE BINARY OPERATOR
+OPER2:	;COMPARE HIERARCHY OF TOS
+	PUSH	B	;SAVE PRIORITY AND OPERATOR NUMBER
+	LDA	OSP
+	ORA	A
+	JZ	OPER3	;NO MORE OPERATORS IN STACK
+	MOV	E,A	;OSP TO E
+	DCR	E	;OSP-1
+	MVI	D,0
+	LXI	H,HIERV
+	DAD	D	;HL ADDRESSES TOP OF OPERATOR STACK
+	MOV	A,M	;PRIORITY OF TOP OPERATOR
+	CMP	B	;CURRENT GREATER?
+	JC	OPER3	;JUMP IF SO
+;	APPLY TOP OPERATOR TO VALUE STACK
+	LXI	H,OSP
+	MOV	M,E	;OSP=OSP-1
+	LXI	H,OPERV
+	DAD	D
+	MOV	A,M	;OPERATOR NUMBER TO ACC
+	CALL	APPLY
+	POP	B	;RESTORE OPERATOR NUMBER AND PRIORITY
+	JMP	OPER2	;FOR ANOTHER TEST
+;
+OPER3:	;ARRIVE HERE WHEN OPERATOR IS STACKED
+;	CHECK FOR RIGHT PAREN BALANCE
+	POP	B	;OPERATOR NUMBER IN C, PRIORITY IN B
+	MOV	A,C
+	CPI	RPAR
+	JNZ	OPER4	;JUMP IF NOT A RIGHT PAREN
+;
+;	RIGHT PAREN FOUND, STACK MUST CONTAIN LEFT PAREN TO DELETE
+	LXI	H,OSP
+	MOV	A,M
+	ORA	A	;ZERO?
+	JZ	LPERR	;PAREN ERROR IF SO
+	DCR	A	;OSP-1
+	MOV	M,A	;STORED TO MEMORY
+	MOV	E,A
+	MVI	D,0
+	LXI	H,OPERV
+	DAD	D
+	MOV	A,M	;TOP OPERATOR IN REG-A
+	CPI	LPAR
+	JZ	NLERR	;JMP IF NO ERROR - PARENS BALANCE
+LPERR:	CALL	ERREX
+NLERR:	;ERROR REPORTING COMPLETE
+	XRA	A
+	JMP	OPER5	;TO CLEAR UNARY FLAG
+;
+OPER4:	;ORDINARY OPERATOR
+	CALL	STKO
+	MVI	A,0FFH	;TO SET UNARY FLAG
+OPER5:	STA	UNARY
+	JMP	GETOP	;FOR ANOTHER ELEMENT
+;
+OPER6:	;UNARY SET, MUST BE + OR -
+	MOV	A,C	;RECALL OPERATOR
+	CPI	PLUS
+	JZ	GETOP	;IGNORE UNARY PLUS
+	CPI	MINUS
+	JNZ	CHKNOT
+	INR	A	;CHANGE TO UNARY MINUS
+	MOV	C,A
+	JMP	OPER2
+CHKNOT:	;UNARY NOT SYMBOL?
+	CPI	NOTF
+	CNZ	ERREX
+	JMP	OPER2
+;
+;
+OP5:	;ELEMENT FOUND IN TABLE, NOT AN OPERATOR
+	CPI	PT	;PSEUDO OPERATOR?
+	CZ	ERREX	;ERROR IF SO
+	MOV	L,B	;GET LOW VALUE TO L
+	MVI	H,0	;ZERO HIGH ORDER BYTE
+	JMP	STNUM	;STORE IT
+;
+OP6:	;NOT FOUND IN TABLE SCAN, $?
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	OP7
+	LDA	ACCUM
+	CPI	'$'
+	JZ	CURPC	;USE CURRENT PC
+	CALL	ERREX
+	LXI	H,0
+	JMP	STNUM
+CURPC:	LHLD	ASPC	;GET CURRENT PC
+	JMP	STNUM
+;
+OP7:	;NOT $, LOOK IT UP
+	CALL	LOOKUP
+	CALL	FOUND
+	JNZ	FIDENT
+;	NOT FOUND IN SYMBOL TABLE, ENTER IF PASS 1
+	MVI	A,'P'
+	CALL	PERR
+	CALL	ENTER	;ENTER SYMBOL WITH ZERO TYPE FIELD
+	JMP	FIDE0
+FIDENT:	CALL	GETTY	;TYPE TO H,L
+	ANI	111B
+	MVI	A,'U'
+	CZ	PERR
+;
+FIDE0:
+	CALL	GETVAL	;VALUE TO H,L
+;
+STNUM:	;STORE H,L TO VALUE STACK
+	LDA	UNARY
+	ORA	A	;UNARY OPERATION SET
+	CZ	ERREX	;OPERAND ENCOUNTERED WITH UNARY OFF
+	XRA	A
+	STA	UNARY	;SET TO OFF
+	CALL	STKV	;STACK THE VALUE
+;
+GETOP:	CALL	SCAN
+	JMP	OP0
+;
+ERREX:	;PUT 'E' ERROR IN OUTPUT BUFFER
+	PUSH	H
+	MVI	A,'E'
+	CALL	PERR
+	POP	H
+	RET
+;
+ENDMOD	EQU	($ AND 0FFE0H) + 20H	;NEXT HALF PAGE
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/as6main.asm

@@ -0,0 +1,895 @@
+	TITLE	'ASM MAIN MODULE'
+;	MP/M RESIDENT ASSEMBLER MAIN PROGRAM
+;
+;		COPYRIGHT  (C) 1976, 1977, 1978, 1979, 1980, 1981
+;		DIGITAL RESEARCH
+;		BOX 579, PACIFIC GROVE
+;		CALIFORNIA, 93950
+;
+;		Revised:
+;		  14 Sept 81  by Thomas Rolander
+;
+;
+	org	0
+base	equ	$
+
+	ORG	1BA0H
+;	MODULE ENTRY POINTS
+IOMOD	EQU	base+200H	;IO MODULE
+SCMOD	EQU	base+1100H	;SCANNER MODULE
+SYMOD	EQU	base+1340H	;SYMBOL TABLE MODULE
+BMOD	EQU	base+15A0H	;BINARY SEARCH MODULE
+OPMOD	EQU	base+1860H	;OPERAND SCAN MODULE
+;
+SETUP	EQU	IOMOD+3H	;FILE SETUP FOR EACH PASS
+PCON	EQU	IOMOD+12H	;WRITE CONSOLE BUFFER TO CR
+WOBUFF	EQU	IOMOD+15H	;WRITE PRINT BUFFER AND REINITIALIZE
+PERR	EQU	IOMOD+18H	;WRITE ERROR CHARACTER TO PRINT BUFFER
+DHEX	EQU	IOMOD+1BH	;SEND HEX CHARACTER TO MACHINE CODE FILE
+EOR	EQU	IOMOD+1EH	;END OF PROCESSING, CLOSE FILES AND TERMINATE
+;
+INITS	EQU	SCMOD+3H	;INITIALIZE SCANNER MODULE
+SCAN	EQU	SCMOD+6H	;SCAN NEXT TOKEN
+;
+INISY	EQU	SYMOD+3H	;INITIALIZE SYMBOL TABLE
+LOOKUP	EQU	SYMOD+6H	;LOOKUP SYMBOL IN ACCUMULATOR
+FOUND	EQU	SYMOD+9H	;FOUND IF NZ FLAG
+ENTER	EQU	SYMOD+0CH	;ENTER SYMBOL IN ACCUMULATOR
+SETTY	EQU	SYMOD+0FH	;SET TYPE FIELD
+GETTY	EQU	SYMOD+12H	;GET TYPE FIELD
+SETVAL	EQU	SYMOD+15H	;SET VALUE FIELD
+GETVAL	EQU	SYMOD+18H	;GET VALUE FIELD
+;
+BGET	EQU	BMOD+6H		;BINARY SEARCH AND GET TYPE/VALUE PAIR
+;
+OPAND	EQU	OPMOD+3H	;GET OPERAND VALUE TO 'EVALUE'
+MULF	EQU	OPMOD+6H	;MULT D,E BY H,L TO H,L
+DIVF	EQU	OPMOD+9H	;DIVIDE HL BY DE, RESULT TO DE
+;
+;
+;	COMMON EQUATES
+PBMAX	EQU	90	;MAX PRINT SIZE
+PBUFF	EQU	base+10CH	;PRINT BUFFER
+PBP	EQU	PBUFF+PBMAX	;PRINT BUFFER POINTER
+;
+TOKEN	EQU	PBP+1	;CURRENT TOKEN UDER SCAN
+VALUE	EQU	TOKEN+1	;VALUE OF NUMBER IN BINARY
+ACCLEN	EQU	VALUE+2	;ACCUMULATOR LENGTH
+ACMAX	EQU	64	;MAX ACCUMULATOR LENGTH
+ACCUM	EQU	ACCLEN+1
+;
+EVALUE	EQU	ACCUM+ACMAX	;VALUE FROM EXPRESSION ANALYSIS
+;
+SYTOP	EQU	EVALUE+2	;CURRENT SYMBOL TOP
+SYMAX	EQU	SYTOP+2		;MAX ADDRESS+1
+;
+PASS	EQU	SYMAX+2	;CURRENT PASS NUMBER
+FPC	EQU	PASS+1	;FILL ADDRESS FOR NEXT HEX BYTE
+ASPC	EQU	FPC+2	;ASSEMBLER'S PSEUDO PC
+SYBAS	EQU	ASPC+2	;BASE OF SYMBOL TABLE
+SYADR	EQU	SYBAS+2	;CURRENT SYMBOL ADDRESS
+;
+;	GLOBAL EQUATES
+IDEN	EQU	1	;IDENTIFIER
+NUMB	EQU	2	;NUMBER
+STRNG	EQU	3	;STRING
+SPECL	EQU	4	;SPECIAL CHARACTER
+;
+PLABT	EQU	0001B	;PROGRAM LABEL
+DLABT	EQU	0010B	;DATA LABEL
+EQUT	EQU	0100B	;EQUATE
+SETT	EQU	0101B	;SET
+MACT	EQU	0110B	;MACRO
+;
+EXTT	EQU	1000B	;EXTERNAL
+REFT	EQU	1011B	;REFER
+GLBT	EQU	1100B	;GLOBAL
+;
+CR	EQU	0DH	;CARRIAGE RETURN
+LF	EQU	0AH	;LINE FEED
+EOF	EQU	1AH	;END OF FILE
+NBMAX	EQU	16	;STARTING POSITION OF PRINT LINE
+;
+;
+RT	EQU	16	;REGISTER TYPE
+PT	EQU	RT+1	;PSEUDO OPERATION
+PENDIF	EQU	5	;PSEUDO OPERATOR 'ENDIF'
+OBASE	EQU	PT+1
+O1	EQU	OBASE+1	;FIRST OPERATOR
+O15	EQU	OBASE+15;LAST OPERATOR
+;
+;	MAIN STATEMENT PROCESSING LOOP
+	XRA	A
+	STA	PASS	;SET TO PASS 0 INITIALLY
+	CALL	INISY	;INITIALIZE THE SYMBOL TABLE
+RESTART:	;PASS LOOP GOES FROM 0 TO 1
+	CALL	INITS	;INITIALIZE THE SCANNER
+	CALL	SETUP	;SET UP THE INPUT FILE
+	LXI	H,0
+	SHLD	SYLAB	;ASSUME NO STARTING LABEL
+	SHLD	FPC
+	SHLD	ASPC
+	SHLD	EPC	;END PC
+;
+SCNEXT:	;SCAN THE NEXT INPUT ITEM
+	CALL	SCAN
+SCN0:	LDA	TOKEN
+	CPI	NUMB	;SKIP LEADING NUMBERS FROM LINE EDITORS
+	JZ	SCNEXT
+	CPI	SPECL	;MAY BE PROCESSOR TECH'S COMMENT
+	JNZ	SCN1
+;	SPECIAL CHARACTER, CHECK FOR *
+	LDA	ACCUM
+	CPI	'*'
+	JNZ	CHEND	;END OF LINE IF NOT *
+;	* FOUND, NO PRECEDING LABEL ALLOWED
+	CALL	SETLA
+	JNZ	STERR	;ERROR IF LABEL
+	JMP	CHEN1	;SCAN THE COMMENT OTHERWISE
+;
+SCN1:	;NOT NUMBER OR SPECIAL CHARACTER, CHECK FOR IDENTIFIER
+	CPI	IDEN
+	JNZ	STERR	;ERROR IF NOT
+;
+;	IDENTIFIER FOUND, MAY BE LABEL, OPCODE, OR MACRO
+	CALL	BGET	;BINARY SEARCH FIXED DATA
+	JZ	CHKPT	;CHECK FOR PSEUDO OR REAL OPERATOR
+;
+;	BINARY SEARCH WAS UNSUCCESSFUL, CHECK FOR MACRO
+	CALL	LOOKUP
+	CALL	FOUND
+	JNZ	LFOUN	;NZ FLAG SET IF FOUND
+;
+;	NOT FOUND, ENTER IT
+	CALL	ENTER	;THIS MUST BE PASS 0
+	LDA	PASS
+	ORA	A
+	CNZ	ERRP	;PHASE ERROR IF NOT
+	JMP	SETSY	;SET SYLAB
+;
+;	ITEM WAS FOUND, CHECK FOR MACRO
+LFOUN:	CALL	GETTY
+	CPI	MACT
+	JNZ	SETSY
+;
+;	MACRO DEFINITION FOUND, EXPAND MACRO
+	CALL	ERRN	;NOT CURRENTLY IMPLEMENTED
+	JMP	CHEN1	;SCANS TO END OF CURRENT LINE
+;
+SETSY:	;LABEL FOUND - IS IT THE ONLY ONE?
+	LHLD	SYLAB
+	MOV	A,L
+	ORA	H
+	CNZ	ERRL	;LABEL ERROR IF NOT
+	LHLD	SYADR	;ADDRESS OF SYMBOL
+	SHLD	SYLAB	;MARK AS LABEL FOUND
+;
+;	LABEL FOUND, SCAN OPTIONAL ':'
+	CALL	SCAN
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	SCN0	;SKIP NEXT SCAN IF NOT SPECIAL
+	LDA	ACCUM
+	CPI	':'
+	JNZ	SCN0
+	JMP	SCNEXT	;TO IGNORE ':'
+;
+;	BINARY SEARCH FOUND SYMBOL, CHECK FOR PSEUDO OR REAL OP
+CHKPT:	CPI	PT	;PSEUDO OPCODE?
+	JNZ	CHKOT
+;
+;	PSEUDO OPCODE FOUND, BRANCH TO CASES
+	MOV	E,B	;B HAS PARTICULAR OPERATOR NUMBER
+	MVI	D,0	;DOUBLE PRECISION VALUE TO D,E
+	DCX	D	;BIASED BY +1
+	LXI	H,PTTAB	;BASE OF JUMP TABLE
+	DAD	D
+	DAD	D
+	MOV	E,M
+	INX	H
+	MOV	H,M
+	MOV	L,E
+	PCHL		;JUMP INTO TABLE
+;
+PTTAB:	;PSEUDO OPCODE JUMP TABLE
+	DW	SDB	;DB
+	DW	SDS	;DS
+	DW	SDW	;DW
+	DW	SEND	;END
+	DW	SENDIF	;ENDIF
+	DW	SENDM	;ENDM
+	DW	SEQU	;EQU
+	DW	SIF	;IF
+	DW	SMACRO	;MACRO
+	DW	SORG	;ORG
+	DW	SSET	;SET
+	DW	STITLE	;TITLE
+;
+SDB:
+	CALL	FILAB	;SET LABEL FOR THIS LINE TO ASPC
+SDB0:
+	CALL	SCAN	;PAST DB TO NEXT ITEM
+	LDA	TOKEN	;LOOK FOR LONG STRING
+	CPI	STRNG
+	JNZ	SDBC	;SKIP IF NOT STRING
+	LDA	ACCLEN
+	DCR	A	;LENGTH 1 STRING?
+	JZ	SDBC
+;	LENGTH 0,2,... STRING
+	MOV	B,A
+	INR	B
+	INR	B	;BECOMES 1,3,... FOR 0,2,... LENGTHS
+	LXI	H,ACCUM	;ADDRESS CHARACTERS IN STRING
+SDB1:	DCR	B	;COUNT DOWN TO ZERO
+	JZ	SDB2	;SCAN DELIMITER AT END OF STRING
+	PUSH	B	;SAVE COUNT
+	MOV	B,M	;GET CHARACTER
+	INX	H
+	PUSH	H	;SAVE ACCUM POINTER
+	CALL	FILHB	;SEND TO HEX FILE
+	POP	H
+	POP	B
+	JMP	SDB1
+SDB2:	CALL	SCAN	;TO THE DELIMITER
+	JMP	SDB3
+;
+;	NOT A LONG STRING
+SDBC:	CALL	OPAND	;COMPUTE OPERAND
+	LHLD	EVALUE	;VALUE TO H,L
+	MOV	A,H
+	ORA	A	;HIGH ORDER MUST BE ZERO
+	CNZ	ERRD	;DATA ERROR
+	MOV	B,L	;GET LOW BYTE
+	CALL	FILHB
+SDB3:	;END OF ITEM - UPDATE ASPC
+	CALL	SETAS	;SET ASPC TO FPC
+	CALL	DELIM
+	CPI	','
+	JZ	SDB0	;FOR ANOTHER ITEM
+	JMP	CHEND	;CHECK END OF LINE SYNTAX
+;
+SDS:
+	CALL	FILAB	;HANDLE LABEL IF IT OCCURRED
+	CALL	PADD	;PRINT ADDRESS
+	CALL	EXP16	;SCAN AND GET 16BIT OPERAND
+	XCHG		;TO D,E
+	LHLD	ASPC	;CURRENT PSEUDO PC
+	DAD	D	;+EXPRESSION
+	SHLD	ASPC
+	SHLD	FPC	;NEXT TO FILL
+	JMP	CHEND
+;
+SDW:
+	CALL	FILAB	;HANDLE OPTIONAL LABEL
+SDW0:
+	CALL	EXP16	;GET 16BIT OPERAND
+	PUSH	H	;SAVE A COPY
+	MOV	B,L	;LOW BYTE FIRST
+	CALL	FILHB	;SEND LOW BYTE
+	POP	H	;RECLAIM A COPY
+	MOV	B,H	;HIGH BYTE NEXT
+	CALL	FILHB	;SEND HIGH BYTE
+	CALL	SETAS	;SET ASPC=FPC
+	CALL	DELIM	;CHECK DELIMITER SYNTAX
+	CPI	','
+	JZ	SDW0	;GET MORE DATA
+	JMP	CHEND
+;
+SEND:
+	CALL	FILAB
+	CALL	PADD	;WRITE LAST LOC
+	LDA	PBUFF
+	CPI	' '
+	JNZ	CHEND
+	CALL	EXP16	;GET EXPRESSION IF IT'S THERE
+	LDA	PBUFF
+	CPI	' '
+	JNZ	SEND0
+	SHLD	EPC	;EXPRESSION FOUND, STORE IT FOR LATER
+SEND0:	MVI	A,' '
+	STA	PBUFF	;CLEAR ERROR, IF IT OCCURRED
+	CALL	SCAN	;CLEAR CR
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	STERR
+	LDA	ACCUM
+	CPI	LF
+	JNZ	STERR
+	JMP	ENDAS	;END OF ASSEMBLER
+;
+SENDIF:
+	JMP	POEND
+;
+SENDM:
+	CALL	ERRN
+	JMP	POEND
+;
+SEQU:
+	CALL	SETLA
+	JZ	STERR	;MUST BE A LABEL
+	LHLD	ASPC	;HOLD TEMP ASPC
+	PUSH	H	;IN STACK
+	CALL	EXP16	;GET 16BIT OPERAND
+	SHLD	ASPC	;VALUE OF EXPRESSION
+	CALL	FILAB
+	CALL	PADDR	;COMPUTED VALUE
+	LXI	H,PBUFF+6	;SPACE AFTER VALUE
+	MVI	M,'='
+	POP	H	;REAL ASPC
+	SHLD	ASPC	;CHANGE BACK
+	JMP	CHEND
+;
+SIF:
+	CALL	FILAB	;IN CASE OF LABEL
+	CALL	EXP16	;GET IF EXPRESSION
+	LDA	PBUFF
+	CPI	' '
+	JNZ	CHEND	;SKIP IF ERROR
+	MOV	A,L	;GET LSB
+	RAR
+	JC	CHEND	;TRUE IF CARRY BIT SET
+;
+;	SKIP TO EOF OR ENDIF
+SIF0:	CALL	SCAN
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	SIF1
+	LDA	ACCUM
+	CPI	EOF
+	MVI	A,'B'	;BALANCE ERROR
+	CZ	PERR
+	JZ	ENDAS
+	JMP	SIF0	;FOR ANOTHER
+SIF1:	;NOT A SPECIAL CHARACTER
+	CPI	IDEN
+	JNZ	SIF0	;NOT AN IDENTIFIER
+	CALL	BGET	;LOOK FOR ENDIF
+	JNZ	SIF0	;NOT FOUND
+	CPI	PT	;PSEUDO OP?
+	JNZ	SIF0
+	MOV	A,B	;GET OPERATOR NUMBER
+	CPI	PENDIF	;ENDIF?
+	JNZ	SIF0	;GET ANOTHER TOKEN
+	JMP	POEND	;OK, CHECK END OF LINE
+;
+SMACRO:
+	CALL	ERRN
+	JMP	CHEND
+;
+SORG:
+	CALL	EXP16
+	LDA	PBUFF
+	CPI	' '
+	JNZ	CHEND	;SKIP ORG IF ERROR
+	SHLD	ASPC	;CHANGE PC
+	SHLD	FPC	;CHANGE NEXT TO FILL
+	CALL	FILAB	;IN CASE OF LABEL
+	CALL	PADD
+	JMP	CHEND
+;
+SSET:
+	CALL	SETLA
+	JZ	STERR	;MUST BE LABELLED
+;
+	CALL	GETTY
+	CPI	SETT
+	CNZ	ERRL	;LABEL ERROR
+	MVI	A,SETT
+	CALL	SETTY	;REPLACE TYPE WITH 'SET'
+	CALL	EXP16	;GET THE EXPRESSION
+	PUSH	H	;SAVE IT
+	CALL	SETLA	;RE-ADDRESS LABEL
+	POP	H	;RECLAIM IT
+	CALL	SETVAL
+	LXI	H,0
+	SHLD	SYLAB	;PREVENT LABEL PROCESSING
+	JMP	CHEND
+;
+;
+STITLE:
+	CALL	ERRN	;NOT IMPLEMENTED
+;
+POEND:	;PSEUDO OPERATOR END - SCAN TO NEXT TOKEN
+	CALL	SCAN
+	JMP	CHEND
+;
+;	NOT A PSEUDO OPCODE, CHECK FOR REAL OPCODE
+CHKOT:	SUI	O1	;BASE OF OPCODES
+	CPI	O15	;PAST LAST OPCODE?
+	JNC	STERR	;STATEMENT ERROR IF SO
+;
+;	FOUND OPCODE, COMPUTE INDEX INTO TABLE AND JUMP TO CASE
+	MOV	E,A
+	MVI	D,0
+	LXI	H,OPTAB
+	DAD	D
+	DAD	D
+	MOV	E,M
+	INX	H
+	MOV	H,M
+	MOV	L,E
+	PCHL		;JUMP TO CASE
+;
+OPTAB:	;OPCODE CATEGORIES
+	DW	SSIMP	;SIMPLE
+	DW	SLXI	;LXI
+	DW	SDAD	;DAD
+	DW	SPUSH	;PUSH/POP
+	DW	SJMP	;JMP/CALL
+	DW	SMOV	;MOV
+	DW	SMVI	;MVI
+	DW	SACCI	;ACCUM IMMEDIATE
+	DW	SLDAX	;LDAX/STAX
+	DW	SLHLD	;LHLD/SHLD/LDA/STA
+	DW	SACCR	;ACCUM-REGISTER
+	DW	SINC	;INC/DCR
+	DW	SINX	;INX/DCX
+	DW	SRST	;RESTART
+	DW	SIN	;IN/OUT
+;
+SSIMP:	;SIMPLE OPERATION CODES
+	CALL	FILHB	;SEND HEX VALUE TO MACHINE CODE FILE
+	CALL	SCAN	;TO NEXT TOKEN
+	JMP	INCPC
+;
+SLXI:	;LXI H,16B
+	CALL	SHDREG	;SCAN DOUBLE PRECISION REGISTER
+	CALL	CHCOM	;CHECK FOR COMMA FOLLOWING REGISTER
+	CALL	SETADR	;SCAN AND EMIT DOUBLE PRECISION OPERAND
+	JMP	INCPC
+;
+SDAD:	;DAD B
+	CALL	SHDREG	;SCAN AND EMIT DOUBLE PRECISION REGISTER
+	JMP	INCPC
+;
+SPUSH:	;PUSH B POP D
+	CALL	SHREG	;SCAN SINGLE PRECISION REGISTER TO A
+	CPI	111000B	;MAY BE PSW
+	JZ	SPU0
+;	NOT PSW, MUST BE B,D, OR H
+	ANI	001000B	;LOW BIT MUST BE 0
+	CNZ	ERRR	;REGISTER ERROR IF NOT
+SPU0:	MOV	A,C	;RECALL REGISTER AND MASK IN CASE OF ERROR
+	ANI	110000B
+	ORA	B	;MASK IN OPCODE FOR PUSH OR POP
+	JMP	FILINC	;FILL HEX VALUE AND INCREMENT PC
+;
+SJMP:	;JMP 16B/ CALL 16B
+	CALL	FILHB	;EMIT JMP OR CALL OPCODE
+	CALL	SETADR	;EMIT 16BIT OPERAND
+	JMP	INCPC
+;
+SMOV:	;MOV A,B
+	CALL	SHREG
+	ORA	B	;MASK IN OPCODE
+	MOV	B,A	;SAVE IN B TEMPORARILY
+	CALL	CHCOM	;MUST BE COMMA SEPARATOR
+	CALL	EXP3	;VALUE MUST BE 0-7
+	ORA	B	;MASK IN OPCODE
+	JMP	FILINC
+;
+SMVI:	;MVI A,8B
+	CALL	SHREG
+	ORA	B	;MASK IN OPCODE
+	CALL	FILHEX	;EMIT OPCODE
+	CALL	CHCOM	;SCAN COMMA
+	CALL	SETBYTE	;EMIT 8BIT VALUE
+	JMP	INCPC
+;
+SACCI:	;ADI 8B
+	CALL	FILHB	;EMIT IMMEDIATE OPCODE
+	CALL	SETBYTE	;EMIT 8BIT OPERAND
+	JMP	INCPC
+;
+SLDAX:	;LDAX B/STAX D
+	CALL	SHREG
+	ANI	101000B	;MUST BE B OR D
+	CNZ	ERRR	;REGISTER ERROR IF NOT
+	MOV	A,C	;RECOVER REGISTER NUMBER
+	ANI	010000B	;CHANGE TO B OR D IF ERROR
+	ORA	B	;MASK IN OPCODE
+	JMP	FILINC	;EMIT OPCODE
+;
+SLHLD:	;LHLD 16B/ SHLD 16B/ LDA 16B/ STA 16B
+	CALL	FILHB	;EMIT OPCODE
+	CALL	SETADR	;EMIT OPERAND
+	JMP	INCPC
+;
+SACCR:	;ADD B
+	CALL	EXP3	;RIGHT ADJUSTED 3BIT VALUE FOR REGISTER
+	ORA	B	;MASK IN OPCODE
+	JMP	FILINC
+;
+SINC:	;INR B/DCR D
+	CALL	SHREG	;GET REGISTER
+	ORA	B
+	JMP	FILINC
+;
+SINX:	;INX H/DCX B
+	CALL	SHREG
+	ANI	001000B	;MUST BE B D M OR SP
+	CNZ	ERRR	;REGISTER ERROR IF NOT
+	MOV	A,C	;RECOVER REGISTER
+	ANI	110000B	;IN CASE OF ERROR
+	ORA	B	;MASK IN OPCODE
+	JMP	FILINC
+;
+SRST:	;RESTART 4
+	CALL	SHREG	;VALUE IS 0-7
+	ORA	B	;OPCODE MASKED
+	JMP	FILINC
+;
+SIN:	;IN 8B/OUT 8B
+	CALL	FILHB	;EMIT OPCODE
+	CALL	SETBYTE	;EMIT 8BIT OPERAND
+	JMP	INCPC
+;
+FILINC:	;FILL HEX VALUE FROM A BEFORE INCREMENTING PC
+	CALL	FILHEX
+;
+INCPC:	;CHANGE ASSEMBLER'S PSEUDO PROGRAM COUNTER
+	CALL	FILAB	;SET ANY LABELS WHICH OCCUR ON THE LINE
+	CALL	SETAS	;ASPC=FPC
+	JMP	CHEND	;END OF LINE SCAN
+;
+;
+;	UTILITY SUBROUTINES FOR OPERATION CODES
+;
+DELIM:	;CHECK DELIMITER SYNTAX FOR DATA STATEMENTS
+	LDA	TOKEN
+	CPI	SPECL
+	CNZ	ERRD
+	LDA	ACCUM
+	CPI	','
+	RZ
+	CPI	';'
+	RZ
+	CPI	CR
+	CNZ	ERRD
+	RET
+;
+EXP16:	;GET 16BIT VALUE TO H,L
+	PUSH	B
+	CALL	SCAN	;START SCANNING OPERAND FIELD
+	CALL	OPAND
+	LHLD	EVALUE	;VALUE TO H,L
+	POP	B
+	RET
+;
+EXP8:	;GET 8BIT VALUE TO REG A
+	CALL	EXP16
+	MOV	A,H
+	ORA	A
+	CNZ	ERRV	;VALUE ERROR IF HIGH BYTE NOT ZERO
+	MOV	A,L
+	RET
+;
+EXP3:	;GET 3BIT VALUE TO REG A
+	CALL	EXP8
+	CPI	8
+	CNC	ERRV	;VALUE ERROR IF >=8
+	ANI	111B	;REDUCE IF ERROR OCCURS
+	RET
+;
+SHREG:	;GET 3BIT VALUE AND SHIFT LEFT BY 3
+	CALL	EXP3
+	RAL
+	RAL
+	RAL
+	ANI	111000B
+	MOV	C,A	;COPY TO C
+	RET
+;
+SHDREG:	;GET DOUBLE REGISTER TO A
+	CALL	SHREG
+	ANI	001000B	;CHECK FOR A,C,E, OR L
+	CNZ	ERRR	;REGISTER ERROR
+	MOV	A,C	;RECOVER REGISTER
+	ANI	110000B	;FIX IT IF ERROR OCCURRED
+	ORA	B	;MASK OPCODE
+	JMP	FILHEX	;EMIT IT
+;
+SETBYTE:	;EMIT 16BIT OPERAND
+	CALL	EXP8
+	JMP	FILHEX
+;
+SETADR:	;EMIT 16BIT OPERAND
+	CALL	EXP16
+	JMP	FILADR
+;
+CHCOM:	;CHECK FOR COMMA FOLLOWING EXPRESSION
+	PUSH	PSW
+	PUSH	B
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	COMER
+;	SPECIAL CHARACTER, CHECK FOR COMMA
+	LDA	ACCUM
+	CPI	','
+	JZ	COMRET	;RETURN IF COMMA FOUND
+COMER:	;COMMA ERROR
+	MVI	A,'C'
+	CALL	PERR
+COMRET:
+	POP	B
+	POP	PSW
+	RET
+;
+CHEND:	;END OF LINE CHECK
+	CALL	FILAB	;IN CASE OF A LABEL
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	STERR	;MUST BE A SPECIAL CHARACTER
+	LDA	ACCUM
+	CPI	CR	;CARRIAGE RETURN
+	JNZ	CHEN0
+;	CARRIAGE RETURN FOUND, SCAN PICKS UP LF AND PUSHES LINE
+	CALL	SCAN
+	JMP	SCNEXT
+;
+CHEN0:	;NOT CR, CHECK FOR COMMENT
+	CPI	';'
+	JNZ	CHEN2
+	CALL	FILAB	;IN CASE LABELLED EMPTY LINE
+;	CLEAR COMMENT TO END OF LINE
+CHEN1:	CALL	SCAN
+	LDA	TOKEN
+	CPI	SPECL
+	JNZ	CHEN1
+	LDA	ACCUM
+	CPI	LF
+	JZ	SCNEXT
+	CPI	EOF
+	JZ	ENDAS	;END OF ASSEMBLY IF EOF
+	CPI	'!'
+	JZ	SCNEXT	;LOGICAL END OF LINE
+	JMP	CHEN1	;NONE OF THE ABOVE
+;
+;	NOT CR OR LF, MAY BE LOGICAL END OF LINE
+CHEN2:	CPI	'!'
+	JZ	SCNEXT
+	CPI	EOF
+	JZ	ENDAS
+;
+;	STATEMENT ERROR IN OPERAND FIELD
+STERR:	MVI	A,'S'
+	CALL	PERR
+	JMP	CHEN1	;TO DUMP LINE
+;
+DIFF:	;COMPUTE DE-HL TO HL
+	MOV	A,E
+	SUB	L
+	MOV	L,A
+	MOV	A,D
+	SBB	H
+	MOV	H,A
+	RET
+;
+ENDAS:	;END OF ASSEMBLY FOR THIS PASS
+	LXI	H,PASS
+	MOV	A,M
+	INR	M	;PASS NUMBER INCREMENTED
+	ORA	A
+	JZ	RESTART
+	CALL	SCAN	;TO CLEAR LAST LINE FEED
+	CALL	PADD	;WRITE LAST ADDRESS
+	LXI	H,PBUFF+5
+	MVI	M,CR	;SET TO CR FOR END OF MESSAGE
+	LXI	H,PBUFF+1
+	CALL	PCON	;PRINT LAST ADDRESS
+;
+;	COMPUTE REMAINING SPACE
+	LHLD	SYTOP
+	XCHG
+	LHLD	SYBAS
+	CALL	DIFF	;DIFFERENCE TO H,L
+	PUSH	H	;SYTOP-SYBAS TO STACK
+	LHLD	SYMAX
+	XCHG
+	LHLD	SYBAS
+	CALL	DIFF	;SYMAX-SYBAS TO H,L
+	MOV	E,H
+	MVI	D,0	;DIVIDED BY 256
+	POP	H	;SYTOP-SYBAS TO H,L
+	CALL	DIVF	;RESULT TO DE
+	XCHG
+	CALL	PADDR	;PRINT H,L TO PBUFF
+	LXI	H,PBUFF+5	;MESSAGE
+	LXI	D,EMSG		;END MESSAGE
+ENDA0:	LDAX	D
+	ORA	A	;ZERO?
+	JZ	ENDA1
+	MOV	M,A
+	INX	H
+	INX	D
+	JMP	ENDA0
+;
+EMSG:	DB	'H USE FACTOR',CR,0
+;
+ENDA1:	LXI	H,PBUFF+2	;BEGINNING OF RATIO
+	CALL	PCON
+	LHLD	EPC
+	SHLD	FPC	;END PROGRAM COUNTER
+	JMP	EOR
+;
+;	UTILITY SUBROUTINES
+COMDH:	;COMPARE D,E WITH H,L FOR EQUALITY (NZ FLAG IF NOT EQUAL)
+	MOV	A,D
+	CMP	H
+	RNZ
+	MOV	A,E
+	CMP	L
+	RET
+;
+SETAS:	;ASPC=FPC
+	LHLD	FPC
+	SHLD	ASPC
+	RET
+;
+SETLA:	;SYADR=SYLAB, FOLLOWED BY CHECK FOR ZERO
+	LHLD	SYLAB
+	SHLD	SYADR
+	CALL	FOUND
+	RET
+;
+FILAB:	;FILL LABEL VALUE WITH CURRENT ASPC, IF LABEL FOUND
+	CALL	SETLA
+	RZ		;RETURN IF NO LABEL DETECTED
+;
+;	LABEL FOUND, MUST BE DEFINED ON PASS-1
+	LXI	H,0
+	SHLD	SYLAB	;TO MARK NEXT STATEMENT WITH NO LABEL
+	LDA	PASS
+	ORA	A
+	JNZ	FIL1
+;
+;	PASS 0
+	CALL	GETTY
+	PUSH	PSW	;SAVE A COPY OF TYPE
+	ANI	111B	;CHECK FOR UNDEFINED
+	CNZ	ERRL	;LABEL ERROR
+	POP	PSW	;RESTORE TYPE
+	ORI	PLABT	;SET TO LABEL TYPE
+	CALL	SETTY	;SET TYPE FIELD
+	LHLD	ASPC	;GET CURRENT PC
+	CALL	SETVAL	;PLACE INTO VALUE FIELD
+	RET
+;
+FIL1:	;CHECK FOR DEFINED VALUE
+	CALL	GETTY
+	ANI	111B
+	CZ	ERRP	;PHASE ERROR
+;	GET VALUE AND COMPARE WITH ASPC
+	CALL	GETVAL	;TO H,L
+	XCHG
+	LHLD	ASPC
+	CALL	COMDH
+	CNZ	ERRP	;PHASE ERROR IF NOT THE SAME
+	RET
+;
+FILHEX:	;WRITE HEX BYTE IN REGISTER A TO MACHINE CODE FILE IF PASS-1
+	MOV	B,A
+FILHB:	LDA	PASS
+	ORA	A
+	MOV	A,B
+	JZ	FILHI
+;
+;	PASS - 1, WRITE HEX AND PRINT DATA
+	PUSH	B	;SAVE A COPY
+	CALL	DHEX	;INTO MACHINE CODE FILE
+;	MAY BE COMPLETELY EMPTY LINE, SO CHECK ADDRESS
+	LDA	PBUFF+1
+	CPI	' '
+	LHLD	ASPC
+	CZ	PADDR	;PRINT ADDRESS FIELD
+;
+	LDA	NBP
+	CPI	NBMAX	;TRUNCATE CODE IF TOO MUCH ON THIS LINE
+	POP	B	;RECALL HEX DIGIT
+	JNC	FILHI
+;	ROOM FOR DIGIT ON THIS LINE
+	MOV	A,B
+	CALL	WHEXB	;WRITE HEX BYTE TO PRINT LINE
+FILHI:	LHLD	FPC
+	INX	H
+	SHLD	FPC	;READY FOR NEXT BYTE
+	RET
+;
+FILADR:	;EMIT DOUBLE PRECISION VALUE FROM H,L
+	PUSH	H	;SAVE A COPY
+	MOV	B,L
+	CALL	FILHB	;LOW BYTE EMITTED
+	POP	H	;RECOVER A COPY OF H,L
+	MOV	B,H
+	JMP	FILHB	;EMIT HIGH BYTE AND RETURN
+;
+;	UTILITY FUNCTIONS FOR PRINTING HEX ADDRESSES AND DATA
+CHEX:	;CONVERT TO HEX
+	ADI	'0'
+	CPI	'0'+10
+	RC
+	ADI	'A'-'0'-10
+	RET
+;
+WHEXN:	;WRITE HEX NIBBLE
+	CALL	CHEX	;CONVERT TO ASCII FROM HEX
+	LXI	H,NBP
+	MOV	E,M	;NEXT POSITION TO PRINT
+	MVI	D,0	;DOUBLE PRECISION
+	INR	M	;NBP=NBP+1
+	LXI	H,PBUFF
+	DAD	D
+	MOV	M,A	;STORE IN PRINT BUFFER
+	RET
+;
+WHEXB:	;WRITE HEX BYTE TO PRINT BUFFER
+	PUSH	PSW
+	RAR
+	RAR
+	RAR
+	RAR
+	ANI	0FH	;HIGH ORDER NIBBLE NORMALIZE IN A
+	CALL	WHEXN	;WRITE IT
+	POP	PSW
+	ANI	0FH
+	JMP	WHEXN	;WRITE AND RETURN
+;
+PADD:	LHLD	ASPC
+PADDR:	;PRINT ADDRESS FIELD OF PRINT LINE FROM H,L
+	XCHG
+	LXI	H,NBP	;INITIALIZE NEXT TO FILL
+	PUSH	H	;SAVE A COPY OF NBP'S ADDRESS
+	MVI	M,1
+	MOV	A,D	;PRINT HIGH BYTE
+	PUSH	D	;SAVE A COPY
+	CALL	WHEXB
+	POP	D
+	MOV	A,E
+	CALL	WHEXB
+	POP	H	;ADDRESSING NBP
+	INR	M	;SKIP A SPACE AFTER ADDRESS FIELD
+	RET
+;
+ERRR:	;EMIT REGISTER ERROR
+	PUSH	PSW
+	PUSH	B
+	MVI	A,'R'
+	CALL	PERR
+	POP	B
+	POP	PSW
+	RET
+;
+ERRV:	;EMIT VALUE ERROR
+	PUSH	PSW
+	PUSH	H
+	MVI	A,'V'
+	CALL	PERR
+	POP	H
+	POP	PSW
+	RET
+;
+ERRD:	PUSH	PSW
+	MVI	A,'D'	;DATA ERROR
+	JMP	ERR
+;
+ERRP:	PUSH	PSW
+	MVI	A,'P'
+	JMP	ERR
+;
+ERRL:	PUSH	PSW
+	MVI	A,'L'	;LABEL ERROR
+	JMP	ERR
+;
+ERRN:	PUSH	PSW
+	MVI	A,'N'	;NOT IMPLEMENTED
+;
+ERR:
+	CALL	PERR
+	POP	PSW
+	RET
+;
+SYLAB:	DS	2	;ADDRESS OF LINE LABEL
+EPC:	DS	2	;END PC VALUE
+NBP:	DS	1	;NEXT BYTE POSITION TO WRITE FOR MACHINE CODE
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/asm.sub

@@ -0,0 +1,52 @@
+mac as0com
+vax as0com.prn $$stan
+vax as0com.sym $$stan
+era *.prn
+era *.sym
+mac as1io
+vax as1io.prn $$stan
+vax as1io.sym $$stan
+era *.prn
+era *.sym
+mac as2scan
+vax as2scan.prn $$stan
+vax as2scan.sym $$stan
+era *.prn
+era *.sym
+mac as3sym
+vax as3sym.prn $$stan
+vax as3sym.sym $$stan
+era *.prn
+era *.sym
+pip as00.hex=as0com.hex[i],as1io.hex[i],as2scan.hex[i],as3sym.hex[h]
+mac as0com $$pzsz+r
+mac as1io $$pzsz+r
+mac as2scan $$pzsz+r
+mac as3sym $$pzsz+r
+pip as01.hex=as0com.hex[i],as1io.hex[i],as2scan.hex[i],as3sym.hex[h]
+mac as4sear
+vax as4sear.prn $$stan
+vax as4sear.sym $$stan
+era *.prn
+era *.sym
+mac as5oper
+vax as5oper.prn $$stan
+vax as5oper.sym $$stan
+era *.prn
+era *.sym
+mac as6main
+vax as6main.prn $$stan
+vax as6main.sym $$stan
+era *.prn
+era *.sym
+pip as10.hex=as4sear.hex[i],as5oper.hex[i],as6main.hex[h]
+mac as4sear $$pzsz+r
+mac as5oper $$pzsz+r
+mac as6main $$pzsz+r
+pip as11.hex=as4sear.hex[i],as5oper.hex[i],as6main.hex[h]
+pip as0.hex=as00.hex[i],as10.hex[h]
+pip as1.hex=as01.hex[i],as11.hex[h]
+pip asm.hex=as0.hex,as1.hex
+genmod asm.hex asm.prl $$1000
+era *.hex
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/ddt.sub

@@ -0,0 +1,40 @@
+mac ddt1asm
+vax ddt1asm.prn $$stan
+vax ddt1asm.sym $$stan
+era ddt1asm0.hex
+ren ddt1asm0.hex=ddt1asm.hex
+mac ddt1asm $$pzsz+r
+era ddt1asm1.hex
+ren ddt1asm1.hex=ddt1asm.hex
+mac ddt2mon
+vax ddt2mon.prn $$stan
+vax ddt2mon.sym $$stan
+era ddt2mon0.hex
+ren ddt2mon0.hex=ddt2mon.hex
+mac ddt2mon $$pzsz+r
+era ddt2mon1.hex
+ren ddt2mon1.hex=ddt2mon.hex
+pip relddt0.hex=ddt1asm0.hex[i],ddt2mon0.hex[h]
+pip relddt1.hex=ddt1asm1.hex[i],ddt2mon1.hex[h]
+pip relddt.hex=relddt0.hex,relddt1.hex
+genmod relddt.hex relddt.com
+genhex relddt 100
+era relddt0.hex
+ren relddt0.hex=relddt.hex
+genhex relddt 200
+era relddt1.hex
+ren relddt1.hex=relddt.hex
+mac ddt0mov
+vax ddt0mov.prn $$stan
+vax ddt0mov.sym $$stan
+era ddt0mov0.hex
+ren ddt0mov0.hex=ddt0mov.hex
+mac ddt0mov $$pzsz+r
+era ddt0mov1.hex
+ren ddt0mov1.hex=ddt0mov.hex
+pip relddt0.hex=relddt0.hex[i],ddt0mov0.hex[h]
+pip relddt1.hex=relddt1.hex[i],ddt0mov1.hex[h]
+pip relddt.hex=relddt0.hex,relddt1.hex
+genmod relddt.hex rdt.prl $$z1500
+prlcom rdt.prl ddt.com
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/ASM/DDT/ddt0mov.asm

@@ -0,0 +1,101 @@
+	TITLE	'DDT RELOCATOR PROGRAM'
+;	DDT RELOCATOR PROGRAM, INCLUDED WITH THE MODULE TO PERFORM
+;	THE MOVE FROM 200H TO THE DESTINATION ADDRESS
+VERSION	EQU	20	;2.0
+;
+;	COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981
+;	DIGITAL RESEARCH
+;	BOX 579 PACIFIC GROVE
+;	CALIFORNIA 93950
+;
+
+;	Revised:
+;	  14 Sept 81  Thomas Rolander
+
+	org	0
+base	equ	$
+
+	ORG	100H
+STACK	EQU	base+200H
+BDOS	EQU	base+05H
+PRNT	EQU	9	;BDOS PRINT FUNCTION
+MODULE	EQU	base+200H	;MODULE ADDRESS
+;
+;	LXI	B,0	;ADDRESS FIELD FILLED-IN WHEN MODULE BUILT
+	db	01h
+	org	103h
+	JMP	START
+	DB	'COPYRIGHT (C) 1981, DIGITAL RESEARCH      '
+SIGNON:	DB	'[MP/M II] DDT VERS '
+	DB	VERSION/10+'0','.'
+	DB	VERSION MOD 10 + '0','$'
+START:	LXI	SP,STACK
+	PUSH	B
+	PUSH	B
+	LXI	D,SIGNON
+	MVI	C,PRNT
+	CALL	BDOS
+	POP	B	;RECOVER LENGTH OF MOVE
+	LXI	H,BDOS+2;ADDRESS FIELD OF JUMP TO BDOS (TOP MEMORY)
+	MOV	A,M	;A HAS HIGH ORDER ADDRESS OF MEMORY TOP
+	DCR	A	;PAGE DIRECTLY BELOW BDOS
+	SUB	B	;A HAS HIGH ORDER ADDRESS OF RELOC AREA
+	MOV	D,A
+	MVI	E,0	;D,E ADDRESSES BASE OF RELOC AREA
+	PUSH	D	;SAVE FOR RELOCATION BELOW
+;
+	LXI	H,MODULE;READY FOR THE MOVE
+MOVE:	MOV	A,B	;BC=0?
+	ORA	C
+	JZ	RELOC
+	DCX	B	;COUNT MODULE SIZE DOWN TO ZERO
+	MOV	A,M	;GET NEXT ABSOLUTE LOCATION
+	STAX	D	;PLACE IT INTO THE RELOC AREA
+	INX	D
+	INX	H
+	JMP	MOVE
+;
+RELOC:	;STORAGE MOVED, READY FOR RELOCATION
+;	HL ADDRESSES BEGINNING OF THE BIT MAP FOR RELOCATION
+	POP	D	;RECALL BASE OF RELOCATION AREA
+	POP	B	;RECALL MODULE LENGTH
+	PUSH	H	;SAVE BIT MAP BASE IN STACK
+	MOV	H,D	;RELOCATION BIAS IS IN D
+;
+REL0:	MOV	A,B	;BC=0?
+	ORA	C
+	JZ	ENDREL
+;
+;	NOT END OF THE RELOCATION, MAY BE INTO NEXT BYTE OF BIT MAP
+	DCX	B	;COUNT LENGTH DOWN
+	MOV	A,E
+	ANI	111B	;0 CAUSES FETCH OF NEXT BYTE
+	JNZ	REL1
+;	FETCH BIT MAP FROM STACKED ADDRESS
+	XTHL
+	MOV	A,M	;NEXT 8 BITS OF MAP
+	INX	H
+	XTHL		;BASE ADDRESS GOES BACK TO STACK
+	MOV	L,A	;L HOLDS THE MAP AS WE PROCESS 8 LOCATIONS
+REL1:	MOV	A,L
+	RAL		;CY SET TO 1 IF RELOCATION NECESSARY
+	MOV	L,A	;BACK TO L FOR NEXT TIME AROUND
+	JNC	REL2	;SKIP RELOCATION IF CY=0
+;
+;	CURRENT ADDRESS REQUIRES RELOCATION
+	LDAX	D
+	ADD	H	;APPLY BIAS IN H
+	STAX	D
+REL2:	INX	D	;TO NEXT ADDRESS
+	JMP	REL0	;FOR ANOTHER BYTE TO RELOCATE
+;
+ENDREL:	;END OF RELOCATION
+	lxi	b,base
+	mov	a,b
+	dcx	d
+	stax	d
+	POP	D	;CLEAR STACKED ADDRESS
+	MVI	L,0
+	PCHL		;GO TO RELOCATED PROGRAM
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/dir.plm

@@ -0,0 +1,355 @@
+$ TITLE('MP/M II --- DIR 2.0')
+dir:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+declare
+    true literally '1',
+    false literally '0',
+    forever literally 'while true',
+    lit literally 'literally',
+    proc literally 'procedure',
+    dcl literally 'declare',
+    addr literally 'address',
+    cr literally '13',
+    lf literally '10';
+
+
+  /**************************************
+   *                                    *
+   *       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;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) 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 (1) byte    external;	/* default dma buffer */
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  write$console:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end write$console;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (18,fcb$address);
+    end search$next;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  set$user$code:
+    procedure(user);
+      declare user byte;
+      call mon1 (32,user);
+    end set$user$code;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address),
+    delimiter based parse$fn.buff$adr byte;
+
+  parse: procedure address;
+    return mon3(152,.parse$fn);
+    end parse;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  crlf:
+    procedure;
+      call write$console (0dh);
+      call write$console (0ah);
+    end crlf;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                * * *  GLOBAL VARIABLES  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+
+declare dir$title (*) byte initial
+  ('Directory for User  x:','$');
+
+declare (sys,temp,dcnt,cnt,user) byte;
+declare 
+   i          byte initial (0),
+   new$user   byte initial (true),
+   sys$exists byte initial (false),
+   incl$sys   byte initial (false),
+   option     byte initial (false);
+
+declare 
+   dirbuf (128) byte;
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                * * *  DIRECTORY DISPLAY  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+                  /* display directory heading */
+heading: procedure;
+
+    if user > 9 then
+    do;
+      dir$title(19) = '1';
+      dir$title(20) = user - 10 + '0';
+    end;
+    else
+    do;
+      dir$title(19) = ' ';
+      dir$title(20) = user + '0';
+    end;
+    call print$buf (.dir$title);
+    end heading;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* do next directory display */
+directory: procedure;
+
+    if new$user then do;
+        call heading;
+        new$user = false;
+        end;
+    sys$exists = false;
+    cnt = -1;
+    /* if drive is 0 (default) 
+       then set to current disk */
+    if fcb(0) = 0
+      then fcb(0) = mon2 (25,0) + 1;
+    if fcb(1) = ' ' then
+    /* check for blank filename => wildcard */
+    do i = 1 to 11;
+      fcb(i) = '?';
+    end;
+    /* get first file */
+    if (dcnt := search$first (.fcb)) <> 0ffh then
+    do while dcnt <> 0ffh;
+      temp = ror(dcnt,3) and 0110$0000b;
+      sys = ((dirbuf(temp+10) and 80h) = 80h);
+      if (dirbuf(temp) = user) and
+         (incl$sys or not sys) then
+      do;
+        if ((cnt:=cnt+1) mod 4) = 0 then
+        do;
+          call crlf;
+          call write$console ('A'+fcb(0)-1);
+        end;
+        else
+        do;
+          call write$console (' ');
+        end;
+        call write$console (':');
+        call write$console (' ');
+        do i = 1 to 11;
+          if i = 9 then call write$console (' ');
+          call write$console
+            (dirbuf(temp+i) and 7fh);
+          if check$con$stat then
+          do;
+            dcnt = read$console;
+            call terminate;
+          end;
+        end;
+      end;
+      else if sys then
+        sys$exists = true;
+      dcnt = search$next (.fcb);
+    end;
+    if cnt = -1 then
+    do;
+      call print$buf (.(0dh,0ah,
+        'File not found.','$'));
+    end;
+    if sys$exists then 
+      call print$buf (.(0dh,0ah,
+        'System Files Exist','$'));
+    end directory;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                    * * *  PARSING  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+                  /* parse next item */
+parse$next: procedure;
+
+    /* skip comma or space delimiter */
+    parse$fn.buff$adr = parse$fn.buff$adr + 1;
+    parse$fn.buff$adr = parse;
+    if parse$fn.buff$adr = 0ffffh then do;
+        call print$buf (.(0dh,0ah,
+          'Bad entry','$'));
+        call terminate;
+        end;
+    if delimiter = ']' then do;    /* skip */
+        parse$fn.buff$adr = parse$fn.buff$adr + 1;
+        if delimiter = 0 then 
+            parse$fn.buff$adr = 0;
+        option = false;
+        end;
+    if delimiter = '[' then 
+        option = true;
+    if parse$fn.buff$adr = 0 then 
+        option = false;
+    end parse$next;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* parse & interpret option */
+parse$option: procedure;
+
+    parse$fn.fcb$adr = .dirbuf;
+        do while option;
+        call parse$next;
+        if dirbuf(1) = 'S' then
+            incl$sys = true;
+        else if dirbuf(1) = 'G' then do;
+            if dirbuf(3) <> ' ' then 
+                temp = dirbuf(3) - '0' + 10;
+            else if dirbuf(2) <> ' ' then
+                temp = dirbuf(2) - '0';
+            if temp < 16 then do;
+                call set$user$code(user:=temp);
+                new$user = true;
+                end;
+            end;
+        end;
+    parse$fn.fcb$adr = .fcb;
+    end parse$option;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+             * * *  M A I N   P R O G R A M  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    user = get$user$code;
+    incl$sys = (fcb16(1) = 'S');
+    call setdma(.dirbuf);
+    parse$fn.buff$adr = .tbuff;
+    parse$fn.fcb$adr = .fcb;
+
+        /* scan for global option */
+        do while tbuff(i:=i+1)=' ';
+        end;
+    if tbuff(i) = '[' then do;   /* skip leading [ */
+        parse$fn.buff$adr = .tbuff(i);
+        option = true;
+        call parse$option;
+        fcb(0) = 0;              /* set current disk */
+        fcb(1) = ' ';            /* clear fcb */
+        call directory;
+        end;
+
+        /* do command line */
+        do while parse$fn.buff$adr <> 0;
+        call parse$next;      /* filename */
+        if option then
+            call parse$option;
+        call directory;
+        end;
+    call terminate;
+  end;
+
+end dir;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/era.plm

@@ -0,0 +1,422 @@
+$ TITLE('MP/M II --- ERA 2.0')
+erase:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '1',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+$include (proces.lit)
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       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;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) 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 (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  search:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search;
+
+  searchn:
+    procedure byte;
+      return mon2 (18,0);
+    end searchn;
+
+  delete$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (19,fcb$address);
+    end delete$file;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure;
+      call mon1 (45,0ffh);	
+    end return$errors;
+
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+declare
+    pdadr      addr,
+    pd         based pdadr process$descriptor;
+
+getpd: procedure;
+
+    pdadr = mon3(156,0);
+    end getpd;
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  declare xfcb     byte initial(0);
+  declare successful lit '0FFh';
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    call printchar(' ');
+    if code=1 then 
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+    if code=2 then 
+        call print$buf(.(cr,lf,'Drive $'));
+    if code = 3 or code = 2 then
+        call print$buf(.('Read Only$'));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code < 3 then 
+        call terminate;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                 /* print file name */
+print$file: procedure(fcbp);
+        declare k byte;
+        declare typ lit '9';        /* file type */
+        declare fnam lit '11';        /* file type */
+        declare
+            fcbp   addr,
+            fcbv   based fcbp (32) byte;
+
+            do k = 1 to fnam;
+            if k = typ then 
+	       call printchar('.');
+            call printchar(fcbv(k) and 7fh);
+            end;
+        end print$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to delete fcb at fcb$address
+            return error code if unsuccessful */
+  delete:
+    procedure(fcb$address) byte;
+    declare
+       fcb$address address,
+       fcbv based  fcb$address (32) byte,
+       error$code  address,
+       code        byte;
+       
+    if xfcb then 
+        fcbv(5) = fcbv(5) or 80h;
+    call setdma(.fcb16);                   /* password */
+    fcbv(0) = fcb(0);                      /* drive */
+    error$code = delete$file(fcb$address);
+    fcbv(5) = fcbv(5) and 7fh;             /* reset xfcb bit */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if (code=1) or (code=2) then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end delete;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then do;
+            call crlf;
+            go to exit;
+            end;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* try deleting files one at a time */
+  single$file:
+    procedure;
+    declare (code,dcnt,sav$searchl) byte;
+    declare (fcba,sav$dcnt) addr;
+
+    file$err: procedure;
+        call crlf;
+        call print$buf(.('Not erased: $'));
+        call print$file(fcba);
+        call error(code);
+        end file$err;
+
+    call setdma(.tbuff);
+    dcnt = search(.fcb);
+        do while dcnt <> 0ffh;
+        fcba = shl(dcnt,5) + .tbuff;
+        sav$dcnt = pd.dcnt;
+        sav$searchl = pd.searchl;
+        if (code:=delete(fcba)) = 7 then do;
+            call file$err;
+            call getpasswd;
+            code = delete(fcba);
+            end;
+        if code <> successful then 
+            call file$err;
+        call setdma(.tbuff);
+        /* restore dcnt and search length of 11 */
+        pd.dcnt = sav$dcnt;
+        pd.searchl = sav$searchl;
+        dcnt = searchn;
+        end;
+    end single$file;
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+declare (i,response,user,code) byte;
+declare ver address;
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    parse$fn.buff$adr = .tbuff(1);
+    parse$fn.fcb$adr = .fcb;
+    user = get$user$code;
+    call getpd;             /* process descriptor */
+    call return$errors;
+    if fcb(17) <> ' ' then 
+        if fcb(17) = 'X' then 
+            xfcb = true;
+        else do;
+            call print$buf (.(
+              'Invalid Parameter$'));
+            call terminate;
+            end;
+
+    i = 0;
+      do while fcb(i:=i+1) = '?';
+      ;
+      end;
+    if i > 11 then
+      if not xfcb then 
+        do;
+        call print$buf (.(
+          'Confirm delete all user files (Y/N)?','$'));
+        response = read$console;
+        if not ((response = 'y') or
+              (response = 'Y'))
+        then call terminate;
+        end;
+    call parse;
+    if (code:=delete(.fcb)) <> successful then do;
+        if code = 0 then 
+            call print$buf (.(cr,lf,
+            'No file','$'));
+        else if code < 3 then 
+            call error(code);            /* fatal errors */
+        else 
+            call single$file;       /* single file error */
+        end;
+    call terminate;
+  end;
+
+end erase;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/eraq.plm

@@ -0,0 +1,411 @@
+$ TITLE('MP/M II --- ERAQ 2.0')
+eraseq:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '1',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       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;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) 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 (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure byte;
+      return mon2 (18,0);
+    end search$next;
+
+  delete$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (19,fcb$address);
+    end delete$file;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure;
+      call mon1 (45,0ffh);	
+    end return$errors;
+
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  declare xfcb     byte initial(0);
+  declare successful lit '0FFh';
+
+  declare dir$entries (128) structure (
+     file (12) byte );
+
+  declare dir$entry$adr address;
+  declare dir$entry based dir$entry$adr (1) byte;
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    call printchar(' ');
+    if code=1 then 
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+    if code=2 then 
+        call print$buf(.(cr,lf,'Drive $'));
+    if code = 3 or code = 2 then
+        call print$buf(.('Read Only$'));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code < 3 then 
+        call terminate;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to delete fcb at fcb$address
+            return error code if unsuccessful */
+  delete:
+    procedure(fcb$address) byte;
+    declare
+       fcb$address address,
+       fcbv based  fcb$address (32) byte,
+       error$code  address,
+       code        byte;
+       
+    if xfcb then 
+        fcbv(5) = fcbv(5) or 80h;
+    call setdma(.fcb16);                   /* password */
+    fcbv(0) = fcb(0);                      /* drive */
+    error$code = delete$file(fcb$address);
+    fcbv(5) = fcbv(5) and 7fh;             /* reset xfcb bit */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if (code=1) or (code=2) then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end delete;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then
+            go to exit;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error on deleting a file */
+    file$err: procedure(code);
+        declare code byte;
+
+        call crlf;
+        call print$buf(.('Not erased, $'));
+        call error(code);
+        call crlf;
+        end file$err;
+
+
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+declare (i,j,k,code,response,user,dcnt) byte;
+declare ver address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    if fcb(17) <> ' ' then 
+        if fcb(17) = 'X' then 
+            xfcb = true;
+        else do;
+            call print$buf (.(
+              'Invalid Parameter$'));
+            call terminate;
+            end;
+
+    if len0 <> 0 then do;
+      parse$fn.buff$adr = .tbuff(1);
+      parse$fn.fcb$adr = .fcb;
+      call parse;
+      end;
+    if fcb(0) = 0 then
+      fcb(0) = low (mon2 (25,0)) + 1;
+    i = -1;
+    user = get$user$code;
+    call return$errors;
+    dcnt = search$first (.fcb);
+    do while dcnt <> 0ffh;
+      dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
+      if dir$entry(0) = user then
+      do;
+        if (i:=i+1) = 128 then
+        do;
+          call print$buf (.(
+            'Too many directory entries for query.','$'));
+          call terminate;
+        end;
+        call move (12,.dir$entry(1),.dir$entries(i));
+      end;
+      dcnt = search$next;
+    end;
+    if i = -1 then
+    do;
+      call print$buf (.(
+        'No file','$'));
+    end;
+    else
+    do j = 0 to i;
+      call printchar ('A'+fcb(0)-1);
+      call printchar (':');
+      call printchar (' ');
+      do k = 0 to 10;
+        if k = 8
+          then call printchar ('.');
+        call printchar (dir$entries(j).file(k));
+      end;
+      call printchar (' ');
+      call printchar ('?');
+      response = read$console;
+      call printchar (0dh);
+      call printchar (0ah);
+      if (response = 'y') or
+         (response = 'Y') then
+      do;
+        call move (12,.dir$entries(j),.fcb(1));
+        if (code:=delete(.fcb)) <> successful then do;
+            if code < 3 then 
+                call error(code);            /* fatal errors */
+            else if code = 7 then do;
+                call file$err(code);
+                call getpasswd;
+                code = delete(.fcb);
+                end;
+            if code <> successful then 
+                call file$err(code);
+            call crlf;
+            end;
+      end;
+    end;
+    call terminate;
+  end;
+
+end eraseq;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla1.sub

@@ -0,0 +1,73 @@
+pip a:=dir.plm[g8]
+seteof dir.plm
+isx
+plm80 dir.plm nolist debug
+era dir.plm
+link dir.obj,x0100,plm80.lib to dir1.mod
+locate dir1.mod code(0100H) stacksize(100)
+era dir1.mod
+objhex dir1 to dir1.hex
+link dir.obj,x0200,plm80.lib to dir2.mod
+locate dir2.mod code(0200H) stacksize(100)
+era dir2.mod
+objhex dir2 to dir2.hex
+era dir2
+cpm
+objcpm dir1
+era dir*.
+era dir1.com
+pip dir.hex=dir1.hex,dir2.hex
+era dir1.hex
+era dir2.hex
+zero
+genmod dir.hex xdir.prl 
+era *.hex
+pip a:=ed.plm[g8]
+seteof ed.plm
+isx
+plm80 ed.plm nolist debug
+era ed.plm
+link ed.obj,x0100,plm80.lib to ed1.mod
+locate ed1.mod code(0100H) stacksize(100)
+era ed1.mod
+objhex ed1 to ed1.hex
+link ed.obj,x0200,plm80.lib to ed2.mod
+locate ed2.mod code(0200H) stacksize(100)
+era ed2.mod
+objhex ed2 to ed2.hex
+era ed2
+cpm
+objcpm ed1
+era ed1.com
+pip ed.hex=ed1.hex,ed2.hex
+era ed1.hex
+era ed2.hex
+zero
+genmod ed.hex xed.prl $$1000
+era *.hex
+pip a:=era.plm[g8]
+seteof era.plm
+isx
+plm80 era.plm nolist debug
+era era.plm
+link era.obj,x0100,plm80.lib to era1.mod
+locate era1.mod code(0100H) stacksize(100)
+era era1.mod
+objhex era1 to era1.hex
+link era.obj,x0200,plm80.lib to era2.mod
+locate era2.mod code(0200H) stacksize(100)
+era era2.mod
+objhex era2 to era2.hex
+era era2
+cpm
+objcpm era1
+era era*.
+era era1.com
+pip era.hex=era1.hex,era2.hex
+era era1.hex
+era era2.hex
+zero
+genmod era.hex xera.prl 
+era *.hex
+sub prla2
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla2.sub

@@ -0,0 +1,71 @@
+pip a:=eraq.plm[g8]
+seteof eraq.plm
+isx
+plm80 eraq.plm nolist debug
+era eraq.plm
+link eraq.obj,x0100,plm80.lib to eraq1.mod
+locate eraq1.mod code(0100H) stacksize(100)
+era eraq1.mod
+objhex eraq1 to eraq1.hex
+link eraq.obj,x0200,plm80.lib to eraq2.mod
+locate eraq2.mod code(0200H) stacksize(100)
+era eraq2.mod
+objhex eraq2 to eraq2.hex
+era eraq2
+cpm
+objcpm eraq1
+era eraq1.com
+pip eraq.hex=eraq1.hex,eraq2.hex
+era eraq1.hex
+era eraq2.hex
+zero
+genmod eraq.hex xeraq.prl 
+era *.hex
+pip a:=ren.plm[g8]
+seteof ren.plm
+isx
+plm80 ren.plm nolist debug
+era ren.plm
+link ren.obj,x0100,plm80.lib to ren1.mod
+locate ren1.mod code(0100H) stacksize(100)
+era ren1.mod
+objhex ren1 to ren1.hex
+link ren.obj,x0200,plm80.lib to ren2.mod
+locate ren2.mod code(0200H) stacksize(100)
+era ren2.mod
+objhex ren2 to ren2.hex
+era ren2
+cpm
+objcpm ren1
+era ren1.com
+pip ren.hex=ren1.hex,ren2.hex
+era ren1.hex
+era ren2.hex
+zero
+genmod ren.hex xren.prl 
+era *.hex
+pip a:=set.plm[g8]
+seteof set.plm
+isx
+plm80 set.plm nolist debug
+era set.plm
+link set.obj,x0100,plm80.lib to set1.mod
+locate set1.mod code(0100H) stacksize(100)
+era set1.mod
+objhex set1 to set1.hex
+link set.obj,x0200,plm80.lib to set2.mod
+locate set2.mod code(0200H) stacksize(100)
+era set2.mod
+objhex set2 to set2.hex
+era set2
+cpm
+objcpm set1
+era set1.com
+pip set.hex=set1.hex,set2.hex
+era set1.hex
+era set2.hex
+zero
+genmod set.hex xset.prl 
+era *.hex
+sub prla3
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla3.sub

@@ -0,0 +1,70 @@
+pip a:=show.plm[g8]
+seteof show.plm
+isx
+plm80 show.plm nolist debug
+era show.plm
+link show.obj,x0100,plm80.lib to show1.mod
+locate show1.mod code(0100H) stacksize(100)
+era show1.mod
+objhex show1 to show1.hex
+link show.obj,x0200,plm80.lib to show2.mod
+locate show2.mod code(0200H) stacksize(100)
+era show2.mod
+objhex show2 to show2.hex
+era show2
+cpm
+objcpm show1
+era show1.com
+pip show.hex=show1.hex,show2.hex
+era show1.hex
+era show2.hex
+zero
+genmod show.hex xshow.prl 
+era *.hex
+pip a:=stat.plm[g8]
+seteof stat.plm
+isx
+plm80 stat.plm nolist debug
+era stat.plm
+link stat.obj,x0100,plm80.lib to stat1.mod
+locate stat1.mod code(0100H) stacksize(100)
+era stat1.mod
+objhex stat1 to stat1.hex
+link stat.obj,x0200,plm80.lib to stat2.mod
+locate stat2.mod code(0200H) stacksize(100)
+era stat2.mod
+objhex stat2 to stat2.hex
+era stat2
+cpm
+objcpm stat1
+era stat1.com
+pip stat.hex=stat1.hex,stat2.hex
+era stat1.hex
+era stat2.hex
+zero
+genmod stat.hex xstat.prl 
+era *.hex
+pip a:=type.plm[g8]
+seteof type.plm
+isx
+plm80 type.plm nolist debug
+era type.plm
+link type.obj,x0100,plm80.lib to type1.mod
+locate type1.mod code(0100H) stacksize(100)
+era type1.mod
+objhex type1 to type1.hex
+link type.obj,x0200,plm80.lib to type2.mod
+locate type2.mod code(0200H) stacksize(100)
+era type2.mod
+objhex type2 to type2.hex
+era type2
+cpm
+objcpm type1
+era type1.com
+pip type.hex=type1.hex,type2.hex
+era type1.hex
+era type2.hex
+zero
+genmod type.hex xtype.prl 
+era *.hex
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/ren.plm

@@ -0,0 +1,514 @@
+$ TITLE('MP/M II --- REN 2.0')
+ren:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '0FFh',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+$include (proces.lit)
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       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;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) 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 (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  printchar:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end printchar;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure byte;
+      return mon2 (18,0);
+    end search$next;
+
+  delete$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (19,fcb$address);
+    end delete$file;
+
+  rename$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (23,fcb$address);
+    end rename$file;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure(mode);
+    declare mode byte;
+      call mon1 (45,mode);	
+    end return$errors;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure address;
+    return mon3(152,.parse$fn);
+    end parse;
+
+  declare
+    pdadr      addr,
+    pd         based pdadr process$descriptor;
+
+  getpd: procedure;
+
+    pdadr = mon3(156,0);
+    end getpd;
+
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  /* Note: there are three fcbs used by
+     this program:
+
+         1) new$fcb: the new file name
+            (this can be a wildcard if it
+            has the same pattern of question
+            marks as the old file name)
+            Any question marks are replaced
+            with the corresponding filename
+            character in the old$fcb before
+            doing the rename function.
+
+         2) cur$fcb: the file to be renamed
+            specified in the rename command.
+            (any question marks must correspond
+            to question marks in new$fcb).
+
+         3) old$fcb: a fcb in the directory
+            matching the cur$fcb and used in
+            the bdos rename function.  This
+            cannot contain any question marks.
+  */         
+
+  declare successful lit '0FFh';
+  declare failed       (*) byte data(cr,lf,'Not renamed: $'),
+          read$only    (*) byte data(cr,lf,'Drive Read Only$'),
+          bad$wildcard (*) byte data('Invalid Wildcard$');
+  declare passwd (8) byte;
+  declare 
+      new$fcb$adr address,       /* new name */
+      new$fcb based  new$fcb$adr (32) byte;
+  declare cur$fcb (33) byte;      /* current fcb (old name) */
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    if code = 0 then do;  
+        call print$buf(.('No such file to rename$'));
+        call terminate;
+        end;
+    if code=1 then do;
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+        call terminate;
+        end;
+    if code=2 then do;
+        call print$buf(.read$only);
+        call terminate;
+        end;
+    if code = 3 then
+        call print$buf(.read$only(8));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code = 8 then      
+        call print$buf(.('already exists$'));
+    if code = 9 then do;
+        call print$buf(.bad$wildcard);
+        call terminate;
+        end;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                 /* print file name */
+print$file: procedure(fcbp);
+        declare k byte;
+        declare typ lit '9';        /* file type */
+        declare fnam lit '11';        /* file type */
+        declare
+            fcbp   addr,
+            fcbv   based fcbp (32) byte;
+
+            do k = 1 to fnam;
+            if k = typ then 
+	       call printchar('.');
+            call printchar(fcbv(k) and 7fh);
+            end;
+        end print$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to rename fcb at old$fcb$adr to name at new$fcb$adr 
+            return error code if unsuccessful */
+  rename:
+    procedure(old$fcb$adr) byte;
+    declare
+       old$fcb$adr address,
+       old$fcb based  old$fcb$adr (32) byte,
+       error$code  address,
+       code        byte;
+       
+    call move (16,new$fcb$adr,old$fcb$adr+16);
+    call setdma(.passwd);                   /* password    */
+    call return$errors(0FFh);        /* return bdos errors */
+    error$code = rename$file (old$fcb$adr);
+    call return$errors(0);           /* normal error mode  */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if code < 3 then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end rename;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc(c) byte;
+    dcl c byte;
+
+    if c >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.passwd,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase(conin)) >= ' ' then 
+            passwd(i)=c;
+        if c = cr then do;
+            call crlf;
+            go to exit;
+            end;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                passwd(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = ctrlc then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* check for wildcard in rename command */
+wildcard:   proc byte;
+    dcl (i,wild) byte;
+
+    wild = false;
+        do i=1 to 11;
+        if cur$fcb(i) = '?' then
+            if new$fcb(i) <> '?' then do;
+                call print$buf(.failed);
+                call print$buf(.bad$wildcard);
+                call terminate;
+                end;
+            else
+                wild = true;
+        end;
+    return wild;
+    end wildcard;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* set up new name for rename function */
+set$new$fcb:   proc(old$fcb$adr);
+    dcl old$fcb$adr address,
+        old$fcb based old$fcb$adr (32) byte;
+    dcl i byte;
+
+    old$fcb(0) = cur$fcb(0);    /* set up drive */
+        do i=1 to 11;
+        if cur$fcb(i) = '?' then 
+            new$fcb(i) = old$fcb(i);
+        end;
+    end set$new$fcb;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* try deleting files one at a time */
+  single$file:
+    procedure;
+    declare (code,dcnt,savsearchl) byte;
+    declare (old$fcb$adr,savdcnt,savsearcha) addr;
+    declare old$fcb based old$fcb$adr (32) byte;
+ 
+    file$err: procedure(fcba);
+        dcl fcba address;
+        call print$buf(.failed);
+        call print$file(fcba);
+        call printchar(' ');
+        call error(code);
+        end file$err;
+
+    call setdma(.tbuff);
+    if (dcnt:=search$first(.cur$fcb)) = 0ffh then
+        call error(0);
+
+        do while dcnt <> 0ffh;
+        old$fcb$adr = shl(dcnt,5) + .tbuff;
+        savdcnt = pd.dcnt;
+        savsearcha = pd.searcha;
+        savsearchl = pd.searchl;
+        call set$new$fcb(old$fcb$adr);
+        if (code:=rename(old$fcb$adr)) = 8 then do;
+            call file$err(new$fcb$adr);
+            call print$buf(.(', delete (Y/N)?$'));
+            if ucase(read$console) = 'Y' then do;
+                call delete$file(new$fcb$adr);
+                code = rename(old$fcb$adr);
+                end;
+            else
+                go to next;
+            end;
+        if code = 7 then do;
+            call file$err(old$fcb$adr);
+            call getpasswd;
+            code = rename(old$fcb$adr);
+            end;
+        if code <> successful then 
+            call file$err(old$fcb$adr);
+        else do;
+            call crlf;
+            call print$file(new$fcb$adr);
+            call printchar('=');
+            call print$file(old$fcb$adr);
+            end;
+next:
+        call setdma(.tbuff);
+        pd.dcnt = savdcnt;
+        pd.searcha = savsearcha;
+        pd.searchl = savsearchl;
+        dcnt = search$next;
+        end;
+    end single$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* invalid rename command */
+bad$entry:   proc;
+
+    call print$buf(.failed);
+    call print$buf(.('Invalid File','$'));
+    call terminate;
+    end bad$entry;
+
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+declare ver address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then 
+        call print$buf (.(
+          'Requires MP/M 2.0','$'));
+    else do;
+        call getpd;
+        parse$fn.buff$adr = .tbuff(1);
+        new$fcb$adr, parse$fn.fcb$adr = .fcb;
+        if (parse$fn.fcb$adr:=parse) <> 0FFFFh then do; /* old file */
+            parse$fn.buff$adr = parse$fn.fcb$adr + 1; /* skip delim */
+            parse$fn.fcb$adr  = .cur$fcb;
+            parse$fn.fcb$adr = parse;                /* new file */
+            call move (8,.cur$fcb+16,.passwd);       /* password */
+            end;
+        if parse$fn.fcb$adr = 0ffffh then 
+            call bad$entry;
+        if fcb(0) <> 0 then
+            if cur$fcb(0) <> 0 then do;
+                if fcb(0) <> cur$fcb(0) then
+                    call bad$entry;
+                end;
+            else
+                cur$fcb(0) = new$fcb(0);        /* set drive */
+        if wildcard then
+            call singlefile;
+        else if rename(.cur$fcb) <> successful then 
+            call singlefile;
+        end;
+    call mon1(0,0);
+
+end ren;
+
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/type.plm

@@ -0,0 +1,334 @@
+$ TITLE('MP/M II --- TYPE 2.0')
+type:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '0FFh',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       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;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) 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 (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  printchar:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buff$adr);
+      declare buff$adr address;
+      call mon1 (9,buff$adr);
+    end print$buf;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  open$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+    return mon3 (15,fcb$address);
+    end open$file;
+
+  close$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (16,fcb$address);
+    end close$file;
+
+  read$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (20,fcb$address);
+    end read$record;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure(mode);
+    declare mode byte;
+      call mon1 (45,mode);	
+    end return$errors;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then
+            go to exit;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+  declare (eod,i,char) byte;
+  declare control$z literally '1AH';
+
+  /*
+    Main Program
+  */
+
+declare (cnt,tcnt) byte;
+declare (ver, error$code)  address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    tcnt,
+    cnt = 0;
+    if fcb16(1) = 'P' then
+      do;
+      if fcb16(2) = ' ' or fcb16(2) = 'A' then   
+        cnt = 24;
+      else
+        cnt = (fcb16(2)-'0')*10
+           +(fcb16(3)-'0');
+      end;
+    if len0 <> 0 then do;
+      parse$fn.buff$adr = .tbuff(1);
+      parse$fn.fcb$adr = .fcb;
+      call parse;                       /* get password */
+      end;
+    call return$errors(0FEh);           /* return after error message */
+    call setdma(.fcb16);                /* set dma to password */
+    fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
+    error$code = open$file (.fcb);
+    if low(error$code) = 0FFh then 
+      if high(error$code) = 7 then do;
+         call getpasswd;
+         call crlf;
+         call setdma(.fcb16);                /* set dma to password */
+         fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
+         error$code = open$file(.fcb);
+         end;
+    if low(error$code) <> 0FFH then
+    do;
+      call return$errors(0);        /* reset error mode */
+      call setdma(.tbuff);
+      fcb(32) = 0;
+      eod = 0;
+      do while (not eod) and (read$record (.fcb) = 0);
+        do i = 0 to 127;
+          if (char := tbuff(i)) = control$z
+            then eod = true;
+          if not eod then
+          do;
+            if check$con$stat then
+            do;
+              i = read$console;
+              call terminate;
+            end;
+            if cnt <> 0 then
+            do;
+              if char = 0ah then
+              do;
+                if (tcnt:=tcnt+1) = cnt then
+                do;
+                  tcnt = read$console;
+                  tcnt = 0;
+                end;
+              end;
+            end;
+            call printchar (char);
+          end;
+        end;
+      end;
+    /*
+      call close (.fcb);
+      *** Warning ***
+      If this call is left in, the file can be destroyed.
+    */
+    end;
+    else if high(error$code) = 0 then
+      call print$buf (.('No file.','$'));
+    call terminate;
+  end;
+
+end type;
+
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/abort.plm

@@ -0,0 +1,100 @@
+$title ('MP/M II  V2.0  Abort a Program')
+abort:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+  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;
+
+  declare fcb (1) byte external;
+  declare fcb16 (1) byte external;
+  declare tbuff (1) byte external;
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  print$console$buffer:
+    procedure (buff$adr);
+      declare buff$adr address;
+      call mon1 (9,buff$adr);
+    end print$console$buffer;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  console$number:
+    procedure byte;
+      return mon2 (153,0);
+    end console$number;
+
+  abort$process:
+    procedure (abort$pb) byte;
+      declare abort$pb address;
+      return mon2 (157,abort$pb);
+    end abort$process;
+
+  declare abort$pb structure (
+    pdadr address,
+    param address,
+    pname (8) byte,
+    console byte) initial (
+    0,00ffh,'        ',0);
+
+  /*
+    Main Program
+  */
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    if fcb16(1) = ' ' then
+    do;
+      abort$pb.console = console$number;
+    end;
+    else
+    do;
+      if (fcb16(1):=fcb16(1)-'0') > 9 then
+      do;
+        fcb16(1) = fcb16(1) + '0' - 'A' + 10;
+      end;
+      abort$pb.console = fcb16(1);
+    end;
+    call move (8,.fcb(1),.abort$pb.pname);
+    if abort$process (.abort$pb) = 0ffh then
+    do;
+      call print$console$buffer (.(
+        'Abort failed.','$'));
+    end;
+    call terminate;
+  end;
+
+end abort;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/cns.plm

@@ -0,0 +1,74 @@
+$title ('MP/M II V2.0  Console Identification')
+console:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+  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;
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  print$console$buffer:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$console$buffer;
+
+  /**************************************
+   *                                    *
+   *       X D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  get$console$number:
+    procedure byte;
+      return mon2 (153,0);
+    end get$console$number;
+
+
+  /*
+    Main Program
+  */
+
+  declare cnsmsg (*) byte initial
+    (0dh,0ah,'Console = x','$');
+
+start:
+  do;
+    cnsmsg(12) = get$console$number + '0';
+    call print$console$buffer (.cnsmsg);
+    call terminate;
+  end;
+
+end console;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/drst.plm

@@ -0,0 +1,93 @@
+$title ('MP/M II  V2.0  Disk System Reset')
+disk$reset:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+  mon1:
+    procedure (func,info) external;
+      declare func byte;
+      declare info address;
+    end mon1;
+
+  declare tbuff (1) byte external;
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  reset$drives:
+    procedure (drive$vector);
+      declare drive$vector address;
+      call mon1 (37,drive$vector);
+    end reset$drives;
+
+  /**************************************
+   *                                    *
+   *       X D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare mask (16) address data (
+    0000000000000001b,
+    0000000000000010b,
+    0000000000000100b,
+    0000000000001000b,
+    0000000000010000b,
+    0000000000100000b,
+    0000000001000000b,
+    0000000010000000b,
+    0000000100000000b,
+    0000001000000000b,
+    0000010000000000b,
+    0000100000000000b,
+    0001000000000000b,
+    0010000000000000b,
+    0100000000000000b,
+    1000000000000000b );
+
+  declare drive$mask address initial (0);
+  declare i byte;
+
+  /*
+    Main Program
+  */
+
+start:
+  do;
+    i = 0;
+    if tbuff(0) = 0 then
+    do;
+      drive$mask = 0ffffh;
+    end;
+    else
+    do while (i:=i+1) <= tbuff(0);
+      if (tbuff(i) >= 'A') and (tbuff(i) <= 'P') then
+      do;
+        drive$mask = drive$mask or mask(tbuff(i)-'A');
+      end;
+    end;
+    call reset$drives (drive$mask);
+    call terminate;
+  end;
+
+end disk$reset;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/dump.asm

@@ -0,0 +1,242 @@
+; NOTE:
+;	In order to execute this sample DUMP utility you
+; must assemble EXTRN.ASM and then link DUMP and EXTRN to
+; create the DUMP.PRL file.  This is shown below:
+;
+;	0A>RMAC dump
+;	0A>RMAC extrn
+;	0A>LINK dump,extrn[op]
+;
+	title	'File Dump Program'
+	cseg
+;	File dump program, reads an input file and
+;	  prints in hex
+;
+;	Copyright (C) 1975, 1976, 1977, 1978, 1979, 1980, 1981
+;	Digital Research
+;	Box 579, Pacific Grove
+;	California, 93950
+;
+;	Externals
+	extrn	bdos
+	extrn	fcb
+	extrn	buff
+;
+cons	equ	1	;read console
+typef	equ	2	;type function
+printf	equ	9	;buffer print entry
+brkf	equ	11	;break key function
+openf	equ	15	;file open
+readf	equ	20	;read function
+;
+;	non graphic characters
+cr	equ	0dh	;carriage return
+lf	equ	0ah	;line feed
+;
+;	file control block definitions
+;fcbdn	equ	fcb+0	;disk name
+;fcbfn	equ	fcb+1	;file name
+;fcbft	equ	fcb+9	;disk file type (3 characters)
+;fcbrl	equ	fcb+12	;file's current reel number
+;fcbrc	equ	fcb+15	;file's record count (0 to 128)
+;fcbcr	equ	fcb+32	;current (next) record number
+;fcbln	equ	fcb+33	;fcb length
+;
+dump:
+;	set up stack
+	lxi	h,0
+	dad	sp
+;	entry stack pointer in hl from the ccp
+	shld	oldsp
+;	set sp to local stack area (restored at finis)
+	lxi	sp,stktop
+;	print sign on message
+	lxi	d,signon
+	call	prntmsg	
+;	read and print successive buffers
+	call	setup	;set up input file
+	cpi	255	;255 if file not present
+	jnz	openok	;skip if open is ok
+;
+;	file not there, give error message and return
+	lxi	d,opnmsg
+	call	prntmsg
+	jmp	finis	;to return
+;
+openok:	;open operation ok, set buffer index to end
+	mvi	a,80h
+	sta	ibp	;set buffer pointer to 80h
+;	hl contains next address to print
+	lxi	h,0	;start with 0000
+;
+gloop:
+	push	h	;save line position
+	call	gnb
+	pop	h	;recall line position
+	jc	finis	;carry set by gnb if end file
+	mov	b,a
+;	print hex values
+;	check for line fold
+	mov	a,l
+	ani	0fh	;check low 4 bits
+	jnz	nonum
+;	print line number
+	call	crlf
+;
+;	check for break key
+	call	break
+;	accum lsb = 1 if character ready
+	rrc		;into carry
+	jc	purge	;don't print any more
+;
+	mov	a,h
+	call	phex
+	mov	a,l
+	call	phex
+nonum:
+	inx	h	;to next line number
+	mvi	a,' '
+	call	pchar
+	mov	a,b
+	call	phex
+	jmp	gloop
+;
+purge:
+	mvi	c,cons
+	call	bdos
+finis:
+;	end of dump, return to ccp
+;	(note that a jmp to 0000h reboots)
+	call	crlf
+	lhld	oldsp
+	sphl
+;	stack pointer contains ccp's stack location
+	ret		;to the ccp
+;
+;
+;	subroutines
+;
+break:	;check break key (actually any key will do)
+	push h! push d! push b; environment saved
+	mvi	c,brkf
+	call	bdos
+	pop b! pop d! pop h; environment restored
+	ret
+;
+pchar:	;print a character
+	push h! push d! push b; saved
+	mvi	c,typef
+	mov	e,a
+	call	bdos
+	pop b! pop d! pop h; restored
+	ret
+;
+crlf:
+	mvi	a,cr
+	call	pchar
+	mvi	a,lf
+	call	pchar
+	ret
+;
+;
+pnib:	;print nibble in reg a
+	ani	0fh	;low 4 bits
+	cpi	10
+	jnc	p10
+;	less than or equal to 9
+	adi	'0'
+	jmp	prn
+;
+;	greater or equal to 10
+p10:	adi	'A' - 10
+prn:	call	pchar
+	ret
+;
+phex:	;print hex char in reg a
+	push	psw
+	rrc
+	rrc
+	rrc
+	rrc
+	call	pnib	;print nibble
+	pop	psw
+	call	pnib
+	ret
+;
+prntmsg:	;print message
+;	d,e addresses message ending with "$"
+	mvi	c,printf	;print buffer function
+	jmp	bdos
+;	ret
+;
+;
+gnb:	;get next byte
+	lda	ibp
+	cpi	80h
+	jnz	g0
+;	read another buffer
+;
+;
+	call	diskr
+	ora	a	;zero value if read ok
+	jz	g0	;for another byte
+;	end of data, return with carry set for eof
+	stc
+	ret
+;
+g0:	;read the byte at buff+reg a
+	mov	e,a	;ls byte of buffer index
+	mvi	d,0	;double precision index to de
+	inr	a	;index=index+1
+	sta	ibp	;back to memory
+;	pointer is incremented
+;	save the current file address
+	lxi	h,buff
+	dad	d
+;	absolute character address is in hl
+	mov	a,m
+;	byte is in the accumulator
+	ora	a	;reset carry bit
+	ret
+;
+setup:	;set up file 
+;	open the file for input
+	xra	a	;zero to accum
+	sta	fcb+32	;clear current record
+;
+;	open the file in R/O mode
+	lxi	h,fcb+6
+	mov	a,m
+	ori	80h
+	mov	m,a	;set f6' on
+	lxi	d,fcb
+	mvi	c,openf
+	call	bdos
+;	255 in accum if open error
+	ret
+;
+diskr:	;read disk file record
+	push h! push d! push b
+	lxi	d,fcb
+	mvi	c,readf
+	call	bdos
+	pop b! pop d! pop h
+	ret
+;
+;	fixed message area
+signon:
+	db	'MP/M II V2.0  File Dump'
+	db	cr,lf,'$'
+opnmsg:
+	db	cr,lf,'No input file present on disk$'
+
+;	variable area
+ibp:	ds	2	;input buffer pointer
+oldsp:	ds	2	;entry sp value from ccp
+;
+;	stack area
+	ds	64	;reserve 32 level stack
+stktop:
+;
+	end	dump
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/extrn.asm

@@ -0,0 +1,14 @@
+	title	'External Reference Module'
+
+bdos	equ	0005h
+fcb	equ	005ch
+tfcb	equ	006ch
+buff	equ	0080h
+
+	public	bdos
+	public	fcb
+	public	tfcb
+	public	buff
+
+	end
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/mschd.plm

@@ -0,0 +1,436 @@
+$title('MP/M II V2.0 Scheduler Transient Program')
+sched:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+$include (proces.lit)
+$include (queue.lit)
+$include (xdos.lit)
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  declare fcb(1) byte external;
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data (
+    0c3h,
+    .start-3);
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare xdos literally 'mon2';
+  declare xdosa literally 'mon2a';
+
+  print$buffer:
+    procedure (buffadr);
+      declare buffadr address;
+      call mon1 (9,buffadr);
+    end print$buffer;
+
+  system$reset:
+    procedure;
+      call mon1 (0,0);
+    end system$reset;
+
+  declare sched$uqcb userqcb
+    initial (0,.new$entry,'Sched   ');
+
+  declare ret address;  /* Warning: this is global */
+
+  declare msg$adr address initial (.default$msg);
+  declare default$msg (*) byte data (
+    'Illegal time/date specification','$');
+
+
+/*****************************************************
+
+          Time & Date ASCII Conversion Code
+
+ *****************************************************/
+
+declare tod$adr address;
+declare tod based tod$adr structure (
+  opcode byte,
+  date address,
+  hrs byte,
+  min byte,
+  sec byte,
+  ASCII (21) byte );
+
+declare string$adr address;
+declare string based string$adr (1) byte;
+declare index byte;
+
+declare lit literally 'literally',
+  word lit 'address';
+
+emitchar: procedure(c);
+    declare c byte;
+    string(index := index + 1) = c;
+    end emitchar;
+
+emitn: procedure(a);
+    declare a address;
+    declare c based a byte;
+    do while c <> '$';
+      string(index := index + 1) = c;
+      a = a + 1;
+    end;
+    end emitn;
+
+
+emit$bcd: procedure(b);
+    declare b byte;
+    call emitchar('0'+b);
+    end emit$bcd;
+
+emit$bcd$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(shr(b,4));
+    call emit$bcd(b and 0fh);
+    end emit$bcd$pair;
+
+emit$colon: procedure(b);
+    declare b byte;
+    call emit$bcd$pair(b);
+    call emitchar(':');
+    end emit$colon;
+
+emit$bin$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(b/10);
+    call emit$bcd(b mod 10);
+    end emit$bin$pair;
+
+emit$slant: procedure(b);
+    declare b byte;
+    call emit$bin$pair(b);
+    call emitchar('/');
+    end emit$slant;
+
+declare chr byte;
+
+gnc: procedure;
+    /* get next command byte */
+    if chr = 0 then return;
+    if index = 20 then
+    do;
+      chr = 0;
+      return;
+    end;
+    chr = string(index := index + 1);
+    end gnc;
+
+deblank: procedure;
+        do while chr = ' ';
+        call gnc;
+        end;
+    end deblank;
+
+numeric: procedure byte;
+    /* test for numeric */
+    return (chr - '0') < 10;
+    end numeric;
+
+scan$numeric: procedure(lb,ub) byte;
+    declare (lb,ub) byte;
+    declare b byte;
+    b = 0;
+    call deblank;
+    if not numeric then go to error;
+        do while numeric;
+        if (b and 1110$0000b) <> 0 then go to error;
+        b = shl(b,3) + shl(b,1); /* b = b * 10 */
+        if carry then go to error;
+        b = b + (chr - '0');
+        if carry then go to error;
+        call gnc;
+        end;
+    if (b < lb) or (b > ub) then go to error;
+    return b;
+    end scan$numeric;
+
+scan$delimiter: procedure(d,lb,ub) byte;
+    declare (d,lb,ub) byte;
+    call deblank;
+    if chr <> d then go to error;
+    call gnc;
+    return scan$numeric(lb,ub);
+    end scan$delimiter;
+
+declare
+    base$year lit '78',   /* base year for computations */
+    base$day  lit '0',    /* starting day for base$year 0..6 */
+    month$size (*) byte data
+    /* jan feb mar apr may jun jul aug sep oct nov dec */
+    (   31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
+    month$days (*) word data
+    /* jan feb mar apr may jun jul aug sep oct nov dec */
+    (  000,031,059,090,120,151,181,212,243,273,304,334);
+
+leap$days: procedure(y,m) byte;
+    declare (y,m) byte;
+    /* compute days accumulated by leap years */
+    declare yp byte;
+    yp = shr(y,2); /* yp = y/4 */
+    if (y and 11b) = 0 and month$days(m) < 59 then
+        /* y not 00, y mod 4 = 0, before march, so not leap yr */
+        return yp - 1;
+    /* otherwise, yp is the number of accumulated leap days */
+    return yp;
+    end leap$days;
+
+declare word$value word;
+
+get$next$digit: procedure byte;
+    /* get next lsd from word$value */
+    declare lsd byte;
+    lsd = word$value mod 10;
+    word$value = word$value / 10;
+    return lsd;
+    end get$next$digit;
+
+bcd:
+  procedure (val) byte;
+    declare val byte;
+    return shl((val/10),4) + val mod 10;
+  end bcd;
+
+declare (month, day, year, hrs, min, sec) byte;
+
+set$date$time: procedure;
+    declare
+        (i, leap$flag) byte; /* temporaries */
+    month = scan$numeric(1,12) - 1;
+    /* may be feb 29 */
+    if (leap$flag := month = 1) then i = 29;
+        else i = month$size(month);
+    day   = scan$delimiter('/',1,i);
+    year  = scan$delimiter('/',base$year,99);
+    /* ensure that feb 29 is in a leap year */
+    if leap$flag and day = 29 and (year and 11b) <> 0 then
+        /* feb 29 of non-leap year */ go to error;
+    /* compute total days */
+     tod.date = month$days(month)
+                + 365 * (year - base$year)
+                + day
+                - leap$days(base$year,0)
+                + leap$days(year,month);
+
+    tod.hrs   = bcd (scan$numeric(0,23));
+    tod.min   = bcd (scan$delimiter(':',0,59));
+    if tod.opcode = 2 then
+    /* date, hours and minutes only */
+    do;
+      if chr = ':'
+        then i = scan$delimiter (':',0,59);
+      tod.sec = 0;
+    end;
+    /* include seconds */
+    else tod.sec   = bcd (scan$delimiter(':',0,59));
+
+    end set$date$time;
+
+bcd$pair: procedure(a,b) byte;
+    declare (a,b) byte;
+    return shl(a,4) or b;
+    end bcd$pair;
+
+
+compute$year: procedure;
+    /* compute year from number of days in word$value */
+    declare year$length word;
+    year = base$year;
+        do forever;
+        year$length = 365;
+        if (year and 11b) = 0 then /* leap year */
+            year$length = 366;
+        if word$value <= year$length then
+            return;
+        word$value = word$value - year$length;
+        year = year + 1;
+        end;
+    end compute$year;
+
+declare
+    week$day  byte, /* day of week 0 ... 6 */
+    day$list (*) byte data
+    ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
+    leap$bias byte; /* bias for feb 29 */
+
+compute$month: procedure;
+    month = 12;
+        do while month > 0;
+        if (month := month - 1) < 2 then /* jan or feb */
+            leapbias = 0;
+        if month$days(month) + leap$bias < word$value then return;
+        end;
+    end compute$month;
+
+declare
+    date$test byte,    /* true if testing date */
+    test$value word;   /* sequential date value under test */
+
+get$date$time: procedure;
+    /* get date and time */
+    hrs = tod.hrs;
+    min = tod.min;
+    sec = tod.sec;
+    word$value = tod.date;
+    /* word$value contains total number of days */
+    week$day = (word$value + base$day - 1) mod 7;
+    call compute$year;
+    /* year has been set, word$value is remainder */
+    leap$bias = 0;
+    if (year and 11b) = 0 and word$value > 59 then
+        /* after feb 29 on leap year */ leap$bias = 1;
+    call compute$month;
+    day = word$value - (month$days(month) + leap$bias);
+    month = month + 1;
+    end get$date$time;
+
+emit$date$time: procedure;
+    call emitn(.day$list(shl(week$day,2)));
+    call emitchar(' ');
+    call emit$slant(month);
+    call emit$slant(day);
+    call emit$bin$pair(year);
+    call emitchar(' ');
+    call emit$colon(hrs);
+    call emit$colon(min);
+    call emit$bcd$pair(sec);
+    end emit$date$time;
+
+tod$ASCII:
+  procedure (parameter);
+    declare parameter address;
+
+    ret = 0;
+    tod$adr = parameter;
+    string$adr = .tod.ASCII;
+    if tod.opcode = 0 then
+    do;
+      call get$date$time;
+      index = -1;
+      call emit$date$time;
+    end;
+    else
+    do;
+      if (tod.opcode = 1) or
+         (tod.opcode = 2) then
+      do;
+        chr = string(index:=0);
+        call set$date$time;
+        ret = .string(index);
+      end;
+      else
+      do;
+        go to error;
+      end;
+    end;
+  end tod$ASCII;
+
+/********************************************************
+ ********************************************************/
+
+
+  declare new$entry structure (
+    date address,
+    hrs byte,
+    min byte,
+    cli$command (65) byte );
+
+  declare lcltod structure (
+    opcode byte,
+    date address,
+    hrs byte,
+    min byte,
+    sec byte,
+    ASCII (21) byte ) at (.fcb(31));
+
+  fill$entry:
+    procedure;
+
+      new$entry.cli$command(0) = shl (mon2 (25,0),4)
+                                    + mon2 (32,0ffh);
+      new$entry.cli$command(1) = mon2 (get$console$nmb,0);
+      lcltod.opcode = 2;
+      call tod$ASCII (.lcltod);
+      if ret <> 0ffffh then
+      do;
+        new$entry.cli$command(64) = 0dh;
+        ret = ret + 1;
+        call move (63-(ret-.lcltod.min),ret,
+                   .new$entry.cli$command(2));
+        new$entry.date = lcltod.date;
+        new$entry.hrs = lcltod.hrs;
+        new$entry.min = lcltod.min;
+      end;
+      else
+      do;
+        go to error;
+      end;
+    end fill$entry;
+
+
+  declare last$dseg$byte byte
+    initial (0);
+
+/*
+  sched:
+*/
+
+start:
+do;
+  if xdos (open$queue,.sched$uqcb) = 0ffh then
+  do;
+    msgadr = .('Resident portion of scheduler is not in memory','$');
+    go to error;
+  end;
+  call fill$entry;
+  if xdos (cond$write$queue,.sched$uqcb) = 0ffh then
+  do;
+    msg$adr = .('Scheduler queue is full','$');
+    go to error;
+  end;
+  call system$reset;
+end;
+
+error:
+do;
+  call print$buffer (msg$adr);
+  call system$reset;
+end;
+
+end sched;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/mscmn.plm

@@ -0,0 +1,500 @@
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  co:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end co;
+
+  print$buffer:
+    procedure (bufferadr);
+      declare bufferadr address;
+      call mon1 (9,bufferadr);
+    end print$buffer;
+
+  read$buffer:
+    procedure (bufferadr);
+      declare bufferadr address;
+      call mon1 (10,bufferadr);
+    end read$buffer;
+
+  crlf:
+    procedure;
+      call co (0DH);
+      call co (0AH);
+    end crlf;
+
+  declare xdos literally 'mon2a';
+
+  declare datapgadr address;
+  declare datapg based datapgadr address;
+
+  declare param$adr address;
+  declare param based param$adr structure (
+    mem$top byte,
+    nmbcns byte,
+    breakpoint$restart byte,
+    add$sys$stack byte,
+    bank$switching byte,
+    Z80 byte,
+    banked$BDOS byte );
+
+  declare rlradr address;
+  declare rlr based rlradr address;
+  declare rlrcont address;
+  declare rlrpd based rlrcont process$descriptor;
+
+  declare dlradr address;
+  declare dlr based dlradr address;
+
+  declare drladr address;
+  declare drl based drladr address;
+
+  declare plradr address;
+  declare plr based plradr address;
+
+  declare slradr address;
+  declare slr based slradr address;
+
+  declare qlradr address;
+  declare qlr based qlradr address;
+
+  declare nmb$cns$adr address;
+  declare nmb$consoles based nmb$cns$adr byte;
+
+  declare cns$att$adr address;
+  declare console$attached based cns$att$adr (1) address;
+
+  declare cns$que$adr address;
+  declare console$queue based cns$que$adr (1) address;
+
+  declare nmb$lst$adr address;
+  declare nmb$printers based nmb$lst$adr byte;
+
+  declare lst$att$adr address;
+  declare list$attached based lst$att$adr (1) address;
+
+  declare lst$que$adr address;
+  declare list$queue based lst$que$adr (1) address;
+
+  declare nmbflags$adr address;
+  declare nmbflags based nmbflags$adr byte;
+
+  declare sys$flg$adr address;
+  declare sys$flag based sys$flg$adr (1) address;
+
+  declare nmb$seg$adr address;
+  declare nmb$segs based nmb$seg$adr byte;
+
+  declare mem$seg$tbl$adr address;
+  declare mem$seg$tbl based mem$seg$tbl$adr (1) memory$descriptor;
+
+  declare pdtbl$adr address;
+  declare pdtbl based pdtbl$adr (1) process$descriptor;
+
+  declare hex$digit (*) byte data ('0123456789ABCDEF');
+
+  declare queue$adr address;
+
+  declare queue based queue$adr structure (
+    cqueue,
+    owner$adr address );
+
+  display$hex$byte:
+    procedure (value);
+      declare value byte;
+
+      call co (hex$digit(shr(value,4)));
+      call co (hex$digit(value mod 16));
+    end display$hex$byte;
+
+  display$text:
+    procedure (count,text$adr);
+      declare count byte;
+      declare text$adr address;
+      declare char based text$adr byte;
+      declare i byte;
+
+      if count+char = 0 then return;
+      if count = 0 then
+      do;
+        call print$buffer (text$adr);
+      end;
+      else
+      do i = 1 to count;
+        call co (char and 7fh);
+        text$adr = text$adr + 1;
+      end;
+    end display$text;
+
+  display$links:
+    procedure (count,title$adr,root$adr);
+      declare count byte;
+      declare (title$adr,root$adr) address;
+      declare char based title$adr byte;
+      declare pd based root$adr process$descriptor;
+      declare i byte;
+      declare link$list (64) address;
+      declare (n,k) byte;
+
+      if count+char <> 0 then call crlf;
+      call display$text (count,title$adr);
+      if count+char = 0
+        then i = 0;
+        else i = 7;
+      n = -1;
+      disable;  /* critical section required to obtain list */
+        do while (root$adr <> 0) and (n <> 63) and (high(root$adr) <> 0ffh);
+          link$list(n:=n+1) = root$adr;
+          root$adr = pd.pl;
+        end;
+      call mon1 (dispatch,0);  /* enable interrupts by dispatching */
+      if n = -1 then return;
+      do k = 0 to n;
+        root$adr = link$list(k);
+        i = i + 1;
+        if i >= 8 then
+        do;
+          call crlf;
+          call co (' ');
+          i = 1;
+        end;
+        call co (' ');
+        call display$text (8,.pd.name);
+        if pd.memseg <> 0ffh then
+        do;
+          call co ('[');
+          call co (hex$digit(pd.console and 0fh));
+          call co (']');
+        end;
+      end;
+    end display$links;
+
+  display$config:
+    procedure;
+
+      call display$text (0,
+        .(0dh,0ah,0dh,0ah,'Top of memory = ','$'));
+      call display$hex$byte (param.mem$top);
+      call display$text (0,
+        .('FFH',0dh,0ah,'Number of consoles = ','$'));
+      call display$hex$byte (nmb$consoles);
+      call display$text (0,
+        .(0dh,0ah,'Debugger breakpoint restart # = ','$'));
+      call display$hex$byte (param.breakpoint$restart);
+      if param.add$sys$stack then
+      do;
+        call display$text (0,
+          .(0dh,0ah,'Stack is swapped on BDOS calls','$'));
+      end;
+      if param.bank$switching then
+      do;
+        call display$text (0,
+          .(0dh,0ah,'Memory is bank switched','$'));
+        if param.banked$BDOS then
+        do;
+          call display$text (0,
+            .(0dh,0ah,'BDOS disk file management is bank switched','$'));
+        end;
+      end;
+      if param.Z80 then
+      do;
+        call display$text (0,
+          .(0dh,0ah,'Z80 complementary registers managed by dispatcher','$'));
+      end;
+      call crlf;
+    end display$config;
+
+  display$ready:
+    procedure;
+
+      call display$links (0,
+        .('Ready Process(es):','$'),rlr);
+    end display$ready;
+
+  display$DQ:
+    procedure;
+
+      call crlf;
+      call display$text (0,
+        .('Process(es) DQing:','$'));
+      queue$adr = qlr;
+      do while queue$adr <> 0;
+        if queue.dqph <> 0 then
+        do;
+          call display$text (4,.(0DH,0AH,' ['));
+          call display$text (8,.queue.name);
+          call co (']');
+          call display$links (0,.(0),queue.dqph);
+        end;
+        queue$adr = queue.ql;
+      end;
+    end display$DQ;
+
+  display$NQ:
+    procedure;
+
+      call crlf;
+      call display$text (0,
+        .('Process(es) NQing:','$'));
+      queue$adr = qlr;
+      do while queue$adr <> 0;
+        if queue.nqph <> 0 then
+        do;
+          call display$text (4,.(0DH,0AH,' ['));
+          call display$text (8,.queue.name);
+          call co (']');
+          call display$links (0,.(0),queue.nqph);
+        end;
+        queue$adr = queue.ql;
+      end;
+    end display$NQ;
+
+  display$delay:
+    procedure;
+
+      call display$links (0,
+        .('Delayed Process(es):','$'),dlr);
+    end display$delay;
+
+  display$poll:
+    procedure;
+
+      call display$links (0,
+        .('Polling Process(es):','$'),plr);
+    end display$poll;
+
+  display$flag$wait:
+    procedure;
+      declare i byte;
+
+      call crlf;
+      call display$text (0,
+        .('Process(es) Flag Waiting:','$'));
+      do i = 0 to nmbflags-1;
+        if sys$flag(i) < 0FFFEH then
+        do;
+           call crlf;
+           call co (' ');
+           call co (' ');
+           call display$hex$byte (i);
+           call display$text (3,.(' - '));
+           call display$links (0,.(0),sys$flag(i));
+        end;
+      end;
+    end display$flag$wait;
+
+  display$flag$set:
+    procedure;
+      declare i byte;
+
+      call crlf;
+      call display$text (0,
+        .('Flag(s) Set:','$'));
+      do i = 0 to nmbflags-1;
+        if sys$flag(i) = 0FFFEH then
+        do;
+          call crlf;
+          call co (' ');
+          call co (' ');
+          call display$hex$byte (i);
+        end;
+      end;
+    end display$flag$set;
+
+  display$queues:
+    procedure;
+      declare i byte;
+
+      queue$adr = qlr;
+      call crlf;
+      call display$text (0,
+        .('Queue(s):','$'));
+      i = 7;
+      do while queue$adr <> 0;
+        i = i + 1;
+        if i >= 8 then
+        do;
+          call crlf;
+          call co (' ');
+          i = 1;
+        end;
+        call co (' ');
+        call display$text (8,.queue.name);
+        if (queue.name(0) = 'M') and
+           (queue.name(1) = 'X') and
+           (queue.msglen  =  0 ) and
+           (queue.nmbmsgs =  1 ) and
+           (queue.msgcnt  =  0 ) then
+        do;
+          call co ('[');
+          call display$text (8,queue.owner$adr+6);
+          call co (']');
+          i = i + 1;
+        end;
+        queue$adr = queue.ql;
+      end;
+      call crlf;
+    end display$queues;
+
+  display$consoles:
+    procedure;
+      declare i byte;
+      declare name$offset literally '6';
+
+      call display$text (0,
+        .('Process(es) Attached to Consoles:','$'));
+      if nmb$consoles <> 0 then
+      do i = 0 to nmb$consoles-1;
+        call display$text (5,.(0dh,0ah,'  ['));
+        call co (hex$digit(i));
+        call display$text (4,.('] - '));
+        if console$attached(i) = 0
+          then call display$text (0,
+                 .('Unattached','$'));
+          else call display$text (8,
+                 console$attached(i) + name$offset);
+      end;
+      call display$text (0,.(0dh,0ah,
+        'Process(es) Waiting for Consoles:','$'));
+      if nmb$consoles <> 0 then
+      do i = 0 to nmb$consoles-1;
+        if console$queue(i) <> 0 then
+        do;
+          call display$text (5,.(0dh,0ah,'  ['));
+          call co (hex$digit(i));
+          call display$text (4,.('] - '));
+          call display$links (0,.(0),console$queue(i));
+        end;
+      end;
+    end display$consoles;
+
+  display$printers:
+    procedure;
+      declare i byte;
+      declare name$offset literally '6';
+
+      call display$text (0,
+        .(0dh,0ah,'Process(es) Attached to Printers:','$'));
+      if nmb$printers <> 0 then
+      do i = 0 to nmb$printers-1;
+        call display$text (5,.(0dh,0ah,'  ['));
+        call co (hex$digit(i));
+        call display$text (4,.('] - '));
+        if list$attached(i) = 0
+          then call display$text (0,
+                 .('Unattached','$'));
+          else call display$text (8,
+                 list$attached(i) + name$offset);
+      end;
+      call display$text (0,.(0dh,0ah,
+        'Process(es) Waiting for Printers:','$'));
+      if nmb$printers <> 0 then
+      do i = 0 to nmb$printers-1;
+        if list$queue(i) <> 0 then
+        do;
+          call display$text (5,.(0dh,0ah,'  ['));
+          call co (hex$digit(i));
+          call display$text (4,.('] - '));
+          call display$links (0,.(0),list$queue(i));
+        end;
+      end;
+    end display$printers;
+
+  display$mem$seg:
+    procedure;
+      declare i byte;
+
+      call display$text (0,.(0dh,0ah,
+        'Memory Allocation:','$'));
+      do i = 0 to nmbsegs-1;
+        call display$text (0,
+          .(0dh,0ah,'  Base = ','$'));
+        call display$hex$byte (memsegtbl(i).base);
+        call display$text (0,
+          .('00H  Size = ','$'));
+        call display$hex$byte (memsegtbl(i).size);
+        call display$text (0,.('00','$'));
+        if param.bank$switching then
+        do;
+          call display$text (0,
+            .('H  Bank = ','$'));
+          call display$hex$byte (memsegtbl(i).bank);
+        end;
+        if (memsegtbl(i).attrib and allocated) = 0 then
+        do;
+          call display$text (0,
+            .('H  * Free *','$'));
+        end;
+        else
+        do;
+          if memsegtbl(i).attrib = 0ffh then
+          do;
+            call display$text (0,
+              .('H  * Reserved *','$'));
+          end;
+          else
+          do;
+            call display$text (0,
+              .('H  Allocated to ','$'));
+            call display$text (8,.pdtbl(i).name);
+            call co ('[');
+            call co (hex$digit(pdtbl(i).console and 0fh));
+            call co (']');
+          end;
+        end;
+      end;
+    end display$mem$seg;
+
+  setup:
+    procedure;
+
+      datapgadr = (param$adr:=xdos (system$data$adr,0)) + 252;
+      datapgadr = datapg;
+      rlradr = datapgadr + osrlr;
+      rlrcont = rlr;
+      dlradr = datapgadr + osdlr;
+      drladr = datapgadr + osdrl;
+      plradr = datapgadr + osplr;
+      slradr = datapgadr + osslr;
+      qlradr = datapgadr + osqlr;
+      nmb$cns$adr = datapgadr + osnmbcns;
+      cns$att$adr = datapgadr + oscnsatt;
+      cns$que$adr = datapgadr + oscnsque;
+      nmb$lst$adr = datapgadr + osnmblst;
+      lst$att$adr = datapgadr + oslstatt;
+      lst$que$adr = datapgadr + oslstque;
+      nmbflags$adr = datapgadr + osnmbflags;
+      sys$flg$adr = datapgadr + ossysfla;
+      nmb$seg$adr = datapgadr + osnmbsegs;
+      mem$seg$tbl$adr = datapgadr + osmsegtbl;
+      pdtbl$adr = datapgadr + ospdtbl;
+    end setup;
+
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/mspl.plm

@@ -0,0 +1,324 @@
+$title('MP/M II V2.0  Spool Program')
+spool:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+$include (proces.lit)
+$include (queue.lit)
+$include (xdos.lit)
+$include (fcb.lit)
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data (
+    0c3h,
+    .start-3);
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare maxb address external;
+  declare fcb fcb$descriptor external;
+  declare tbuff fcb$descriptor external;
+
+  declare get$user literally '32',
+          get$disk literally '25';
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  print$console$buffer:
+    procedure (buff$adr);
+      declare buff$adr address;
+      call mon1 (9,buff$adr);
+    end print$console$buffer;
+
+  check$console$status:
+    procedure byte;
+      return mon2 (11,0);
+    end check$console$status;
+
+  open:
+    procedure (fcb$adr) byte public;
+      declare fcb$adr address;
+      declare fcb based fcb$adr fcb$descriptor;
+      return mon2 (15,fcb$adr);
+    end open;
+  
+  delete$file:
+    procedure (fcb$adr) public;
+      declare fcb$adr address;
+      call mon1 (19,fcb$adr);
+    end delete$file;
+
+  readbf:
+    procedure (fcb$adr) byte public;
+      declare fcb$adr address;
+      return mon2 (20,fcb$adr);
+    end readbf;
+  
+  set$dma:
+    procedure (dma$adr) public;
+      declare dma$adr address;
+      call mon1 (26,dma$adr);
+    end set$dma;
+
+  free$drives:
+    procedure;
+      call mon1 (39,0ffffh);
+    end free$drives;
+
+  co:
+    procedure (char) public;
+      declare char byte;
+      call mon1 (2,char);
+    end co;
+
+  lo:
+    procedure (char) public;
+      declare char byte;
+      call mon1 (5,char);
+    end lo;
+
+  system$reset:
+    procedure;
+      call mon1 (0,0);
+    end system$reset;
+
+  declare xdos literally 'mon2';
+  declare xdosa literally 'mon2a';
+
+  declare pcb structure (
+    field$adr address,
+    fcb$adr address)
+    initial (0,.fcb);
+
+  declare control$z literally '1AH';
+
+  declare (nmbufs,actbuf) address;
+
+  list$buf:
+    procedure (buf$adr) byte;
+      declare buf$adr address;
+      declare buffer based buf$adr (1) byte;
+      declare i byte;
+
+      do i = 0 to 127;
+        if (char := buffer(i)) = control$z
+          then return true;
+        itab = (char = 09H) and (7 - (column and 7));
+        if char = 09H
+          then char = ' ';
+        do jtab = 0 to itab;
+          if char >= ' '
+            then column = column + 1;
+          if char = 0AH then column = 0;
+          call lo(char);
+          if check$console$status then
+          do;
+            i = read$console;
+            call system$reset;
+          end;
+        end;
+      end;
+      return false;
+    end list$buf;
+
+  copy$file:
+    procedure (buf$base);
+      declare buf$base address;
+      declare buffer based buf$base (1) structure (
+        record (128) byte);
+      declare ok byte;
+      declare i address;
+
+      do forever;
+        actbuf = 0;
+        ok = true;
+        do while ok;
+          call set$dma (.buffer(actbuf));
+          if (ok := (readbf (.fcb) = 0)) then
+          do;
+            ok = ((actbuf := actbuf+1) <> nmbufs);
+          end;
+          else
+          do;
+            if actbuf = 0 then return;
+          end;
+        end;
+        do i = 0 to actbuf-1;
+          if list$buf (.buffer(i))
+            then return;
+        end;
+        if actbuf <> nmbufs then return;
+      end;
+    end copy$file;
+
+  detach$msg:
+    procedure;
+      declare ret byte;
+
+      call print$console$buffer (.(
+             '- Enter STOPSPLR to abort the spooler',0dh,0ah,
+             '- Enter ATTACH SPOOL to re-attach console to spooler',0dh,0ah,
+             '*** Spooler detaching from console ***','$'));
+      ret = xdos (detach,0);
+    end detach$msg;
+
+  declare ret byte;
+
+  declare (char,column,itab,jtab,i) byte;
+
+  declare nxt$chr$adr address;
+  declare delim based nxt$chr$adr byte;
+
+  declare spool$msg (1) byte at (.tbuff-1);
+
+  declare SPOOLQ$uqcb userqcb
+    initial (0,.spool$msg,'SPOOLQ  ');
+
+  declare reserved$for$disk (3) byte;
+  declare dummy$buffer (128) byte;
+  declare buffer (1) structure (
+    char (128) byte) at (.dummy$buffer);
+
+  declare last$dseg$byte byte
+    initial (0);
+
+
+/*
+  spool:
+*/
+
+start:
+
+  call print$console$buffer (.(
+    'MP/M II V2.0  Spooler',0dh,0ah,'$'));
+  nxt$chr$adr = .tbuff;		/* make sure files exit */
+  do while (nxt$chr$adr <> 0);
+    pcb.field$adr = nxt$chr$adr + 1;
+    nxt$chr$adr = xdosa (parse$fname,.pcb);
+    if nxt$chr$adr = 0FFFFH then
+    do;
+      call print$console$buffer(.(0dh,0ah,
+                                'Illegal File Name',0dh,0ah,'$'));
+      call system$reset;
+    end;
+    else
+    do;
+      if open (.fcb) = 0FFH then
+      do;
+        call print$console$buffer (.(0dh,0ah,
+                                   'Can''t Open File = $'));
+        if fcb.et <> 0 then
+        do;
+          call co ('A'+fcb.et-1);
+          call co (':');
+        end;
+        fcb.ex = '$';
+        call print$console$buffer(.fcb.fn);
+        call co (0dh);
+        call co (0ah);
+        call system$reset;
+      end;
+      call free$drives;
+    end;
+  end; /* of while */
+
+  if xdos (open$queue,.SPOOLQ$uqcb) <> 0ffh then
+  do;
+    spool$msg(0) = xdos (get$disk,0)*16 + xdos (get$user,0ffh);
+    spool$msg(1) = xdos (get$list$nmb,0)*16 + xdos (get$console$nmb,0);  
+    if xdos (cond$write$queue,.SPOOLQ$uqcb) = 0ffh then
+    do;
+      call print$console$buffer (.(
+        '*** Spool Queue is full ***',0dh,0ah,'$'));
+    end;
+    call system$reset;
+  end;
+
+  nmbufs = shr((maxb-.buffer),8);
+  if xdos (cond$attach$list,0) = 0ffh then
+  do;
+    call print$console$buffer (.(
+      '*** Printer busy ***',0dh,0ah,
+      '- Spooler will wait until printer free',0dh,0ah,'$'));
+    call detach$msg;
+    ret = xdos (attach$list,0);
+  end;
+  else
+  do;
+    call detach$msg;
+  end;
+  nxt$chr$adr = .tbuff;
+  do while (nxt$chr$adr <> 0) and
+           (nxt$chr$adr <> 0FFFFH);
+    pcb.field$adr = nxt$chr$adr + 1;
+    nxt$chr$adr = xdosa (parse$fname,.pcb);
+    if nxt$chr$adr <> 0FFFFH then
+    do;
+      fcb.fn(5) = (fcb.fn(5) or 80h);
+      if open (.fcb) <> 0FFH then
+      do;
+        fcb.nr = 0;
+        call copy$file(.buffer);
+        call free$drives;
+	if (nxt$chr$adr <> 0) and
+           (delim = '[') then
+        do;
+          pcb.field$adr = nxt$chr$adr + 1;
+          pcb.fcb$adr = .dummy$buffer;
+          nxt$chr$adr = xdosa (parse$fname,.pcb);
+          if nxt$chr$adr <> 0ffffh then
+          do;
+            if dummy$buffer(1) = 'D' then
+            do;
+              fcb.ex = 0;
+              call delete$file (.fcb);
+            end;
+            if (nxt$chr$adr <> 0) and
+               (delim <> ']') then
+            do;
+              nxt$chr$adr = 0ffffh;
+            end;
+          end;
+          pcb.fcb$adr = .fcb;
+        end;
+      end;
+    end;
+  end; /* of while */
+  call system$reset;
+end spool;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/msts.plm

@@ -0,0 +1,51 @@
+$title('MP/M II V2.0 Status Program')
+status:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data (
+    0C3H,.start-3);
+
+$include (dpgos.lit)
+$include (proces.lit)
+$include (queue.lit)
+$include (memmgr.lit)
+$include (xdos.lit)
+
+$include (mscmn.plm)
+
+  declare ret byte;
+
+  declare last$dseg$byte byte
+    initial (0);
+
+  start:
+    call setup;
+    call crlf;
+    call crlf;
+    call display$text (0,
+      .('****** MP/M II V2.0 Status Display ******','$'));
+    call display$config;
+    call display$ready;
+    call display$DQ;
+    call display$NQ;
+    call display$delay;
+    call display$poll;
+    call display$flag$wait;
+    call display$flag$set;
+    call display$queues;
+    call display$consoles;
+    call display$printers;
+    call display$mem$seg;
+    ret = xdos (terminate,0);
+
+end status;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/print.plm

@@ -0,0 +1,183 @@
+$title('MP/M II V2.0 List Number Assign/Display')
+list:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0c3h,.start-3);
+
+$include (proces.lit)
+
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare xdos literally 'mon2';
+  declare xdosa literally 'mon2a';
+
+  declare fcb (1) byte external;
+
+  print$buffer:
+    procedure (bufferadr);
+      declare bufferadr address;
+      call mon1 (9,bufferadr);
+    end print$buffer;
+
+  who$list:
+    procedure byte;
+      declare pdadr address;
+      declare pd based pdadr process$descriptor;
+      pdadr = mon2a (156,0);
+      return (shr (pd.console,4));
+    end who$list;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  who$con:
+    procedure byte;
+      return xdos (153,0);
+    end who$con;
+
+  sys$dat$adr:
+    procedure address;
+      return xdosa (154,0);
+    end sys$dat$adr;
+
+  ASCII$to$int:
+    procedure (string$adr) byte;
+      declare string$adr address;
+      declare string based string$adr (1) byte;
+
+        if (string(0) := string(0) - '0') < 10 then
+        do;
+          if string(1) <> ' '
+            then return string(0)*10 + (string(1)-'0');
+            else return string(0);
+        end;
+        return 254;
+    end ASCII$to$int;
+
+  int$to$ASCII:
+    procedure (string$adr);
+      declare string$adr address;
+      declare string based string$adr (1) byte;
+
+        if string(0) < 10 then
+        do;
+          string(0) = string(0) + '0';
+          string(1) = ' ';
+        end;
+        else
+        do;
+          string(1) = (string(0)-10) + '0';
+          string(0) = '1';
+        end;
+    end int$to$ASCII;
+
+  declare datapgadr address;
+  declare datapg based datapgadr address;
+
+  declare thread$root$adr address;
+  declare thread$root based thread$root$adr address;
+
+  declare TMPx (8) byte
+    initial ('Tmpx    ');
+  declare console byte at (.TMPx(3));
+
+  declare msg1 (*) byte
+    initial ('List Number = ');
+  declare msg2 (5) byte
+    initial ('xx',0dh,0ah,'$');
+  declare list$nmb byte at (.msg2(0));
+
+  declare pdadr address;
+  declare pd based pdadr Process$descriptor;
+
+  declare i byte;
+
+  /*
+     List Main Program
+  */
+
+  start:
+    if fcb(1) = ' ' then
+    /* displaying list number */
+    do;
+      list$nmb = who$list;
+    end;
+    else
+    /* assigning list number */
+    do;
+      if (list$nmb := ASCII$to$int(.fcb(1))) < 16 then
+      do;
+        console = who$con + '0';
+        datapgadr = sys$dat$adr + 252;
+        datapgadr = datapg;
+        thread$root$adr = datapgadr + 17;
+        pdadr = thread$root;
+        do while pdadr <> 0;
+          i = 0;
+          do while (i <> 8) and ((pd.name(i) and 7fh) = TMPx(i));
+            i = i + 1;
+          end;
+          if i = 8 then
+          do;
+            pd.console = ((pd.console and 0Fh) or
+                         (shl (list$nmb,4)));
+            pdadr = 0;
+          end;
+          else
+          do;
+            pdadr = pd.thread;
+          end;
+        end;
+      end;
+      else
+      /* invalid list number entry */
+      do;
+        list$nmb = who$list;
+        call print$buffer (.(
+          'Invalid list number, ignored',0dh,0ah,'$'));
+      end;
+    end;
+    call int$to$ASCII (.listnmb);
+    call print$buffer (.msg1);
+    call terminate;
+
+end list;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/prlb1.sub

@@ -0,0 +1,71 @@
+pip a:=cns.plm[g8]
+seteof cns.plm
+isx
+plm80 cns.plm nolist debug
+era cns.plm
+link cns.obj,x0100,plm80.lib to cns1.mod
+locate cns1.mod code(0100H) stacksize(100)
+era cns1.mod
+objhex cns1 to cns1.hex
+link cns.obj,x0200,plm80.lib to cns2.mod
+locate cns2.mod code(0200H) stacksize(100)
+era cns2.mod
+objhex cns2 to cns2.hex
+era cns2
+cpm
+objcpm cns1
+era cns1.com
+pip cns.hex=cns1.hex,cns2.hex
+era cns1.hex
+era cns2.hex
+zero
+genmod cns.hex xcns.prl 
+era *.hex
+pip a:=drst.plm[g8]
+seteof drst.plm
+isx
+plm80 drst.plm nolist debug
+era drst.plm
+link drst.obj,x0100,plm80.lib to drst1.mod
+locate drst1.mod code(0100H) stacksize(100)
+era drst1.mod
+objhex drst1 to drst1.hex
+link drst.obj,x0200,plm80.lib to drst2.mod
+locate drst2.mod code(0200H) stacksize(100)
+era drst2.mod
+objhex drst2 to drst2.hex
+era drst2
+cpm
+objcpm drst1
+era drst1.com
+pip drst.hex=drst1.hex,drst2.hex
+era drst1.hex
+era drst2.hex
+zero
+genmod drst.hex xdrst.prl 
+era *.hex
+pip a:=print.plm[g8]
+seteof print.plm
+isx
+plm80 print.plm nolist debug
+era print.plm
+link print.obj,x0100,plm80.lib to print1.mod
+locate print1.mod code(0100H) stacksize(100)
+era print1.mod
+objhex print1 to print1.hex
+link print.obj,x0200,plm80.lib to print2.mod
+locate print2.mod code(0200H) stacksize(100)
+era print2.mod
+objhex print2 to print2.hex
+era print2
+cpm
+objcpm print1
+era print1.com
+pip print.hex=print1.hex,print2.hex
+era print1.hex
+era print2.hex
+zero
+genmod print.hex xprint.prl 
+era *.hex
+sub prlb2
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/prlb2.sub

@@ -0,0 +1,71 @@
+pip a:=prlcm.plm[g8]
+seteof prlcm.plm
+isx
+plm80 prlcm.plm nolist debug
+era prlcm.plm
+link prlcm.obj,x0100,plm80.lib to prlcm1.mod
+locate prlcm1.mod code(0100H) stacksize(100)
+era prlcm1.mod
+objhex prlcm1 to prlcm1.hex
+link prlcm.obj,x0200,plm80.lib to prlcm2.mod
+locate prlcm2.mod code(0200H) stacksize(100)
+era prlcm2.mod
+objhex prlcm2 to prlcm2.hex
+era prlcm2
+cpm
+objcpm prlcm1
+era prlcm1.com
+pip prlcm.hex=prlcm1.hex,prlcm2.hex
+era prlcm1.hex
+era prlcm2.hex
+zero
+genmod prlcm.hex xprlcm.prl 
+era *.hex
+pip a:=sub.plm[g8]
+seteof sub.plm
+isx
+plm80 sub.plm nolist debug
+era sub.plm
+link sub.obj,x0100,plm80.lib to sub1.mod
+locate sub1.mod code(0100H) stacksize(100)
+era sub1.mod
+objhex sub1 to sub1.hex
+link sub.obj,x0200,plm80.lib to sub2.mod
+locate sub2.mod code(0200H) stacksize(100)
+era sub2.mod
+objhex sub2 to sub2.hex
+era sub2
+cpm
+objcpm sub1
+era sub1.com
+pip sub.hex=sub1.hex,sub2.hex
+era sub1.hex
+era sub2.hex
+zero
+genmod sub.hex xsub.prl 
+era *.hex
+pip a:=tod.plm[g8]
+seteof tod.plm
+isx
+plm80 tod.plm nolist debug
+era tod.plm
+link tod.obj,x0100,plm80.lib to tod1.mod
+locate tod1.mod code(0100H) stacksize(100)
+era tod1.mod
+objhex tod1 to tod1.hex
+link tod.obj,x0200,plm80.lib to tod2.mod
+locate tod2.mod code(0200H) stacksize(100)
+era tod2.mod
+objhex tod2 to tod2.hex
+era tod2
+cpm
+objcpm tod1
+era tod1.com
+pip tod.hex=tod1.hex,tod2.hex
+era tod1.hex
+era tod2.hex
+zero
+genmod tod.hex xtod.prl 
+era *.hex
+sub prlb3
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/prlb3.sub

@@ -0,0 +1,71 @@
+pip a:=user.plm[g8]
+seteof user.plm
+isx
+plm80 user.plm nolist debug
+era user.plm
+link user.obj,x0100,plm80.lib to user1.mod
+locate user1.mod code(0100H) stacksize(100)
+era user1.mod
+objhex user1 to user1.hex
+link user.obj,x0200,plm80.lib to user2.mod
+locate user2.mod code(0200H) stacksize(100)
+era user2.mod
+objhex user2 to user2.hex
+era user2
+cpm
+objcpm user1
+era user1.com
+pip user.hex=user1.hex,user2.hex
+era user1.hex
+era user2.hex
+zero
+genmod user.hex xuser.prl 
+era *.hex
+pip a:=abort.plm[g8]
+seteof abort.plm
+isx
+plm80 abort.plm nolist debug
+era abort.plm
+link abort.obj,x0100,plm80.lib to abort1.mod
+locate abort1.mod code(0100H) stacksize(100)
+era abort1.mod
+objhex abort1 to abort1.hex
+link abort.obj,x0200,plm80.lib to abort2.mod
+locate abort2.mod code(0200H) stacksize(100)
+era abort2.mod
+objhex abort2 to abort2.hex
+era abort2
+cpm
+objcpm abort1
+era abort1.com
+pip abort.hex=abort1.hex,abort2.hex
+era abort1.hex
+era abort2.hex
+zero
+genmod abort.hex xabort.prl 
+era *.hex
+pip a:=mschd.plm[g8]
+seteof mschd.plm
+isx
+plm80 mschd.plm nolist debug
+era mschd.plm
+link mschd.obj,x0100,plm80.lib to mschd1.mod
+locate mschd1.mod code(0100H) stacksize(100)
+era mschd1.mod
+objhex mschd1 to mschd1.hex
+link mschd.obj,x0200,plm80.lib to mschd2.mod
+locate mschd2.mod code(0200H) stacksize(100)
+era mschd2.mod
+objhex mschd2 to mschd2.hex
+era mschd2
+cpm
+objcpm mschd1
+era mschd1.com
+pip mschd.hex=mschd1.hex,mschd2.hex
+era mschd1.hex
+era mschd2.hex
+zero
+genmod mschd.hex xmschd.prl 
+era *.hex
+sub prlb4
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/prlb4.sub

@@ -0,0 +1,84 @@
+pip a:=mspl.plm[g8]
+seteof mspl.plm
+isx
+plm80 mspl.plm nolist debug
+era mspl.plm
+link mspl.obj,x0100,plm80.lib to mspl1.mod
+locate mspl1.mod code(0100H) stacksize(100)
+era mspl1.mod
+objhex mspl1 to mspl1.hex
+link mspl.obj,x0200,plm80.lib to mspl2.mod
+locate mspl2.mod code(0200H) stacksize(100)
+era mspl2.mod
+objhex mspl2 to mspl2.hex
+era mspl2
+cpm
+objcpm mspl1
+era mspl1.com
+pip mspl.hex=mspl1.hex,mspl2.hex
+era mspl1.hex
+era mspl2.hex
+zero
+genmod mspl.hex xmspl.prl 
+era *.hex
+pip a:=mscmn.plm[g8]
+seteof mscmn.plm
+pip a:=msts.plm[g8]
+seteof msts.plm
+isx
+plm80 msts.plm nolist debug
+era mscmn.plm
+era msts.plm
+link msts.obj,x0100,plm80.lib to msts1.mod
+locate msts1.mod code(0100H) stacksize(100)
+era msts1.mod
+objhex msts1 to msts1.hex
+link msts.obj,x0200,plm80.lib to msts2.mod
+locate msts2.mod code(0200H) stacksize(100)
+era msts2.mod
+objhex msts2 to msts2.hex
+era msts2
+cpm
+objcpm msts1
+era msts1.com
+pip msts.hex=msts1.hex,msts2.hex
+era msts1.hex
+era msts2.hex
+zero
+genmod msts.hex xmsts.prl 
+era *.hex
+pip a:=stpsp.plm[g8]
+seteof stpsp.plm
+isx
+plm80 stpsp.plm nolist debug
+era stpsp.plm
+link stpsp.obj,x0100,plm80.lib to stpsp1.mod
+locate stpsp1.mod code(0100H) stacksize(100)
+era stpsp1.mod
+objhex stpsp1 to stpsp1.hex
+link stpsp.obj,x0200,plm80.lib to stpsp2.mod
+locate stpsp2.mod code(0200H) stacksize(100)
+era stpsp2.mod
+objhex stpsp2 to stpsp2.hex
+era stpsp2
+cpm
+objcpm stpsp1
+era stpsp1.com
+pip stpsp.hex=stpsp1.hex,stpsp2.hex
+era stpsp1.hex
+era stpsp2.hex
+zero
+genmod stpsp.hex xstpsp.prl 
+era *.hex
+pip a:=dump.asm[g8]
+seteof dump.asm
+pip a:=extrn.asm[g8]
+seteof extrn.asm
+rmac dump $$pzsz
+era dump.asm
+rmac extrn $$pzsz
+era extrn.asm
+link xdump=dump,extrn[op]
+era dump.rel
+era extrn.rel
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/prlcm.plm

@@ -0,0 +1,235 @@
+$title ('MP/M II V2.0  PRL to COM File')
+prlcom:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address  ) data (
+      0C3H,.start-3);
+
+  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;
+
+  declare fcb (1) byte external;
+  declare fcb16 (1) byte external;
+  declare tbuff (1) byte external;
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  system$reset:
+    procedure;
+      declare dummy address;
+      dummy = 0;
+      stackptr = .dummy;
+    end system$reset;
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  print$buffer:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buffer;
+
+  open$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (15,fcb$address);
+    end open$file;
+
+  close$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (16,fcb$address);
+    end close$file;
+
+  delete$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (19,fcb$address);
+    end delete$file;
+
+  read$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (20,fcb$address);
+    end read$record;
+
+  write$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (21,fcb$address);
+    end write$record;
+
+  make$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (22,fcb$address);
+    end make$file;
+
+  set$DMA$address:
+    procedure (DMA$address);
+      declare DMA$address address;
+      call mon1 (26,DMA$address);
+    end set$DMA$address;
+  
+
+  declare nrec address;
+  declare errmsg address;
+  declare (i,n,cnt,ret) byte;
+
+  declare fcbout (33) byte initial (
+    1,'        ','   ',0,0,0,0,0,0,0,0,
+    0,0,0,0,0,0,0,0,0,0,0,0,0);
+
+
+
+  declare sector$size literally '128';
+  declare n$sect literally '8';
+  declare buffer (n$sect) structure (
+    sector (sector$size) byte );
+  declare code$size address at (.buffer(0).sector(1));
+  declare last$DSEG$byte byte initial (0);
+
+  write$buffer:
+    procedure (n);
+      declare (i,n) byte;
+
+      /* write COM file from memory */
+      do i = 0 to n-1;
+        call set$DMA$address (.buffer(i));
+        if (ret := write$record (.fcbout)) <> 0 then
+        do;
+          errmsg = .('Error during writing COM output file.','$');
+          go to error;
+        end;
+      end;
+    end write$buffer;
+
+  copy$PRL$to$COM:
+    procedure;
+
+      call set$DMA$address (.buffer(0));
+      if (ret := read$record (.fcb)) <> 0 then
+      do;
+        errmsg = .('Unable to read header record.','$');
+        go to error;
+      end;
+      call set$DMA$address (.buffer(1));
+      if (ret := read$record (.fcb) <> 0) then
+      do;
+        errmsg = .('Unable to read header record.','$');
+        go to error;
+      end;
+      nrec = shr(code$size+7FH,7);
+
+      /* read PRL file into buffer and write to COM file */
+      cnt = 0;
+      do while nrec <> 0;
+        call set$DMA$address (.buffer(cnt));
+        if (ret := read$record (.fcb)) <> 0 then
+        do;
+          errmsg = .('Bad data record in PRL file.','$');
+          go to error;
+        end;
+        if (cnt := cnt+1) = n$sect then
+        do;
+          call write$buffer (n$sect);
+          cnt = 0;
+        end;
+        nrec = nrec - 1;
+      end;
+      if cnt <> 0
+        then call write$buffer (cnt);
+
+      call close$file (.fcbout);
+
+    end copy$PRL$to$COM;
+
+  setup:
+    procedure;
+
+      if fcb(1) = ' ' then
+      do;
+        errmsg = .('Input file must be specified.','$');
+        go to error;
+      end;
+      if fcb(9) = ' '
+        then call move (3,.('PRL'),.fcb(9));
+      if fcb16(1) = ' ' then
+      do;
+        call move (9,.fcb,.fcb16);
+      end;
+      if fcb16(9) = ' '
+        then call move (3,.('COM'),.fcb16(9));
+      call move (16,.fcb16,.fcbout);
+      if open$file (.fcb) = 0ffh then
+      do;
+        errmsg = .('Input file does not exist.','$');
+        go to error;
+      end;
+      fcb(32) = 0;
+      if open$file (.fcbout) <> 0ffh then
+      do;
+        call print$buffer (.(0ah,0dh,
+          'Destination file exists, delete (Y/N)?','$'));
+        ret = read$console;
+        if (ret = 'y') or
+           (ret = 'Y') then
+        do;
+          call delete$file (.fcbout);
+        end;
+        else
+        do;
+          call system$reset;
+        end;
+      end;
+      call make$file (.fcbout);
+      fcbout(32) = 0;
+    end setup;
+
+  /*
+    Main Program
+  */
+
+  start:
+
+    call setup;
+    call copy$PRL$to$COM;
+    call system$reset;
+
+  error:
+    call print$buffer (.(0dh,0ah,'$'));
+    call print$buffer (errmsg);
+    call system$reset;
+
+end prlcom;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/stpsp.plm

@@ -0,0 +1,107 @@
+$title('MP/M II V2.0 Stop Spooler Program')
+stopsplr:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data (
+    0c3h,
+    .start-3);
+
+  declare fcb (1) byte external;
+  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;
+
+  print$console$buffer:
+    procedure (buff$adr);
+      declare buff$adr address;
+      call mon1 (9,buff$adr);
+    end print$console$buffer;
+
+  system$reset:
+    procedure;
+      call mon1 (0,0);
+    end system$reset;
+
+  console$number:
+    procedure byte;
+      return mon2 (153,0);
+    end console$number;
+
+  abort$process:
+    procedure (abort$pb$adr) byte;
+      declare abort$pb$adr address;
+      return mon2 (157,abort$pb$adr);
+    end abort$process;
+
+  declare abort$param$block structure (
+    pdadr address,
+    param address,
+    pname (8) byte,
+    console byte ) initial (
+    0,00ffh,'SPOOL   ',0);
+
+  declare last$dseg$byte byte
+    initial (0);
+
+
+/*
+  stopsplr:
+*/
+
+start:
+
+  if fcb(1) = ' ' then
+  do;
+    abort$param$block.console = console$number;
+  end;
+  else
+  do;
+    if (fcb(1):=fcb(1)-'0') > 9 then
+    do;
+      fcb(1) = fcb(1) + '0' - 'A' + 10;
+    end;
+    abort$param$block.console = fcb(1);
+  end;
+  if abort$process (.abort$param$block) = 0 then
+  do;
+    do while abort$process (.abort$param$block) = 0;
+      ;
+    end;
+    call print$console$buffer (.(
+           'Spooler aborted','$'));
+  end;
+  else
+  do;
+    call print$console$buffer (.(
+           'Spooler not running','$'));
+  end;
+  call system$reset;
+
+end stopsplr;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/sub.plm

@@ -0,0 +1,511 @@
+$title ('MP/M II V2.0  Submit')
+submit:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare maxb address external;
+  declare fcb (1) byte external;
+  declare fcb16 (1) byte external;
+  declare tbuff (1) byte external;
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  print$console$buffer:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$console$buffer;
+
+  open$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (15,fcb$address);
+    end open$file;
+
+  close$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (16,fcb$address);
+    end close$file;
+
+  delete$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (19,fcb$address);
+    end delete$file;
+
+  read$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (20,fcb$address);
+    end read$record;
+
+  write$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (21,fcb$address);
+    end write$record;
+
+  create$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (22,fcb$address);
+    end create$file;
+
+  set$DMA:
+    procedure (DMA$address);
+      declare DMA$address address;
+      call mon1 (26,DMA$address);
+    end set$DMA;
+
+  getuser:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end getuser;
+
+  read$random:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (33,fcb$address);
+    end read$random;
+
+  compute$file$size:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (35,fcb$address);
+    end compute$file$size;
+
+  /**************************************
+   *                                    *
+   *       X D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  parse$filename:
+    procedure (pfcb$address) address;
+      declare pfcb$address address;
+      return mon2a (152,pfcb$address);
+    end parse$filename;
+
+  get$console$number:
+    procedure byte;
+      return mon2 (153,0);
+    end get$console$number;
+
+  system$data$adr:
+    procedure address;
+      return mon2a (154,0);
+    end system$data$adr;
+
+declare
+    copyright(*) byte data
+        (' Copyright(c) 1981, Digital Research ');
+
+declare subflgadr address;
+declare subflg based subflgadr (1) byte;
+
+declare tmpfiledradr address;
+declare tmpfiledr based tmpfiledradr byte;
+
+declare
+    include$level byte initial (0),
+    cur$console byte,
+    pfcb structure (
+        ASCII$string address,
+        FCB$address address )  initial (
+        .a$buff,
+        .a$sfcb  ),
+    ln(5) byte initial('001 $'),
+    ln1 byte at(.ln(0)),
+    ln2 byte at(.ln(1)),
+    ln3 byte at(.ln(2)),
+    dfcb(33) byte initial(1,'$$$     ','SUB',0),
+    console byte at(.dfcb(2)), /* current console number */
+    drec byte at(.dfcb(32)),  /* current record */
+    a$buff(128) byte at(.tbuff),   /* default buffer */
+    a$sfcb(33)  byte at(.fcb);   /* default fcb */
+
+declare
+    (sfcb$adr,buff$adr,sstring$adr,sbp$adr) address,
+    sfcb based sfcb$adr (33) byte,
+    buff based buff$adr (128) byte,
+    sstring based sstring$adr (128) byte,
+    sbp based sbp$adr byte;
+
+declare
+    source (4) structure (
+        sfcb (36) byte,
+        buff (128) byte,
+        sstring (128) byte,
+        sbp byte  );
+
+    /*  t h e    m p /  m   's u b m i t'   f u n c t i o n
+
+    */
+declare lit literally 'literally',
+    dcl lit 'declare',
+    proc lit 'procedure',
+    addr lit 'address',
+    lca  lit '110$0001b',  /* lower case a */
+    lcz  lit '111$1010b',  /* lower case z */
+    endfile lit '1ah';    /* cp/m end of file */
+
+declare
+    true literally '1',
+    false literally '0',
+    forever literally 'while true',
+    cr literally '13',
+    lf literally '10',
+    what literally '63';
+
+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;
+
+error: procedure(a);
+    declare a address;
+    call print$console$buffer(.(cr,lf,'$'));
+    call print$console$buffer(.('error on line $'));
+    call print$console$buffer(.ln1);
+    call print$console$buffer(a);
+    call terminate;
+    end error;
+
+/*
+declare sstring(128) byte, |* substitute string *|
+    sbp byte;             |* source buffer pointer (0-128) *|
+*/
+
+
+setup$adr: procedure;
+    sfcb$adr = .source(include$level).sfcb;
+    buff$adr = .source(include$level).buff;
+    sstring$adr = .source(include$level).sstring;
+    sbp$adr = .source(include$level).sbp;
+    call set$DMA (.buff);
+    end setup$adr;
+
+setup: procedure;
+    call setup$adr;
+    call move (.a$sfcb,.sfcb,33);
+    call move (.a$buff,.buff,128);
+    subflgadr = system$data$adr + 128;
+    cur$console = get$console$number;
+    console = cur$console + '0';
+    /* move buffer to substitute string */
+    call move(.buff(1),.sstring(0),127);
+    sstring(buff(0))=0; /* mark end of string */
+    call move(.('SUB'),.sfcb(9),3); /* set file type to sub */
+    if open$file(.sfcb(0)) = 255 then
+        call error(.('no ''SUB'' file present$'));
+    /* otherwise file is open - read subsequent data */
+    sbp = 128; /* causes read below */
+    sfcb(32) = 0; /* nr = 0 for sub file to read */
+
+    end setup;
+
+
+getsource: procedure byte;
+    /* read the next source character */
+    declare b byte;
+
+    do forever;
+      do while sbp > 127;
+        if read$record (.sfcb) <> 0 then
+        do;
+          if include$level = 0
+            then return endfile;
+          include$level = include$level - 1;
+          call setup$adr;
+        end;
+        else
+          sbp = 0;
+      end;
+      if (b := buff((sbp:=sbp+1)-1)) = cr then
+          do; /* increment line */
+          if (ln3 := ln3 + 1) > '9' then
+              do; ln3 = '0';
+              if (ln2 := ln2 + 1) > '9' then
+                  do; ln2 = '0';
+                  ln1 = ln1 + 1;
+                  end;
+              end;
+          end;
+    /*
+      |* translate to upper case *|
+      if (b-61h) < 26 then |* lower case alpha *|
+          b = b and 5fh; |* change to upper case *|
+    */
+  
+      if (b <> endfile) or
+         ((b = endfile) and (include$level = 0)) then
+        return b;
+      else
+      do;
+        include$level = include$level - 1;
+        call setup$adr;
+      end;
+    end;
+    end getsource;
+
+writebuff: procedure;
+    /* write the contents of the buffer to disk */
+    if write$record(.dfcb) <> 0 then /* error */
+        call error(.('disk write error$'));
+    end writebuff;
+
+declare rbuff(1) byte at (.minimum$buffer), /* jcl buffer */
+    rbp address,      /* jcl buffer pointer */
+    rlen byte;     /* length of current command */
+
+fillrbuff: procedure;
+    declare (s,ssbp) byte;  /* sub string buffer pointer */
+
+    notend: procedure byte;
+        /* look at next character in sstring, return
+        true if not at the end of the string - char passed
+        back in 's' */
+        if not ((s := sstring(ssbp)) = ' ' or s = 0) then
+            do;
+            ssbp = ssbp + 1;
+            return true;
+            end;
+        return false;
+        end notend;
+
+    deblankparm: procedure;
+        /* clear to next non blank substitute string */
+            do while sstring(ssbp) = ' ';
+            ssbp = ssbp + 1;
+            end;
+        end deblankparm;
+
+    putrbuff: procedure(b);
+       declare b byte;
+        if (rbp := rbp + 1) > (maxb-.rbuff) then
+            call error(.('command buffer overflow$'));
+        rbuff(rbp) = b;
+        /* len: c1 ... c125 :00:$ = 128 chars */
+        if (rlen := rlen + 1) > 125 then
+            call error(.('command too long$'));
+        end putrbuff;
+
+    declare (reading,b,fptr) byte;
+    /* fill the jcl buffer */
+    rbuff(0) = 0ffh;
+    rbp = 0;
+    reading = true;
+        do while reading;
+          rlen = 0; /* reset command length */
+          do while (b:=getsource) <> endfile and b <> cr;
+            if b <> lf then
+            do;
+              if b = '$' then /* copy substitute string */
+              do;
+                if (b:=getsource) = '$' then
+                  /* $$ replaced by $ */
+                  call putrbuff(b);
+                else
+                do;
+                   if (b and 0101$1111b) = 'I' then
+                   do;
+                     /* process include */
+                     if (include$level:=include$level+1) = 4 then
+                       call error (.(
+                         'Exceeding 4 include levels$'));
+                     do while (b:=getsource) <> ' ';
+                     end;
+                     fptr = 0;
+                     b = getsource;
+                     do while (b <> ' ') and
+                              (b <> cr );
+                       a$buff(fptr) = b;
+                       if (fptr:=fptr+1) > 127 then
+                         call error (.(
+                           'Include filename too long$'));
+                       b = getsource;
+                     end;
+                     a$buff(fptr) = '$';
+                     call print$console$buffer (.(cr,lf,'$'));
+                     call print$console$buffer (.('Include $'));
+                     call print$console$buffer (.a$buff);
+                     a$buff(fptr) = cr;
+                     if parse$filename (.pfcb) = 0ffffh then
+                       call error (.(
+                         'Bad include filename$'));
+                     if (a$buff(fptr):=b) <> cr then
+                     do;
+                       fptr = fptr + 1;
+                       b = getsource;
+                       do while b <> cr;
+                         if b = '$' then
+                         do;
+                           b = getsource;
+                           if b <> '$' then
+                           do;
+                             if (b := b - '0') > 9 then
+                               call error (.('parameter error$'));
+                             sstringadr = .source(include$level-1).sstring;
+                             ssbp = 0; call deblankparm;
+                             /* ready to scan sstring */
+                             do while b <> 0; b = b - 1;
+                               /* clear next parameter */
+                               do while notend;
+                               end;
+                               call deblankparm;
+                             end;
+                             /* ready to copy substitute string from
+                                position ssbp */
+                             do while notend;
+                               a$buff(fptr) = s;
+                               fptr = fptr + 1;
+                             end;
+                             fptr = fptr - 1;
+                             sstringadr = .source(include$level).sstring;
+                           end;
+                           else
+                           do;
+                             a$buff(fptr) = b;
+                           end;
+                         end;
+                         else
+                         do;
+                           a$buff(fptr) = b;
+                         end;
+                         if (fptr:=fptr+1) > 127 then
+                           call error (.(
+                             'Include substring too long$'));
+                         b = getsource;
+                       end;
+                     end;
+                     a$buff(0) = fptr - 1;
+                     call setup;
+                   end;
+                   else
+                   do;
+                     if (b := b - '0') > 9 then
+                       call error(.('parameter error$'));
+                     else
+                     do; /* find string 'b' in sstring */
+                       ssbp = 0; call deblankparm;
+                       /* ready to scan sstring */
+                       do while b <> 0; b = b - 1;
+                         /* clear next parameter */
+                         do while notend;
+                         end;
+                         call deblankparm;
+                       end;
+                       /* ready to copy substitute string from
+                          position ssbp */
+                       do while notend;
+                         call putrbuff(s);
+                       end;
+                     end;
+                   end;
+                 end;
+               end;
+               else /* not a '$' */
+               do;
+                 if b = '^' then /* control character */
+                 do; /* must be ^a ... ^z */
+                   if (b:=getsource - 'A') > 25 then
+                     call error(.(
+                        'invalid control character$'));
+                   else
+                     call putrbuff(b+1);
+                 end;
+                 else /* not $ or ^ */
+                   call putrbuff(b);
+               end;
+             end;
+           end; /* of line or input file - compute length */
+           reading = (b=cr);
+           call putrbuff(rlen); /* store length */
+         end;
+    /* entire file has been read and processed */
+    end fillrbuff;
+
+makefile: procedure;
+    /* write resulting command file */
+    declare i byte;
+    getrbuff: procedure byte;
+        return rbuff(rbp := rbp - 1);
+        end getrbuff;
+
+    tmpfiledradr = system$data$adr + 196;
+    dfcb(0) = tmpfiledr;
+    call delete$file(.dfcb);
+    drec = 0; /* zero the next record to write */
+    if create$file(.dfcb) = 255
+        then call error(.('directory full$'));
+        do while (i := getrbuff) <> 0ffh;
+        /* copy i characters to buffer */
+        /* 00 $ at end of line gives 1.3 & 1.4 compatibility */
+        buff(0) = i; buff(i+1) = 00; buff(i+2) = '$';
+            do while i > 0;
+            buff(i) = getrbuff; i=i-1;
+            end;
+        /* buffer filled to $ */
+        call writebuff;
+        end;
+    if close$file(.dfcb) = 255
+      then call error(.('close error$'));
+      else subflg(cur$console) = (getuser or 1111$0000b);
+    end makefile;
+
+declare minimum$buffer (1024) byte;
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    call setup;
+    call fillrbuff;
+    call makefile;
+    call terminate;
+  end;
+end submit;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/tod.plm

@@ -0,0 +1,448 @@
+$title ('MP/M II V2.0 Date and Time')
+tod:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare xdos literally 'mon2a';
+
+  declare fcb (1) byte external;
+  declare fcb16 (1) byte external;
+  declare tbuff (1) byte external;
+
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  write$console:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end write$console;
+
+  print$buffer:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buffer;
+
+  check$console$status:
+    procedure byte;
+      return mon2 (11,0);
+    end check$console$status;
+
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+
+  crlf:
+    procedure;
+      call write$console (0dh);
+      call write$console (0ah);
+    end crlf;
+
+
+/*****************************************************
+
+          Time & Date ASCII Conversion Code
+
+ *****************************************************/
+
+declare tod$adr address;
+declare tod based tod$adr structure (
+  opcode byte,
+  date address,
+  hrs byte,
+  min byte,
+  sec byte,
+  ASCII (21) byte );
+
+declare string$adr address;
+declare string based string$adr (1) byte;
+declare index byte;
+
+declare lit literally 'literally',
+  forever lit 'while 1',
+  word lit 'address';
+
+emitchar: procedure(c);
+    declare c byte;
+    string(index := index + 1) = c;
+    end emitchar;
+
+emitn: procedure(a);
+    declare a address;
+    declare c based a byte;
+    do while c <> '$';
+      string(index := index + 1) = c;
+      a = a + 1;
+    end;
+    end emitn;
+
+
+emit$bcd: procedure(b);
+    declare b byte;
+    call emitchar('0'+b);
+    end emit$bcd;
+
+emit$bcd$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(shr(b,4));
+    call emit$bcd(b and 0fh);
+    end emit$bcd$pair;
+
+emit$colon: procedure(b);
+    declare b byte;
+    call emit$bcd$pair(b);
+    call emitchar(':');
+    end emit$colon;
+
+emit$bin$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(b/10);
+    call emit$bcd(b mod 10);
+    end emit$bin$pair;
+
+emit$slant: procedure(b);
+    declare b byte;
+    call emit$bin$pair(b);
+    call emitchar('/');
+    end emit$slant;
+
+declare chr byte;
+
+gnc: procedure;
+    /* get next command byte */
+    if chr = 0 then return;
+    if index = 20 then
+    do;
+      chr = 0;
+      return;
+    end;
+    chr = string(index := index + 1);
+    end gnc;
+
+deblank: procedure;
+        do while chr = ' ';
+        call gnc;
+        end;
+    end deblank;
+
+numeric: procedure byte;
+    /* test for numeric */
+    return (chr - '0') < 10;
+    end numeric;
+
+scan$numeric: procedure(lb,ub) byte;
+    declare (lb,ub) byte;
+    declare b byte;
+    b = 0;
+    call deblank;
+    if not numeric then go to error;
+        do while numeric;
+        if (b and 1110$0000b) <> 0 then go to error;
+        b = shl(b,3) + shl(b,1); /* b = b * 10 */
+        if carry then go to error;
+        b = b + (chr - '0');
+        if carry then go to error;
+        call gnc;
+        end;
+    if (b < lb) or (b > ub) then go to error;
+    return b;
+    end scan$numeric;
+
+scan$delimiter: procedure(d,lb,ub) byte;
+    declare (d,lb,ub) byte;
+    call deblank;
+    if chr <> d then go to error;
+    call gnc;
+    return scan$numeric(lb,ub);
+    end scan$delimiter;
+
+declare
+    base$year lit '78',   /* base year for computations */
+    base$day  lit '0',    /* starting day for base$year 0..6 */
+    month$size (*) byte data
+    /* jan feb mar apr may jun jul aug sep oct nov dec */
+    (   31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
+    month$days (*) word data
+    /* jan feb mar apr may jun jul aug sep oct nov dec */
+    (  000,031,059,090,120,151,181,212,243,273,304,334);
+
+leap$days: procedure(y,m) byte;
+    declare (y,m) byte;
+    /* compute days accumulated by leap years */
+    declare yp byte;
+    yp = shr(y,2); /* yp = y/4 */
+    if (y and 11b) = 0 and month$days(m) < 59 then
+        /* y not 00, y mod 4 = 0, before march, so not leap yr */
+        return yp - 1;
+    /* otherwise, yp is the number of accumulated leap days */
+    return yp;
+    end leap$days;
+
+declare word$value word;
+
+get$next$digit: procedure byte;
+    /* get next lsd from word$value */
+    declare lsd byte;
+    lsd = word$value mod 10;
+    word$value = word$value / 10;
+    return lsd;
+    end get$next$digit;
+
+bcd:
+  procedure (val) byte;
+    declare val byte;
+    return shl((val/10),4) + val mod 10;
+  end bcd;
+
+declare (month, day, year, hrs, min, sec) byte;
+
+set$date$time: procedure;
+    declare
+        (i, leap$flag) byte; /* temporaries */
+    month = scan$numeric(1,12) - 1;
+    /* may be feb 29 */
+    if (leap$flag := month = 1) then i = 29;
+        else i = month$size(month);
+    day   = scan$delimiter('/',1,i);
+    year  = scan$delimiter('/',base$year,99);
+    /* ensure that feb 29 is in a leap year */
+    if leap$flag and day = 29 and (year and 11b) <> 0 then
+        /* feb 29 of non-leap year */ go to error;
+    /* compute total days */
+     tod.date = month$days(month)
+                + 365 * (year - base$year)
+                + day
+                - leap$days(base$year,0)
+                + leap$days(year,month);
+
+    tod.hrs   = bcd (scan$numeric(0,23));
+    tod.min   = bcd (scan$delimiter(':',0,59));
+    if tod.opcode = 2 then
+    /* date, hours and minutes only */
+    do;
+      if chr = ':'
+        then i = scan$delimiter (':',0,59);
+      tod.sec = 0;
+    end;
+    /* include seconds */
+    else tod.sec   = bcd (scan$delimiter(':',0,59));
+
+    end set$date$time;
+
+bcd$pair: procedure(a,b) byte;
+    declare (a,b) byte;
+    return shl(a,4) or b;
+    end bcd$pair;
+
+
+compute$year: procedure;
+    /* compute year from number of days in word$value */
+    declare year$length word;
+    year = base$year;
+        do forever;
+        year$length = 365;
+        if (year and 11b) = 0 then /* leap year */
+            year$length = 366;
+        if word$value <= year$length then
+            return;
+        word$value = word$value - year$length;
+        year = year + 1;
+        end;
+    end compute$year;
+
+declare
+    week$day  byte, /* day of week 0 ... 6 */
+    day$list (*) byte data
+    ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
+    leap$bias byte; /* bias for feb 29 */
+
+compute$month: procedure;
+    month = 12;
+        do while month > 0;
+        if (month := month - 1) < 2 then /* jan or feb */
+            leapbias = 0;
+        if month$days(month) + leap$bias < word$value then return;
+        end;
+    end compute$month;
+
+declare
+    date$test byte,    /* true if testing date */
+    test$value word;   /* sequential date value under test */
+
+get$date$time: procedure;
+    /* get date and time */
+    hrs = tod.hrs;
+    min = tod.min;
+    sec = tod.sec;
+    word$value = tod.date;
+    /* word$value contains total number of days */
+    week$day = (word$value + base$day - 1) mod 7;
+    call compute$year;
+    /* year has been set, word$value is remainder */
+    leap$bias = 0;
+    if (year and 11b) = 0 and word$value > 59 then
+        /* after feb 29 on leap year */ leap$bias = 1;
+    call compute$month;
+    day = word$value - (month$days(month) + leap$bias);
+    month = month + 1;
+    end get$date$time;
+
+emit$date$time: procedure;
+    call emitn(.day$list(shl(week$day,2)));
+    call emitchar(' ');
+    call emit$slant(month);
+    call emit$slant(day);
+    call emit$bin$pair(year);
+    call emitchar(' ');
+    call emit$colon(hrs);
+    call emit$colon(min);
+    call emit$bcd$pair(sec);
+    end emit$date$time;
+
+tod$ASCII:
+  procedure (parameter);
+    declare parameter address;
+    declare ret address;
+
+    ret = 0;
+    tod$adr = parameter;
+    string$adr = .tod.ASCII;
+    if tod.opcode = 0 then
+    do;
+      call get$date$time;
+      index = -1;
+      call emit$date$time;
+    end;
+    else
+    do;
+      if (tod.opcode = 1) or
+         (tod.opcode = 2) then
+      do;
+        chr = string(index:=0);
+        call set$date$time;
+        ret = .string(index);
+      end;
+      else
+      do;
+        go to error;
+      end;
+    end;
+  end tod$ASCII;
+
+/********************************************************
+ ********************************************************/
+
+
+  declare lcltod structure (
+    opcode byte,
+    date address,
+    hrs byte,
+    min byte,
+    sec byte,
+    ASCII (21) byte );
+
+  declare datapgadr address;
+  declare datapg based datapgadr address;
+
+  declare extrnl$todadr address;
+  declare extrnl$tod based extrnl$todadr structure (
+    date address,
+    hrs byte,
+    min byte,
+    sec byte );
+
+  declare i byte;
+  declare ret address;
+
+  display$tod:
+    procedure;
+
+      lcltod.opcode = 0; /* read tod */
+      call move (5,.extrnl$tod.date,.lcltod.date);
+      call tod$ASCII (.lcltod);
+      call write$console (0dh);
+      do i = 0 to 20;
+        call write$console (lcltod.ASCII(i));
+      end;
+    end display$tod;
+
+
+  /*
+    Main Program
+  */
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    datapgadr = xdos (154,0) + 252;
+    extrnl$todadr = datapg;
+    if (fcb(1) <> ' ') and (fcb(1) <> 'P') then
+    do;
+      call move (21,.tbuff(1),.lcltod.ASCII);
+      lcltod.opcode = 1;
+      call tod$ASCII (.lcltod);
+      call print$buffer (.(
+        'Strike key to set time','$'));
+      ret = read$console;
+      call move (5,.lcltod.date,.extrnl$tod.date);
+      call crlf;
+    end;
+    do while fcb(1) = 'P';
+      call display$tod;
+      if check$console$status then
+      do;
+        ret = read$console;
+        fcb(1) = 0;
+      end;
+    end;
+    call display$tod;
+    call terminate;
+  end;
+
+error:
+  do;
+    call print$buffer (.(
+      'Illegal time/date specification.','$'));
+    call terminate;
+  end;
+
+end tod;

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/user.plm

@@ -0,0 +1,179 @@
+$title('MP/M II V2.0 User Number Assign/Display')
+user:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    14 Sept 81  by Thomas Rolander
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0c3h,.start-3);
+
+$include (proces.lit)
+
+
+/*
+    Common Literals
+*/
+
+  declare true literally '0FFFFH';
+  declare false literally '0';
+  declare forever literally 'while true';
+  declare boolean literally 'byte';
+
+  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;
+
+  mon2a:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon2a;
+
+  declare xdos literally 'mon2';
+  declare xdosa literally 'mon2a';
+
+  declare fcb (1) byte external;
+
+  print$buffer:
+    procedure (bufferadr);
+      declare bufferadr address;
+      call mon1 (9,bufferadr);
+    end print$buffer;
+
+  who$user:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end who$user;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  who$con:
+    procedure byte;
+      return xdos (153,0);
+    end who$con;
+
+  sys$dat$adr:
+    procedure address;
+      return xdosa (154,0);
+    end sys$dat$adr;
+
+  ASCII$to$int:
+    procedure (string$adr) byte;
+      declare string$adr address;
+      declare string based string$adr (1) byte;
+
+        if (string(0) := string(0) - '0') < 10 then
+        do;
+          if string(1) <> ' '
+            then return string(0)*10 + (string(1)-'0');
+            else return string(0);
+        end;
+        return 254;
+    end ASCII$to$int;
+
+  int$to$ASCII:
+    procedure (string$adr);
+      declare string$adr address;
+      declare string based string$adr (1) byte;
+
+        if string(0) < 10 then
+        do;
+          string(0) = string(0) + '0';
+          string(1) = ' ';
+        end;
+        else
+        do;
+          string(1) = (string(0)-10) + '0';
+          string(0) = '1';
+        end;
+    end int$to$ASCII;
+
+  declare datapgadr address;
+  declare datapg based datapgadr address;
+
+  declare thread$root$adr address;
+  declare thread$root based thread$root$adr address;
+
+  declare TMPx (8) byte
+    initial ('Tmpx    ');
+  declare console byte at (.TMPx(3));
+
+  declare msg1 (*) byte
+    initial ('User Number = ');
+  declare msg2 (5) byte
+    initial ('xx',0dh,0ah,'$');
+  declare user$nmb byte at (.msg2(0));
+
+  declare pdadr address;
+  declare pd based pdadr Process$descriptor;
+
+  declare i byte;
+
+  /*
+     User Main Program
+  */
+
+  start:
+    if fcb(1) = ' ' then
+    /* displaying user number */
+    do;
+      user$nmb = who$user;
+    end;
+    else
+    /* assigning user number */
+    do;
+      if (user$nmb := ASCII$to$int(.fcb(1))) < 16 then
+      do;
+        console = who$con + '0';
+        datapgadr = sys$dat$adr + 252;
+        datapgadr = datapg;
+        thread$root$adr = datapgadr + 17;
+        pdadr = thread$root;
+        do while pdadr <> 0;
+          i = 0;
+          do while (i <> 8) and ((pd.name(i) and 7fh) = TMPx(i));
+            i = i + 1;
+          end;
+          if i = 8 then
+          do;
+            pd.diskslct = (pd.diskslct and 0F0h) or user$nmb;
+            pdadr = 0;
+          end;
+          else
+          do;
+            pdadr = pd.thread;
+          end;
+        end;
+      end;
+      else
+      /* invalid user number entry */
+      do;
+        user$nmb = who$user;
+        call print$buffer (.(
+          'Invalid user number, ignored',0dh,0ah,'$'));
+      end;
+    end;
+    call int$to$ASCII (.usernmb);
+    call print$buffer (.msg1);
+    call terminate;
+
+end user;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_3/comgen.sub

@@ -0,0 +1,21 @@
+;era *.lst
+;era *.lin
+;era *.sym
+;era *.bak
+;pip a:=$1.plm[g2]
+;seteof $1.plm
+;isx
+;plm80 $1.plm debug
+;cpm
+;vax $1.lst $$stan
+;era $1.lst
+isx
+link $1.obj,x0100,plm80.lib to x$1.mod
+locate x$1.mod code(0100H) stacksize(48)
+era x$1.mod
+cpm
+objcpm x$1
+era x$1
+vax x$1.sym $$stan
+vax x$1.lin $$stan
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_3/genhex.asm

@@ -0,0 +1,388 @@
+	TITLE	'GENERATE HEX FILE FROM COM FILE 9/81'
+;	HEX DUMP PROGRAM, READS AN INPUT FILE AND PRODUCES A HEX FILE
+;
+;	COPYRIGHT (C), DIGITAL RESEARCH, 1976, 1977, 1978, 1979, 1980, 1981
+;	BOX 579 PACIFIC GROVE, CALIFORNIA
+;
+;
+;	Revised:
+;	  14 Sept 81  by Thomas Rolander
+;
+	ORG	100H
+	LXI	SP,STKTOP
+	JMP	MAIN
+	DB	' COPYRIGHT (C) DIGITAL RESEARCH '
+BOOT	EQU	0000H	;REBOOT POINT
+BDOS	EQU	0005H	;DOS ENTRY POINT
+CONS	EQU	1	;READ CONSOLE
+TYPEF	EQU	2	;TYPE FUNCTION
+PRNTF	EQU	9	;PRINT BUFFER
+OPENF	EQU	15	;FILE OPEN
+CLOSF	EQU	16	;FILE CLOSE
+DELF	EQU	19	;FILE DELETE
+READF	EQU	20	;READ FUNCTION
+WRITF	EQU	21	;WRITE RECORD
+MAKEF	EQU	22	;MAKE FILE
+DMAF	EQU	26	;SET DMA ADDRESS
+;
+FCB	EQU	5CH	;FILE CONTROL BLOCK ADDRESS
+BUFF	EQU	80H	;INPUT DISK BUFFER ADDRESS
+CR	EQU	0DH
+LF	EQU	0AH
+EOF	EQU	1AH	;END OF FILE (CTL-Z)
+;
+;	SET UP STACK
+;	STACK AREA
+STACK:	DS	64
+STKTOP	EQU	$
+;
+;	SUBROUTINES
+;
+;
+GETBASE:
+;	READ THE OFFSET FROM THE SECOND PARAMETER
+	LXI	H,FCB+17
+	LXI	D,0
+	MVI	B,8	;MAX 8 DIGITS
+GET0:	MOV	A,M
+	CPI	' '
+	JZ	ENDGET
+	SUI	'0'
+	CPI	10
+	JC	GET1
+;	MUST BE HEX A-F
+	ADI	('0'-'A'+10) AND 0FFH
+	CPI	16
+	JNC	BADGET
+GET1:	;NEXT DIGIT IS IN A
+	XCHG
+	DAD	H	;*2
+	DAD	H	;*4
+	DAD	H	;*8
+	DAD	H	;*16
+	ADD	L
+	MOV	L,A
+	XCHG
+	INX	H	;TO NEXT POSITION
+	DCR	B
+	JNZ	GET0
+;
+ENDGET:
+	XCHG
+	SHLD	OFFSET
+	RET
+;
+BADGET:
+	LXI	D,GETMSG
+	CALL	PRINT
+	JMP	BOOT
+;
+GETMSG:
+	DB	CR,LF,'BAD HEX DIGIT IN BASE$'
+;
+PRINT:	;PRINT A BUFFER
+	MVI	C,PRNTF
+	CALL	BDOS
+	RET
+;
+PCHAR:	;SEND CHAR TO OUTPUT FILE
+	PUSH	H
+	PUSH	D
+	LXI	H,OBP	;BUFFER POINTER
+	PUSH	H	;SAVE FOR LATER
+	MOV	E,M	;LO BYTE
+	MVI	D,0
+	LXI	H,BUFF
+	DAD	D	;BUFF(OBP) IN H,L
+	MOV	M,A	;STORE CHARACTER TO BUFFER
+	POP	H	;RECALL OBP ADDRESS
+	INR	M	;OBP=OBP+1
+	MOV	A,M	;PAST END OF BUFFER?
+	CPI	128
+	JC	EPCHAR
+;	WRITE THE BUFFER TO THE DISK FILE
+	MVI	M,0	;CLEARS OBP
+	PUSH	B	;SAVE ENVIRONMENT
+	MVI	C,WRITF
+	LXI	D,FCB
+	CALL	BDOS
+	ORA	A	;ERROR?
+	JNZ	BADPR
+;	NO ERROR, RETURN TO CALLER
+	POP	B
+EPCHAR:	POP	D
+	POP	H
+	RET
+;
+BADPR:	;BAD WRITE
+	MVI	C,CLOSF
+	LXI	D,FCB
+	CALL	BDOS	;TRY TO CLOSE THE FILE
+	LXI	D,PRMSG
+	CALL	PRINT
+	JMP	BOOT
+PRMSG:	DB	CR,LF,'DISK IS FULL$'
+;
+CRLF:
+	MVI	A,CR
+	CALL	PCHAR
+	MVI	A,LF
+	CALL	PCHAR
+	RET
+;
+;
+PNIB:	;PRINT NIBBLE IN REG A
+	ANI	0FH	;LOW 4 BITS
+	CPI	10
+	JNC	P10
+;	LESS THAN OR EQUAL TO 9
+	ADI	'0'
+	JMP	PRN
+;
+;	GREATER OR EQUAL TO 10
+P10:	ADI	'A' - 10
+PRN:	CALL	PCHAR
+	RET
+;
+MAIN:	; READ AND PROCESS SUCCESSIVE BUFFERS
+	CALL	GETBASE	;GET BASE ADDRESS FOR DUMP
+	CALL	SETUP	;SET UP INPUT FILE
+;	LOAD COM FILE TO MEMORY
+	LXI	D,IBUFF
+LOAD:	;READ DISK RECORD TO MEMORY
+	PUSH	D	;SAVE DMA ADDRESS
+	MVI	C,DMAF
+	CALL	BDOS	;DMA SET
+	LXI	D,FCB
+	MVI	C,READF
+	CALL	BDOS
+	POP	D
+	ORA	A
+	JNZ	FINIS
+	LXI	H,128
+	DAD	D
+	XCHG
+	JMP	LOAD	;FOR ANOTHER RECORD
+;
+FINIS:
+	DCR	A	;EOF=1
+	JZ	BUILDHEX
+	LXI	D,RERR
+	CALL	PRINT	;BAD DISK READ
+	JMP	BOOT
+;
+BUILDHEX:
+;BUILD HEX FILE FROM IBUFF THROUGH EBUFF
+	PUSH	D
+	CALL	SETHEX	;SET UP HEX FILE
+	POP	D
+	DCX	D	;LAST ADDRESS
+	LXI	H,IBUFF	;D,E HOLDS HIGH ADDRESS, H,L HOLDS LOW ADDRESS
+W0:	MOV	A,L	;GET LOW/NEXT ADDRESS
+	ADI	16	;COMPUTE NEXT ADDRESS
+	MOV	C,A	;SAVE TEMP IN B,C
+	MOV	A,H
+	ACI	0
+	MOV	B,A	;LOW ADDRESS+16 IN B,C
+	MOV	A,E	;COMPARE HIGH ADDRESS
+	SUB	C
+	MOV	C,A	;SAVE DIFFERENCE
+	MOV	A,D
+	SBB	B
+	JC	W1	;'CAUSE LESS THAN 16
+;	OTHERWISE 16 BYTE RECORD
+	MVI	A,16
+	JMP	W2
+;
+W1:	;SHORT RECORD
+	MOV	A,C	;-DIFF
+	ADI	17	;MAKE IT POSITIVE
+W2:	;CHECK FOR LAST RECORD
+	ORA	A
+	JZ	HDONE	;IF LAST
+;	OTHERWISE WRITE RECORD
+	PUSH	D	;SAVE HIGH ADDRESS
+	MOV	E,A	;SAVE LENGTH
+	MVI	D,0	;CLEAR CS
+	CALL	CRLF	;WRITE CRLF
+	MVI	A,':'
+	CALL	PCHAR
+	MOV	A,E	;LENGTH
+	CALL	WRC	;WRITE CHARACTER
+;	APPLY OFFSET TO BASE ADDRESS
+	PUSH	H
+	PUSH	D
+	XCHG		;ABSOLUTE ADDRESS TO D,E
+	LXI	H,-IBUFF
+	DAD	D	;ABSOLUTE-IBUFF TO H,L
+	XCHG
+	LHLD	OFFSET
+	DAD	D	;ABSOLUTE-IBUFF+OFFSET
+	POP	D
+	MOV	A,H	;HO ADDRESS
+	CALL	WRC
+	MOV	A,L	;LO ADDRESS
+	CALL	WRC
+	POP	H	;ABSOLUTE ADDRESS
+	XRA	A
+	CALL	WRC	;RECORD TYPE
+;
+;	WRITE RECORD
+W3:	MOV	A,M
+	INX	H
+	CALL	WRC
+	DCR	E
+	JNZ	W3	;FOR MORE
+;
+	XRA	A	;COMPUTE CHECKSUM
+	SUB	D
+	CALL	WRC
+	POP	D	;RESTORE HIGH ADDR
+	JMP	W0
+;
+WRC:	;WRITE CHAR WITH CHECK SUM IN D
+	PUSH	PSW
+	RRC
+	RRC
+	RRC
+	RRC
+	ANI	0FH
+	CALL	PNIB
+	POP	PSW
+	PUSH	PSW
+	ANI	0FH
+	CALL	PNIB
+	POP	PSW
+	ADD	D
+	MOV	D,A
+	RET
+;
+HDONE:
+;	FINISH BUFFER OUTPUT
+	CALL	CRLF
+	MVI	A,':'
+	CALL	PCHAR
+	MVI	B,8
+ZLOOP:	;SEND 8 ZEROES TO OUTPUT
+	XRA	A
+	CALL	WRC
+	DCR	B
+	JNZ	ZLOOP
+;
+	CALL	CRLF
+;
+;	FILL OUTPUT WITH END OF FILE CHARACTERS
+FILLE:	LDA	OBP
+	ORA	A
+	JZ	EFILL	;WRITE 'TIL ZERO POINTER
+	MVI	A,EOF
+	CALL	PCHAR
+	JMP	FILLE
+;	CLEARED, NOW CLOSE THE FILE
+EFILL:	MVI	C,CLOSF
+	LXI	D,FCB
+	CALL	BDOS
+	CPI	255
+	JZ	BADCLOSE
+	LXI	D,ENDMSG
+	CALL	PRINT
+	JMP	BOOT
+ENDMSG:	DB	CR,LF,'HEX FILE WRITTEN$'
+;
+BADCLOSE:
+;	CANNOT CLOSE THE FILE
+	LXI	D,CLMSG
+	CALL	PRINT
+	JMP	BOOT
+CLMSG:	DB	CR,LF,'CANNOT CLOSE FILE, CHECK WRITE PROTECT$'
+;
+;	FILE CONTROL BLOCK DEFINITIONS
+FCBDN	EQU	FCB+0	;DISK NAME
+FCBFN	EQU	FCB+1	;FILE NAME
+FCBFT	EQU	FCB+9	;DISK FILE TYPE (3 CHARACTERS)
+FCBRL	EQU	FCB+12	;FILE'S CURRENT REEL NUMBER
+FCBRC	EQU	FCB+15	;FILE'S RECORD COUNT (0 TO 128)
+FCBCR	EQU	FCB+32	;CURRENT (NEXT) RECORD NUMBER (0 TO 127)
+FCBLN	EQU	FCB+33	;FCB LENGTH
+;
+;
+FILLTYPE:
+;	SET THE TYPE FIELD FOR THE CURRENT FCB TO VALUE AT D,E
+	LXI	H,FCBFT
+	MVI	B,3
+FILL0:	LDAX	D
+	INX	D
+	MOV	M,A
+	INX	H
+	DCR	B
+	JNZ	FILL0
+;	mvi	m,0	;*** Bug fix: zeroes the extent
+	RET
+;
+SETUP:	;SET UP FILE 
+	LXI	D,COMTYPE
+	CALL	FILLTYPE
+;	OPEN THE FILE FOR INPUT
+	LXI	D,FCB
+	MVI	C,OPENF
+	CALL	BDOS
+;	CHECK FOR ERRORS
+	CPI	255
+	JNZ	OPNOK
+	LXI	D,OPERR
+	CALL	PRINT
+	JMP	BOOT
+OPERR:	DB	CR,LF,'NO INPUT FILE PRESENT$'
+COMTYPE:
+	DB	'COM'
+;
+SETHEX:
+;	SET UP HEX FILE
+	XRA	A
+	STA	OBP	;OUTPUT POINTER SET TO BEGINNING
+	LXI	D,BUFF
+	MVI	C,DMAF	;RESET DMA ADDRESS
+	CALL	BDOS
+;
+	LXI	D,HEXTYPE
+;	CALL	FILLTYPE	;SET TO .HEX
+	call	patch	;*** bug fix ***
+	LXI	D,FCB
+	PUSH	D
+	MVI	C,DELF		;DELETE OLD COPIES
+	CALL	BDOS
+	POP	D
+	MVI	C,MAKEF		;MAKE A NEW ONE
+	CALL	BDOS
+	CPI	255
+	JNZ	OPNOK
+;
+;	CANNOT CREATE THE FILE
+	LXI	D,NOSPACE
+	CALL	PRINT
+	JMP	BOOT
+NOSPACE:
+	DB	CR,LF,'NO DIRECTORY SPACE$'
+HEXTYPE:
+	DB	'HEX'
+;
+OPNOK:	;OPEN IS OK.
+	XRA	A
+	STA	FCBCR
+	RET
+;
+RERR:	DB	CR,LF,'DISK READ ERROR$'
+;
+OBP	DS	1	;OUTPUT BUFFER POINTER
+OFFSET	DS	2	;DISPLACEMENT TO ADD IN HEX TAPE
+
+	ds	3
+patch:
+	call	filltype
+	mvi	a,0
+	sta	fcb+0ch
+	ret
+
+IBUFF	EQU	($ AND 0FF00H)+100H
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_3/genmod.asm

@@ -0,0 +1,674 @@
+	TITLE	'GENMOD - MP/M RELOCATABLE MODULE GENERATOR 9/81'
+;	RELOCATING LOADER PROGRAM WITH MODULE GENERATION
+;
+;	COPYRIGHT (C) 1979, 1980, 1981
+;	DIGITAL RESEARCH
+;	BOX 579, PACIFIC GROVE
+;	CALIFORNIA, 93950
+;
+;
+;	Revised:
+;	  14 Sept 81  by Thomas Rolander
+
+	ORG	000H	;BASE OF RELOCATABLE SEGMENT
+BASE	EQU	$
+
+	ORG	100H	;BASE OF MP/M PROGRAM AREA
+	JMP	START
+
+	DB	' COPYRIGHT (C) 1980, DIGITAL RESEARCH '
+;
+STKSIZ	EQU	64	;32 LEVEL WORKING STACK
+;
+;	MISCELLANEOUS ADDRESS CONSTANTS
+BOOT	EQU	BASE+0		;SYSTEM REBOOT
+BDOS	EQU	BASE+5		;DOS ENTRY POINT
+TOP	EQU	BASE+6		;CONTAINS TOP OF MEMORY
+DFCB	EQU	BASE+5CH	;DEFAULT FILE CONTROL BLOCK
+DBF	EQU	BASE+80H	;DEFAULT BUFFER
+RWORK	EQU	BASE+700H	;BASE OF RELOCATION WORK AREA
+RMOD	EQU	BASE+600H	;MODULE RELOCATOR BASE
+RSIZE	EQU	RMOD+1		;MODULE SIZE FIELD
+DSIZE	EQU	RMOD+4		;DATA SIZE FIELD
+;
+;	BDOS ENTRY FUNCTIONS
+CONOF	EQU	2	;CONSOLE OUTPUT
+OPF	EQU	15	;FILE OPEN FUNCTION
+CLF	EQU	16	;FILE CLOSE FUNCTION
+DLF	EQU	19	;FILE DELETE FUNCTION
+RDF	EQU	20	;READ DISK
+WRF	EQU	21	;WRITE DISK
+MKF	EQU	22	;MAKE FILE
+PRF	EQU	9	;PRINT BUFFER
+DMF	EQU	26	;SET DMA ADDRESS
+;
+;	NON GRAPHIC CHARACTERS
+CR	EQU	0DH	;CARRIAGE RETURN
+LF	EQU	0AH	;LINE FEED
+DEOF	EQU	1AH	;END OF FILE
+;
+START:
+	LXI	SP,STACK
+;
+	CALL	SETUP	;SET UP FILES
+	XRA	A	;ZERO IN ACCUM
+	STA	PASS	;PASS = 0
+	LXI	H,0
+	SHLD	HLOC	;HLOC = 0
+	CALL	HREAD
+	LHLD	HLOC	;HIGH ADDRESS TO H,L
+	INX	H	;+1
+	PUSH	H
+;	CLEAR THE RELOCATION BIT MAP
+	CALL	FINDBYTE	;HLOC+1 IS TRANSLATED TO AN ABS ADDR
+;	MOVE H,L TO NEXT PARAGRAPH BOUNDARY
+ADJ0:	MOV	A,L
+	ANI	7FH
+	JZ	ADJ1
+	INX	H	;TO NEXT ADDRESS
+	JMP	ADJ0
+ADJ1:	DCX	H
+	SHLD	LBYTE	;LAST BYTE TO WRITE
+	XCHG			;LAST BYTE TO ZERO IS IN D,E
+	POP	H		;RECALL HLOC+1
+;	CLEAR ALL BYTES FROM H,L THROUGH D,E
+CLER0:	MOV	A,E
+	SUB	L
+	MOV	A,D
+	SBB	H
+	JC	CLER1
+	MVI	M,0	;CLEAR ANOTHER BYTE
+	INX	H
+	JMP	CLER0
+CLER1:	;BIT VECTOR CLEARED
+;	THE RELOCATION BIT VECTOR IS BUILT DURING THE SECOND PASS
+	LXI	H,PASS
+	INR	M	;PASS = 1
+	CALL	HREAD
+;	BIT VECTOR BUILT, WRITE THE MODULE
+	CALL	TERMINATE
+	LXI	D,OKMSG	;OPERATION COMPLETE
+	CALL	PRINT
+	JMP	FINIS
+OKMSG:	DB	CR,LF,'MODULE CONSTRUCTED$'
+;
+;	UTILITY SUBROUTINES
+;
+HREAD:	;HEX FORMAT READ SUBROUTINE
+;	INPUT RECORDS TAKE THE FORM:
+;	:NNLLLLTTD1D2D3...DNCC
+;	WHERE -
+;		NN	IS THE RECORD LENGTH (00-FF)
+;		LLLL	IS THE LOAD ADDRESS (0000-FFFF)
+;		TT	IS THE RECORD TYPE (ALWAYS 00)
+;		D1-DN	ARE THE DATA BYTES
+;		CC	IS THE CHECKSUM
+;	THE LAST RECORD HAS A LENGTH OF ZERO, AND LLLL IS THE
+;	STARTING ADDRESS FOR THE MODULE (IGNORED HERE)
+;
+	CALL	DISKR	;NEXT INPUT CHARACTER TO ACCUM
+	CPI	DEOF	;PAST END OF TAPE?
+	JZ	CERROR
+	SBI	':'
+	JNZ	HREAD	;LOOKING FOR START OF RECORD
+;
+;	START FOUND, CLEAR CHECKSUM
+	MOV	D,A
+	CALL	RBYTE
+	MOV	E,A	;SAVE LENGTH
+	CALL	RBYTE	;HIGH ORDER ADDR
+	PUSH	PSW
+	CALL	RBYTE	;LOW ORDER ADDR
+	POP	B	;HIGH ORDER ADDRESS TO B
+	MOV	C,A	;LOW ORDER ADDRESS TO C
+	LDA	BBOOL
+	ORA	A
+	JNZ	HVBIAS
+	MVI	A,0FFH
+	STA	BBOOL
+	MVI	A,LOW(RWORK)
+	SUB	C
+	MOV	L,A
+	MVI	A,HIGH(RWORK)
+	SBB	B
+	MOV	H,A
+	SHLD	BRWRK	;BRWRK = RWORK-BIAS
+	MOV	A,C
+	SUI	LOW(RWORK)
+	MOV	L,A
+	MOV	A,B
+	SBI	HIGH(RWORK)
+	MOV	H,A
+	SHLD	NBRWRK	;NBRWRK = BIAS-RWORK
+HVBIAS:
+	LHLD	BRWRK	;ADDRESS INTO WORK AREA (BIASED)
+	DAD	B	;BIAS ADDRESS IN H,L
+;
+;	IF ON SECOND PASS, THEN ADDRESSES ARE OFF BY ONE PAGE
+	LDA	PASS
+	ORA	A
+	JZ	CHKLEN
+;	SECOND PASS, DECREMENT ADDRESS TO PREVIOUS PAGE
+	DCR	H
+CHKLEN:
+;	CHECK THE LENGTH FIELD FOR END OF HEX FILE
+	MOV	A,E	;CHECK FOR LAST RECORD
+	ORA	A
+	JNZ	RDTYPE
+;	END OF HEX INPUT
+	RET
+;
+RDTYPE:
+	CALL	RBYTE	;RECORD TYPE = 0
+;
+;	LOAD THE RECORD ON PASS 0, SET REL BITS ON PASS 1
+RED1:	CALL	RBYTE
+	MOV	B,A	;SAVE DATA BYTE FOR COMPARE
+	LDA	PASS
+	ORA	A
+	JNZ	COMP	;COMPARE ON PASS 1
+;
+;	PASS 0, STORE DATA BYTE TO MEMORY
+	XCHG		;COMPARE WITH MEMORY TOP ADDRESS
+	PUSH	H
+	LHLD	TOP
+	MOV	A,D
+	SUB	H
+	JC	SIZEOK
+	JNZ	SZERR
+	MOV	A,E
+	SUB	L
+	JNC	SZERR
+SIZEOK:
+	POP	H
+	XCHG
+	MOV	M,B
+;	COMPUTE HIGH ADDRESS
+	PUSH	H
+	PUSH	D
+	XCHG		;CURRENT ADDRESS TO H,L
+	LHLD	HLOC	;CURRENT HIGH LOCATION
+	MOV	A,L
+	SUB	E
+	MOV	A,H
+	SBB	D
+	POP	D
+	POP	H
+	JNC	RED2	;NO CARRY IF HLOC HIGH
+	SHLD	HLOC	;NEW HLOC OTHERWISE
+	JMP	RED2
+;
+COMP:	;PASS 1, COMPUTE RELOCATION BITS
+	MOV	C,M	;GET DATA FROM MEMORY
+	MOV	A,B
+	ora	a
+	jnz	comp1	; jump if non-zero byte
+	lda	igz
+	ora	a
+	jnz	red2	; jump if ignoring zeroes on pass 1
+	mov	a,b
+comp1:
+	SUB	C	;DIFFERENT?
+	JZ	RED2	;SKIP IF SAME DATA
+	PUSH	D
+	PUSH	H
+;	DIFFERENT, MUST BE BY 1
+	CPI	1
+	JZ	RELOK	;OK TO RELOCATE
+	CPI	-1	; OR BY -1
+	JZ	RELOK	;ALSO OK TO RELOCATE
+;	PRINT ERROR IN FORM -
+;	REL ERROR AT XXXX IMAGE X
+	LXI	D,RELMSG
+	CALL	PRINT
+	POP	D	;ADDRESS
+	PUSH	D
+	LHLD	NBRWRK	;BIASED ADDRESS
+	DAD	D	;REAL ADDRESS TO HL
+	CALL	PADDR	;ADDRESS PRINTED
+	POP	H
+	PUSH	H	;HL READY FOR SETBIT
+	JMP	RELOK
+;
+;	INLINE  RELOCATION ERROR MESSAGE
+RELMSG:	DB	CR,LF,'RELOC ERROR AT $'
+;
+RELOK:	CALL	SETBIT	;RELOCATION BIT SET/RESET
+	POP	H
+	POP	D
+RED2:	INX	H
+	DCR	E
+	JNZ	RED1	;FOR ANOTHER BYTE
+;	OTHERWISE AT END OF RECORD - CHECKSUM
+	CALL	RBYTE
+	JNZ	CERROR
+	JMP	HREAD	;FOR ANOTHER RECORD
+;
+RBYTE:	;READ ONE BYTE FROM BUFF AT WBP TO REG-A
+;	COMPUTE CHECKSUM IN REG-D
+	PUSH	B
+	PUSH	H
+	PUSH	D
+;
+	CALL	DISKR	;GET ONE MORE CHARACTER
+	CALL	HEXCON	;CONVERT TO HEX (OR ERROR)
+;
+;	SHIFT LEFT AND MASK
+	RLC
+	RLC
+	RLC
+	RLC
+	ANI	0F0H
+	PUSH	PSW	;SAVE FOR A FEW STEPS
+	CALL	DISKR
+	CALL	HEXCON
+;
+;	OTHERWISE SECOND NIBBLE OK, SO MERGE
+	POP	B	;PREVIOUS NIBBLE TO REG-B
+	ORA	B
+	MOV	B,A	;VALUE IS NOW IN B TEMPORARILY
+	POP	D	;CHECKSUM
+	ADD	D	;ACCUMULATING
+	MOV	D,A	;BACK TO CS
+;	ZERO FLAG REMAINS SET
+	MOV	A,B	;BRING BYTE BACK TO ACCUMULATOR
+	POP	H
+	POP	B	;BACK TO INITIAL STATE WITH ACCUM SET
+	RET
+REND:
+	;NORMAL END OF LOAD
+	RET
+;
+;
+DISKR:	;DISK READ
+	PUSH	H
+	PUSH	D
+	PUSH	B
+;
+RDI:	;READ DISK INPUT
+	LDA	DBP
+	ANI	7FH
+	JZ	NDI	;GET NEXT DISK INPUT RECORD
+;
+;	READ CHARACTER
+RDC:
+	MVI	D,0
+	MOV	E,A
+	LXI	H,DBF
+	DAD	D
+	MOV	A,M
+	CPI	DEOF
+	JZ	RRET	;END OF FILE
+	LXI	H,DBP
+	INR	M
+	JMP	RRET
+;
+NDI:	;NEXT BUFFER IN
+	MVI	C,RDF
+	LXI	D,DFCB
+	CALL	BDOS
+	ORA	A
+	JNZ	DEF
+;
+;	BUFFER READ OK
+	STA	DBP	;STORE 00H
+	JMP	RDC
+;
+DEF:	;DISK END OF FILE
+	MVI	A,DEOF
+RRET:
+	POP	B
+	POP	D
+	POP	H
+;	TRANSLATE TO UPPER CASE
+TRAN:
+	CPI	7FH	;RUBOUT?
+	RZ
+	CPI	('A' OR 010$0000B)	;UPPER CASE A
+	RC
+	ANI	101$1111B		;CLEAR UPPER CASE BIT
+	RET
+;
+SETBIT:
+	;SET THE BIT POSITION GIVEN BY H,L TO 1
+	CALL	FINDBYTE
+;	ROTATE A 1 BIT BY THE AMOUNT GIVEN BY B - 1
+	MVI	A,1
+SET0:	DCR	B
+	JZ	SET1
+	ORA	A	;CLEAR CY
+	RAL
+	JMP	SET0
+;
+;	BIT IS IN POSITION
+SET1:	ORA	M	;OR'ED TO BIT PATTERN IN MEMORY
+	MOV	M,A	;BACK TO BIT VECTOR
+	RET
+;
+FINDBYTE:
+;	H,L ADDRESSES A BYTE POSITION, CHANGE H,L TO BIT VECTOR
+;	POSITION, SET B TO NUMBER OF SHIFTS REQUIRED TO SELECT
+;	PROPER BIT AT RESULTING H,L POSITION
+	LXI	D,-RWORK
+	DAD	D
+	XCHG			;BIT ADDRESS IN D,E
+	MOV	A,E
+	ANI	111B		;VALUE X = 0,1,...,7
+;	CHANGE TO 8-X (8,7,...,1) TO SIMPLIFY BIT SHIFTING LATER
+	CMA			;VALUE X = -1,-2,...,-8
+	ADI	9		;VALUE X = 8,7, ...,1
+	MOV	B,A
+	MVI	C,3		;SHIFT COUNT IS 3
+SHRL:	;SHIFT RIGHT LOOP
+	XRA	A		;CLEAR FLAGS
+	MOV	A,D
+	RAR
+	MOV	D,A
+	MOV	A,E
+	RAR
+	MOV	E,A
+	DCR	C
+	JNZ	SHRL
+;
+;	END OF SHIFT, H,L ADDRESS RELATIVE BYTE POSITION
+	LHLD	HLOC		;LAST MEMORY ADDRESS FOR CODE
+	INX	H
+	DAD	D		;ABSOLUTE ADDRESS IS IN H,L
+	RET
+;
+PCHAR:	;PRINT CHARACTER IN A
+	PUSH	H
+	PUSH	D
+	PUSH	B
+	MOV	E,A
+	MVI	C,CONOF
+	CALL	BDOS
+	POP	B
+	POP	D
+	POP	H
+	RET
+;
+PNIB:	;PRINT NIBBLE IN REG A
+	ANI	0FH
+	CPI	10
+	JNC	P10
+;	<= 9
+	ADI	'0'
+	JMP	PRN
+P10:	ADI	'A' - 10
+PRN:	CALL	PCHAR
+	RET
+;
+PHEX:	;PRINT HEX CHAR IN REG-A
+	PUSH	PSW
+	RRC
+	RRC
+	RRC
+	RRC
+	CALL	PNIB
+	POP	PSW
+	CALL	PNIB
+	RET
+;
+PADDR:	;PRINT ADDRESS IN H,L
+	MOV	A,H
+	CALL	PHEX
+	MOV	A,L
+	CALL	PHEX
+	RET
+;
+CRLF:	;CARRIAGE RETURN - LINE FEED
+	MVI	A,CR
+	CALL	PCHAR
+	MVI	A,LF
+	CALL	PCHAR
+	RET
+;
+TERMINATE:
+	;WRITE MODULE TO DISK
+	LXI	D,-(RWORK-1)
+	LHLD	HLOC	;HIGH MODULE ADDRESS
+	DAD	D	;MODULE RELATIVE END IN H,L
+	SHLD	RSIZE	;STORE MODULE SIZE IN RELOCATOR
+	PUSH	H
+	LXI	D,RELEMSG	;REL MOD END
+	CALL	PRINT
+	POP	H
+	CALL	PADDR	;REL MOD END  XXXX
+	LHLD	LBYTE	;LAST POSITION TO WRITE
+	PUSH	H
+	LXI	D,-RWORK
+	DAD	D
+	PUSH	H
+	LXI	D,RELSMSG
+	CALL	PRINT
+	POP	H
+	CALL	PADDR	;REL MOD SIZE XXXX
+	LXI	D,RELDMSG
+	CALL	PRINT
+	LHLD	DSIZE
+	CALL	PADDR	;REL DAT SIZE XXXX
+	POP	H
+	LXI	D,RMOD	;D,E ADDRESS FIRST POSITION TO WRITE
+WLOOP:	MOV	A,L
+	SUB	E
+	MOV	A,H
+	SBB	D	;CARRY GENERATED IF D,E > H,L
+	JC	CLOS
+;	WRITE ANOTHER RECORD
+	PUSH	H
+	PUSH	D	;FIRST AND LAST SAVED
+	MVI	C,DMF	;SET DMA ADDRESS
+	CALL	BDOS
+	MVI	C,WRF	;WRITE TO FILE
+	LXI	D,OFCB
+	CALL	BDOS	;WRITTEN
+	ORA	A
+	JNZ	OFERR
+;	WRITE OK, INCREMENT DMA ADDRESS
+	LXI	H,128
+	POP	D
+	DAD	D
+	XCHG
+	POP	H	;STATE RESTORED FOR ANOTHER WRITE
+	JMP	WLOOP
+CLOS:	;CLOSE OUTPUT FILE
+;	MOVE DMA ADDRESS BACK TO 80H SO DATA IS NOT DESTROYED
+;	(THERE MAY BE A SUBSEQUENT SAVE OF THE ENTIRE MEM IMAGE)
+	MVI	C,DMF
+	LXI	D,DBF
+	CALL	BDOS
+	MVI	C,CLF
+	LXI	D,OFCB
+	CALL	BDOS
+	CPI	255
+	JZ	OFERR
+	RET
+;
+RELEMSG:
+	DB	CR,LF,'REL MOD END  $'
+RELSMSG:
+	DB	CR,LF,'REL MOD SIZE $'
+RELDMSG:
+	DB	CR,LF,'REL DAT SIZE $'
+;
+HEXCON:
+	;CONVERT ACCUMULATOR TO PURE BINARY FROM EXTERNAL ASCII
+	SUI	'0'
+	CPI	10
+	RC		;MUST BE 0-9
+	ADI	('0'-'A'+10) AND 0FFH
+	CPI	16
+	RC		;MUST BE A-F
+	LXI	D,HEXMSG
+	CALL	PRINT
+	JMP	FINIS
+HEXMSG:	DB	CR,LF,'BAD HEX DIGIT'
+INHEX:	DB	' '
+	DB	'IN DATA SIZE SPECIFICATION$'
+;
+SETUP:
+	;SETUP FILES FOR PROCESSING
+;	SCAN FOR DATA SIZE SPECIFICATION
+	LXI	D,DBF
+SCNDLR:
+	LDAX	D
+	INX	D
+	ORA	A
+	JZ	NODTSZ
+	CPI	'$'
+	JNZ	SCNDLR
+	LXI	H,0
+	MVI	B,0
+	ldax	d
+	call	tran
+	cpi	'Z'
+	jnz	scnend
+	mvi	a,0ffh
+	sta	igz
+	inx	d
+SCNEND:
+	LDAX	D
+	INX	D
+	ORA	A
+	JZ	ENDTSZ
+	CALL	TRAN	;CONVERT TO UPPER CASE
+	CALL	HEXCON
+	JNC	ENDTSZ
+OKDIGIT:
+	MOV	C,A
+	DAD	H
+	DAD	H
+	DAD	H
+	DAD	H
+	DAD	B
+	JMP	SCNEND
+NODTSZ:
+	LXI	H,0
+ENDTSZ:
+	LXI	D,RMOD
+	MVI	B,0
+	XRA	A
+ZEROBP:
+	STAX	D
+	INX	D
+	DCR	B
+	JNZ	ZEROBP
+	SHLD	DSIZE
+	MVI	A,'$'
+	STA	INHEX
+;	SET DMA ADDRESS TO DBF
+	LXI	D,DBF
+	MVI	C,DMF
+	CALL	BDOS
+;	LOOK FOR VALID FILE NAMES
+	LDA	DFCB+1
+	CPI	' '
+	JZ	FNERR
+	LDA	DFCB+17
+	CPI	' '
+	JZ	FNERR
+;	NAMES ARE PRESENT, COPY SECOND NAME TO OFCB
+	LXI	H,OFCB
+	LXI	D,DFCB+16
+	MVI	B,16
+FLOOP:	LDAX	D	;GET CHARACTER
+	MOV	M,A
+	INX	H
+	INX	D
+	DCR	B
+	JNZ	FLOOP
+;
+;	NAME COPIED, DELETE CURRENT VERSIONS, MAKE NEW FILE
+	LXI	D,OFCB
+	PUSH	D
+	MVI	C,DLF
+	CALL	BDOS
+	POP	D
+	MVI	C,MKF
+	CALL	BDOS
+	CPI	255
+	JZ	OFERR
+	XRA	A
+	STA	OFR	;CLEAR RECORD NUMBER
+;
+;	NEW FILE HAS BEEN CREATED, NOW OPEN INPUT FILE
+	MVI	C,OPF	;FILE OPEN FUNCTION
+	LXI	D,DFCB	;FILE CONTROL BLOCK ADDRESS
+	CALL	BDOS
+	CPI	255	;ERROR IF NOT FOUND
+	JZ	OPERR	;ERROR MESSAGE AND ABORT IF NOT FOUND
+	LXI	H,DBP	;DATA BUFFER POINTER
+	MVI	M,0	;CAUSES IMMEDIATE DATA READ
+	RET
+;
+OPERR:	;OPEN ERROR
+	LXI	D,OPMSG
+	CALL	PRINT
+	JMP	FINIS
+;
+OPMSG:	DB	CR,LF,'INPUT FILE NOT PRESENT$'
+;
+BERROR:
+	LXI	D,BASMSG
+	CALL	PRINT
+	JMP	FINIS
+BASMSG: DB	CR,LF,'INVALID RELOCATION BASE$'
+;
+;
+CERROR:
+	;ERROR IN INPUT, ABORT THE LOAD
+	LXI	D,ERMSG
+	CALL	PRINT
+	JMP	FINIS
+ERMSG:	DB	CR,LF,'BAD INPUT RECORD$'
+;
+FNERR:
+	LXI	D,FNMSG
+	CALL	PRINT
+	JMP	FINIS
+FNMSG:	DB	'MISSING FILE NAME$'
+;
+OFERR:
+	LXI	D,OFMSG
+	CALL	PRINT
+	JMP	FINIS
+OFMSG:	DB	'CANNOT CREATE OUTPUT FILE$'
+;
+SZERR:
+	LXI	D,SZMSG
+	CALL	PRINT
+	JMP	FINIS
+SZMSG:	DB	'HEX FILE SIZE TOO LARGE$'
+;
+PRINT:	;PRINT MESSAGE ADDRESSED BY D,E
+	MVI	C,PRF
+	CALL	BDOS
+	RET
+;
+FINIS:	;END OF PROCESSING
+	JMP	BOOT
+;
+DBP:	DS	1	;DISK BUFFER POINTER
+RBASE:	DS	1	;RELOCATION BASE
+PASS:	DS	1	;PASS 0,1
+;
+;
+HLOC:	DS	2	;HIGH ADDRESS IN MODULE
+LBYTE:	DS	2	;LAST BIT VECTOR BYTE POSITION
+;
+;
+BRWRK:	DS	2	;BIASED RWORK
+NBRWRK:	DS	2	;NEGATIVE BIASED RWORK
+;
+OFCB:	DS	32	;OUTPUT FILE CONTROL BLOCK
+OFR:	DS	1	;OUTPUT FILE RECORD NUMBER
+;
+	DS	STKSIZ	;STACK SIZE
+STACK:
+;
+igz:	db	0	;ignore zeroes on pass 1, boolean
+BBOOL:	DB	0	;BIAS COMPUTED, BOOLEAN
+;			;THIS DB GUARANTEES MODULE SIZE
+	END
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_3/load.plm

@@ -0,0 +1,362 @@
+LOAD:
+DO;
+    /* C P / M   C O M M A N D   F I L E   L O A D E R
+
+    COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981
+    DIGITAL RESEARCH
+    BOX 579 PACIFIC GROVE
+    CALIFORNIA 93950
+
+    Revised:
+      14 Sept 81  by Thomas Rolander
+    */
+
+DECLARE
+    TPA   LITERALLY '0100H',   /* TRANSIENT PROGRAM AREA */
+    DFCBA LITERALLY '005CH',   /* DEFAULT FILE CONTROL BLOCK */
+    DBUFF LITERALLY '0080H';   /* DEFAULT BUFFER ADDRESS */
+
+/* JMP LOADCOM TO START LOAD */
+DECLARE JUMP BYTE DATA(0C3H);
+DECLARE JUMPA ADDRESS DATA(.LOADCOM);
+
+DECLARE COPYRIGHT(*) BYTE DATA
+    (' COPYRIGHT (C) 1980, DIGITAL RESEARCH ');
+
+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;
+
+DECLARE SP ADDRESS;
+
+BOOT: PROCEDURE;
+    STACKPTR = SP;
+    RETURN;
+    END BOOT;
+
+
+LOADCOM: PROCEDURE;
+    DECLARE FCB (33) BYTE AT (DFCBA),
+       FCBA LITERALLY 'DFCBA';
+    DECLARE BUFFER (128) BYTE AT (DBUFF),
+        BUFFA LITERALLY 'DBUFF';
+    DECLARE SFCB(33) BYTE,  /* SOURCE FILE CONTROL BLOCK */
+        BSIZE LITERALLY '1024',
+        EOFILE LITERALLY '1AH',
+        SBUFF(BSIZE) BYTE,  /* SOURCE FILE BUFFER */
+        RFLAG BYTE,         /* READER FLAG */
+        SBP ADDRESS;        /* SOURCE FILE BUFFER POINTER */
+
+    /* LOADCOM LOADS TRANSIENT COMMAND FILES TO THE DISK FROM THE
+    CURRENTLY DEFINED READER PERIPHERAL.  THE LOADER PLACES THE MACHINE
+    CODE INTO A FILE WHICH APPEARS IN THE LOADCOM COMMAND */
+
+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;
+
+PRINTNIB: PROCEDURE(N);
+    DECLARE N BYTE;
+        IF N > 9 THEN CALL PRINTCHAR(N+'A'-10); ELSE
+        CALL PRINTCHAR(N+'0');
+    END PRINTNIB;
+
+PRINTHEX: PROCEDURE(B);
+    DECLARE B BYTE;
+        CALL PRINTNIB(SHR(B,4)); CALL PRINTNIB(B AND 0FH);
+    END PRINTHEX;
+
+PRINTADDR: PROCEDURE(A);
+    DECLARE A ADDRESS;
+    CALL PRINTHEX(HIGH(A)); CALL PRINTHEX(LOW(A));
+    END PRINTADDR;
+
+PRINTM: PROCEDURE(A);
+    DECLARE A ADDRESS;
+    CALL MON1(9,A);
+    END PRINTM;
+
+PRINT: PROCEDURE(A);
+    DECLARE A ADDRESS;
+    /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
+    NEXT DOLLAR SIGN IS ENCOUNTERED WITH PRECEDING CRLF */
+    CALL CRLF;
+    CALL PRINTM(A);
+    END PRINT;
+
+DECLARE LA ADDRESS;  /* CURRENT LOAD ADDRESS */
+
+PERROR: PROCEDURE(A);
+    /* PRINT ERROR MESSAGE */
+    DECLARE A ADDRESS;
+    CALL PRINT(.('ERROR: $'));
+    CALL PRINTM(A);
+    CALL PRINTM(.(', LOAD ADDRESS $'));
+    CALL PRINTADDR(LA);
+    CALL BOOT;
+    END PERROR;
+
+DECLARE DCNT BYTE;
+
+OPEN: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    DCNT = MON2(15,FCB);
+    END OPEN;
+
+CLOSE: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    DCNT = MON2(16,FCB);
+    END CLOSE;
+
+SEARCH: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    DCNT = MON2(17,FCB);
+    END SEARCH;
+
+SEARCHN: PROCEDURE;
+    DCNT = MON2(18,0);
+    END SEARCHN;
+
+DELETE: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    CALL MON1(19,FCB);
+    END DELETE;
+
+DISKREAD: PROCEDURE(FCB) BYTE;
+    DECLARE FCB ADDRESS;
+    RETURN MON2(20,FCB);
+    END DISKREAD;
+
+DISKWRITE: PROCEDURE(FCB) BYTE;
+    DECLARE FCB ADDRESS;
+    RETURN MON2(21,FCB);
+    END DISKWRITE;
+
+MAKE: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    DCNT = MON2(22,FCB);
+    END MAKE;
+
+RENAME: PROCEDURE(FCB);
+    DECLARE FCB ADDRESS;
+    CALL MON1(23,FCB);
+    END RENAME;
+
+    MOVE: PROCEDURE(S,D,N);
+        DECLARE (S,D) ADDRESS, N BYTE,
+        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;
+
+    GETCHAR: PROCEDURE BYTE;
+        /* GET NEXT CHARACTER */
+        DECLARE I BYTE;
+        IF (SBP := SBP+1) <= LAST(SBUFF) THEN
+            RETURN SBUFF(SBP);
+        /* OTHERWISE READ ANOTHER BUFFER FULL */
+            DO SBP = 0 TO LAST(SBUFF) BY 128;
+            IF (I:=DISKREAD(.SFCB)) = 0 THEN
+                CALL MOVE(80H,.SBUFF(SBP),80H); ELSE
+                DO;
+                IF I<>1 THEN CALL PERROR(.('DISK READ$'));
+                SBUFF(SBP) = EOFILE;
+                SBP = LAST(SBUFF);
+                END;
+            END;
+        SBP = 0; RETURN SBUFF(0);
+        END GETCHAR;
+DECLARE
+    STACKPOINTER LITERALLY 'STACKPTR';
+
+ /* INTEL HEX FORMAT LOADER */
+
+RELOC: PROCEDURE;
+    DECLARE (RL, CS, RT) BYTE;
+    DECLARE
+        TA ADDRESS,     /* TEMP ADDRESS */
+        SA ADDRESS,     /* START ADDRESS */
+        FA ADDRESS,     /* FINAL ADDRESS */
+        NB ADDRESS,     /* NUMBER OF BYTES LOADED */
+
+    MBUFF(256) BYTE,
+    P BYTE,
+    L ADDRESS;
+
+    SETMEM: PROCEDURE(B);
+        /* SET MBUFF TO B AT LOCATION LA MOD LENGTH(MBUFF) */
+        DECLARE (B,I) BYTE;
+        IF LA < L THEN
+            CALL PERROR(.('INVERTED LOAD ADDRESS$'));
+            DO WHILE LA > L + LAST(MBUFF); /* WRITE A PARAGRAPH */
+                DO I = 0 TO 127; /* COPY INTO BUFFER */
+                BUFFER(I) = MBUFF(LOW(L)); L = L + 1;
+                END;
+            /* WRITE BUFFER ONTO DISK */
+            P = P + 1;
+            IF DISKWRITE(FCBA) <> 0 THEN
+                DO; CALL PERROR(.('DISK WRITE$'));
+                END;
+            END;
+        MBUFF(LOW(LA)) = B;
+        END SETMEM;
+
+    DIAGNOSE: PROCEDURE;
+
+    DECLARE M BASED TA BYTE;
+
+    NEWLINE: PROCEDURE;
+        CALL CRLF; CALL PRINTADDR(TA); CALL PRINTCHAR(':');
+        CALL PRINTCHAR(' ');
+        END NEWLINE;
+
+    /* PRINT DIAGNOSTIC INFORMATION AT THE CONSOLE */
+        CALL PRINT(.('LOAD  ADDRESS $')); CALL PRINTADDR(TA);
+        CALL PRINT(.('ERROR ADDRESS $')); CALL PRINTADDR(LA);
+
+        CALL PRINT(.('BYTES READ:$')); CALL NEWLINE;
+        DO WHILE TA < LA;
+        IF (LOW(TA) AND 0FH) = 0  THEN CALL NEWLINE;
+        CALL PRINTHEX(MBUFF(TA-L)); TA=TA+1;
+        CALL PRINTCHAR(' ');
+        END;
+    CALL CRLF;
+    CALL BOOT;
+    END DIAGNOSE;
+
+    READHEX: PROCEDURE BYTE;
+        /* READ ONE HEX CHARACTER FROM THE INPUT */
+        DECLARE H BYTE;
+        IF (H := GETCHAR) - '0' <= 9 THEN RETURN H - '0';
+        IF H - 'A' > 5 THEN
+            DO; CALL PRINT(.('INVALID HEX DIGIT$'));
+            CALL DIAGNOSE;
+            END;
+        RETURN H - 'A' + 10;
+        END READHEX;
+
+    READBYTE: PROCEDURE BYTE;
+        /* READ TWO HEX DIGITS */
+        RETURN SHL(READHEX,4) OR READHEX;
+        END READBYTE;
+
+    READCS: PROCEDURE BYTE;
+        /* READ BYTE WHILE COMPUTING CHECKSUM */
+        DECLARE B BYTE;
+        CS = CS + (B := READBYTE);
+        RETURN B;
+        END READCS;
+
+    MAKE$DOUBLE: PROCEDURE(H,L) ADDRESS;
+        /* CREATE A BOUBLE BYTE VALUE FROM TWO SINGLE BYTES */
+        DECLARE (H,L) BYTE;
+        RETURN SHL(DOUBLE(H),8) OR L;
+        END MAKE$DOUBLE;
+
+
+    /* INITIALIZE */
+    SA, FA, NB = 0;
+    P = 0; /* PARAGRAPH COUNT */
+    TA,L = TPA;  /* BASE ADDRESS OF TRANSIENT ROUTINES */
+    SBUFF(0) = EOFILE;
+
+
+    /* READ RECORDS UNTIL :00XXXX IS ENCOUNTERED */
+
+        DO FOREVER;
+        /* SCAN THE : */
+            DO WHILE GETCHAR <> ':';
+            END;
+
+        /* SET CHECK SUM TO ZERO, AND SAVE THE RECORD LENGTH */
+        CS = 0;
+        /* MAY BE THE END OF TAPE */
+        IF (RL := READCS) = 0 THEN
+                GO TO FIN;
+        NB = NB + RL;
+
+        TA, LA = MAKE$DOUBLE(READCS,READCS);
+        IF SA = 0 THEN SA = LA;
+
+
+        /* READ THE RECORD TYPE (NOT CURRENTLY USED) */
+        RT = READCS;
+
+        /* PROCESS EACH BYTE */
+            DO WHILE (RL := RL - 1) <> 255;
+            CALL SETMEM(READCS); LA = LA+1;
+            END;
+        IF LA > FA THEN FA = LA - 1;
+
+        /* NOW READ CHECKSUM AND COMPARE */
+        IF CS + READBYTE <> 0 THEN
+            DO; CALL PRINT(.('CHECK SUM ERROR $'));
+            CALL DIAGNOSE;
+            END;
+        END;
+
+    FIN:
+    /* EMPTY THE BUFFERS */
+    TA = LA;
+        DO WHILE L < TA;
+        CALL SETMEM(0); LA = LA+1;
+        END;
+    /* PRINT FINAL STATISTICS */
+    CALL PRINT(.('FIRST ADDRESS $')); CALL PRINTADDR(SA);
+    CALL PRINT(.('LAST  ADDRESS $')); CALL PRINTADDR(FA);
+    CALL PRINT(.('BYTES READ    $')); CALL PRINTADDR(NB);
+    CALL PRINT(.('RECORDS WRITTEN $')); CALL PRINTHEX(P);
+    CALL CRLF;
+
+    END RELOC;
+
+ /* ARRIVE HERE FROM THE SYSTEM MONITOR, READY TO READ THE HEX TAPE */
+
+ /* SET UP STACKPOINTER IN THE LOCAL AREA */
+DECLARE STACK(16) ADDRESS;
+SP = STACKPOINTER; STACKPOINTER = .STACK(LENGTH(STACK));
+LA = TPA;
+
+SBP = LENGTH(SBUFF);
+   /* SET UP THE SOURCE FILE */
+    CALL MOVE(FCBA,.SFCB,33);
+    CALL MOVE(.('HEX',0),.SFCB(9),4);
+    CALL OPEN(.SFCB);
+    IF DCNT = 255 THEN CALL PERROR(.('CANNOT OPEN SOURCE$'));
+
+    CALL MOVE(.('COM'),FCBA+9,3);
+
+ /* REMOVE ANY EXISTING FILE BY THIS NAME */
+ CALL DELETE(FCBA);
+ /* THEN OPEN A NEW FILE */
+ CALL MAKE(FCBA); CALL OPEN(FCBA);
+ IF DCNT = 255 THEN CALL PERROR(.('NO MORE DIRECTORY SPACE$')); ELSE
+        DO; CALL RELOC;
+        CALL CLOSE(FCBA);
+        IF DCNT = 255 THEN CALL PERROR(.('CANNOT CLOSE FILE$'));
+        END;
+ CALL CRLF;
+
+CALL BOOT;
+END LOADCOM;
+END;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_4/pip.sub

@@ -0,0 +1,29 @@
+era b:*.lst
+era b:*.bak
+isx
+plm80 :f1:pip.plm debug nolist
+;era b:*.lst
+link :f1:pip.obj,:f1:x0100,plm80.lib to :f1:pip1.mod
+locate :f1:pip1.mod code(0100H) stacksize(100)
+era b:pip1.mod
+objhex :f1:pip1 to :f1:pip1.hex
+link :f1:pip.obj,:f1:x0200,plm80.lib to :f1:pip2.mod
+era b:pip.obj
+locate :f1:pip2.mod code(0200H) stacksize(100)
+era b:pip2.mod
+objhex :f1:pip2 to :f1:pip2.hex
+era b:pip2
+cpm
+;objcpm b:pip1
+era b:pip*.
+;pip lst:=b:pip1.sym[pt8]
+;pip lst:=b:pip1.lin[pt8]
+;pip lst:=nul:[p]
+era b:*.lin
+era b:*.sym
+pip b:pip.hex=b:pip1.hex,b:pip2.hex
+era b:pip1.hex
+era b:pip2.hex
+genmod b:pip.hex b:xpip.prl $$1000
+era b:*.hex
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/da.plm

@@ -0,0 +1,75 @@
+$title ('SDIR - Arithmetic')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+darithmetic:
+do;
+             /* arithmetic module for extended directory */
+
+             /* commonly used macros */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        word lit 'address',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10';
+
+add3byte: procedure(byte3adr,num) public;
+      dcl (byte3adr,num) address,
+          b3 based byte3adr structure (
+          lword address,
+          hbyte byte),
+          temp address;
+
+      temp = b3.lword;
+      if (b3.lword := b3.lword + num) < temp then             /* overflow */
+          b3.hbyte = b3.hbyte + 1;
+end add3byte;
+
+            /* add three byte number to 3 byte value structure */
+add3byte3: procedure(totalb,numb) public;
+      dcl (totalb,numb) address,
+          num base<73> num<75> structur<75> (
+          lword address,
+          hbyte byte),
+          total based totalb structure (
+          lword address,
+          hbyte byte);
+
+      cal<61> add3byte(totalb,num.lword);
+      total.hbyte = num.hbyte + total.hbyte;
+end add3byte3;
+
+                                                /* divide 3 byte value by 8 */
+shr3byte: procedure(byte3adr) public;
+    dcl byte3adr address,
+        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 */
+end shr3byte;
+
+end darithmetic;
+                                                                      
+                                    
+
+                                                                      
+              
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dall.sub

@@ -0,0 +1,38 @@
+pip a:=dm.plm[g9]
+seteof dm.plm
+pip a:=sn.plm[g9]
+seteof sn.plm
+pip a:=dse.plm[g9]
+seteof dse.plm
+pip a:=dsh.plm[g9]
+seteof dsh.plm
+pip a:=dso.plm[g9]
+seteof dso.plm
+pip a:=da.plm[g9]
+seteof da.plm
+pip a:=dp.plm[g9]
+seteof dp.plm
+pip a:=dts.plm[g9]
+seteof dts.plm
+isx
+plm80 dm.plm object(dm) debug nolist
+plm80 sn.plm object(sn) debug nolist
+plm80 dse.plm object(dse) debug nolist
+plm80 dsh.plm object(dsh) debug nolist
+plm80 dso.plm object(dso) debug nolist
+plm80 dp.plm object(dp) debug nolist
+plm80 da.plm object(da) debug nolist
+plm80 dts.plm object(dts) debug nolist
+link x0100,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d1.lnk
+locate d1.lnk code(0100H) stacksize(50)
+era d1.lnk
+objhex d1 to d1.hex
+link x0200,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d2.lnk
+locate d2.lnk code(0200H) stacksize(50)
+era d2.lnk
+objhex d2 to d2.hex
+cpm
+objcpm d1
+pip d.hex=d1.hex,d2.hex
+genmod d.hex xsdir.prl 
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dm.plm

@@ -0,0 +1,610 @@
+$title ('Super Directory Command')
+sdir:
+do;
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+declare start label,
+    jump byte data (0c3h),
+    jadr address data (.start-3);
+
+ /<2F> <20> P <20> M - M P / M <20>   <20> <20> <20> <20> <20> <20> <20> <20> <20>  <20> <20> <20> <20> <20> <20> <20>  (SDIR<49> */
+
+        /* commonly used macros */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10',
+        tab lit '9';
+
+declare cright (*) byte data (cr,lf,
+            'SDIR V1.0 ',
+            'Copyright(c) 1981 ',
+            'Digital Research ',
+            'Box 579 ',
+            'Pacific Grove, CA ',
+            '93950',01AH);
+
+                /* definitions for assembly interface module        */
+declare
+    fcb (33) byte external,        /* default file control block    */
+    maxb address external,         /* top of memory                 */
+    buff(128)byte external;        /* default buffer                */
+
+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;
+
+scan: procedure(pcb$adr) external;
+    declare pcb$adr address;
+end scan;
+
+scan$init: procedure(pcb$adr) external;
+    declare pcb$adr address;
+end scan$init;
+
+get$files: procedure external;
+end get$files;
+
+sort: procedure external;
+end sort;
+
+mult23: procedure (num) address external;
+dcl num address;
+end mult23;
+
+show$files: procedure external;
+end show$files;
+
+printb: procedure external;
+end printb;
+
+print$char: procedure(c) external;
+dcl c byte;
+end print$char;
+
+print: procedure(string$adr) external;
+dcl string$adr address;
+end print;
+
+crlf: procedure external;
+end crlf;
+
+p$decimal: procedure(value,fieldsize,zsup) external;
+    dcl value address,
+        fieldsize address,
+        zsup boolean;
+end p$decimal;
+
+dcl debug boolean public initial (false);
+
+                 /* version information */
+
+dcl (os,bdos) byte public,
+    bdos20 lit '20H',
+    bdos30 lit '30H',
+    mpm    lit '10H';
+
+                /* fcb and dma buffer constants */
+declare
+    f$drvusr         lit '0',        /* drive/user byte                     */
+    f$name           lit '1',        /* file name                           */
+    fnamelen         lit '8',        /* file name length                    */
+    f$type           lit '9',        /* file type field                     */
+    ftypelen         lit '3',        /* type length                         */
+    f$rw             lit '9',        /* high bit is R/W attribute           */
+    f$dirsys         lit '10';       /* high bit is dir/sys attribute       */
+
+        /* search variables        */
+dcl search$ops address public initial(0),/* search options or'd in here     */
+    s$dir lit '1',
+    s$sys lit '2',
+    s$ro  lit '4',
+    s$rw  lit '8',
+    s$pass lit '16',
+    s$xfcb lit '32',
+    s$nonxfcb  lit '64',
+    s$exclude lit '128';
+
+dcl max$search$files lit '10',  /* files to search for on each pass through */
+    num$s$files byte public initial(0),    /* the directory */
+    search (max$search$files) structure(
+        name(8) byte,
+        type (3) byte,
+        drv byte,
+        anyfile byte ) public;  /* if explicit drive byte has been given    */
+                                /* with the file spec : "A:JUNK.JNK"        */
+
+dcl file$info structure (
+    space(23) byte);
+
+dcl get$all$dir$entries boolean public;
+dcl end$adr address external;
+dcl hash$table$len lit '128';
+dcl hash$table(hash$table$len) address external;
+
+dcl first$pass boolean public;
+dcl usr$vector address public initial(0),   /* bits for user #s to scan */
+    active$usr$vector address public,       /* active users on curdrv   */
+    drv$vector address initial (0);         /* bits for drives to scan  */
+
+dcl form$short lit '0',
+    form$size lit '1',
+    form$full lit '2',
+    format byte public initial (form$full),
+    page$len address public initial (0), /* lines on a page before printing */
+                                      /* new headers, 0 forces initial hdrs */
+    message boolean public initial(false),/* show titles when no files found*/
+    formfeeds boolean public initial(false);/* use form feeds               */
+
+dcl file$displayed boolean external;
+                                /* 1 or more files displayed by dsh.plm     */
+
+dcl sort$op boolean initial (true);             /* default is to do sorting */
+dcl sorted boolean external;                    /* if successful sort       */
+
+        /* other globals        */
+
+dcl cur$usr byte public,        /* current user being searched              */
+    cur$drv byte public;        /* current drive   "     "                  */
+
+        /* BDOS calls           */
+
+get$version: procedure address; /* returns current cp/m - mp/m version #    */
+    return mon2(12,0);
+end get$version;
+
+select$drive: procedure(d);
+    declare d byte;
+    call mon1(14,d);
+end select$drive;
+
+search$first: procedure(d) byte external;
+dcl d address;
+end search$first;
+
+search$next: procedure byte external;
+end search$next;
+
+get$cur$drv: procedure byte;        /* return current drive number          */
+    return mon2(25,0);
+end get$cur$drv;
+
+getlogin: procedure address;        /* get the login vector                 */
+    return mon3(24,0);
+end getlogin;
+
+getusr: procedure byte;             /* return current user number           */
+    return mon2(32,0ffh);
+end getusr;
+
+terminate: procedure public;
+    if os = mpm then
+        call mon1(0,143);               /* MP/M */
+    else
+        cal<61> mon<6F> (0,0)<29>                /* CP/M */<2F>
+end terminate;
+
+        /* Utility routines */
+
+number: procedure (char) boolean;
+    dcl char byte;
+    return(char >= '0' and char <= '9');
+end number;
+
+make$numeric: procedure(char$adr,len,val$adr) boolean;
+    dcl (char$adr, val$adr, place) address,
+        chars based char$adr (1) byte,
+        value based val$adr address,
+        (i,len) byte;
+
+    value = 0;
+    place = 1;
+    do i = 1 to len;
+        if not number(chars(len - i)) then
+            return(false);
+        value = value + (chars(len - i) - '0') * place;
+        place = place * 10;
+   end;
+   return(true); 
+end make$numeric;
+
+set$vec: procedure(v$adr,num) public;
+    dcl v$adr address,               /* set bit number given by num */
+        vector based v$adr address,  /* 0 <= num <= 15              */
+        num byte;
+    if num = 0 then
+       vector = vector or 1;
+    else
+       vector = vector or shl(double(1),num);
+end set$vec;
+
+bit$loc: procedure(vector) byte;
+                             /* return location of right most on bit vector */
+    dcl vector address,      /* 0 - 15                                      */
+        i byte;
+    i = 0;
+    do while i < 16 and (vector and double(1)) = 0;
+        vector = shr(vector,1);
+        i = i + 1;
+    end;
+    return(i);
+end bit$loc;
+
+get$nxt: procedure(vector$adr) byte;
+    dcl i byte,
+        (vector$adr,mask) address,
+        vector based vector$adr address;
+    if debug then
+        do;  call print(.(cr,lf,'getnxt: vector = $'));
+        call pdecimal(vector,10000,false);
+        end;   
+
+    if (i := bit$loc(vector)) > 15 then
+        return(0ffh);
+    mask = 1;
+    if i > 0 then
+        mask = shl(mask,i);
+    vector = vector xor mask;                /* turn off bit        */
+    if debug then
+        do;  call print(.(cr,lf,'getnxt: vector, i, mask $'));
+        call pdecimal(vector,10000,false);
+        call printb;
+        call pdecimal(i,10000,false); 
+        call printb;
+        call pdecimal(mask,10000,false);
+        end;
+    return(i);
+end get$nxt;               /* too bad plm rotates only work on byte values */
+
+dcl t$null lit '0',
+    t$param  lit '1',
+    t$op lit '2',
+    t$mod lit '4',
+    t$identifier lit '8',
+    t$string lit '16',
+    t$numeric lit '32',
+    t$filespec lit '64',
+    t$error lit '128';
+
+dcl pcb structure (
+            state address,
+            scan$adr address,
+            token$adr address,
+            tok$typ byte,
+            token$len byte,
+            p$level byte,
+            nxt$token byte) initial (0,.buff(0),.fcb(0),0,0,0,0) ;
+
+help: procedure;             /* show options for this program */
+
+call print(.(cr,lf,
+tab,tab,tab,'SDIR EXAMPLES',cr,lf,lf,
+'sdir file.one',tab,tab,tab,
+'(find a file on current user and default drive)',cr,lf,
+'sdir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)',
+cr,lf,
+'sdir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf,
+'sdir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf,
+'sdir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf,
+'sdir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf,
+'sdir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf,
+'sdir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf,
+'sdir [full]',tab,tab,tab,'(show all file information)',cr,lf,
+'sdir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf,
+'sdi<64> [short]',tab<61>tab,tab,'(sho<68> jus<75> th<74> fil<69> names)',cr,lf,
+'sdir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf,
+'sdir [drive = (a,b,p)]',tab,tab,
+'(search specified drives, ''disk'' is synonym)',cr,lf,
+'sdir [user = all]',tab,tab,'(find files with any user number)',cr,lf,
+'sdir [user = (0,1,15)]',tab,tab,'(find files with specified user number)',
+cr,lf,
+'sdir [length = n]',tab,tab,'(print headers every n lines)',cr,lf,
+'sdir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf,
+'sdir [message user=all]',tab,tab,'(show user/drive areas with no files)',
+cr,lf,
+'sdir [help]',tab,tab,tab,'(show this message)',cr,lf,
+'sdir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$'));
+
+call terminate;
+end help;
+
+dcl token based pcb.token$adr (12) byte;
+
+dcl got$options boolean;
+
+get$options: procedure;
+    dcl temp byte;
+
+    do while pcb.scan$adr <> 0ffffh and ((pcb.tok$typ and t$op) <> 0);
+      if pcb.nxt$token <> t$mod then
+      do;  /* options with no modifiers */
+        if token(1) = 'D' and token(2) = 'I' then
+            search$ops = search$ops or s$dir;
+        /* else if token(1) = 'D' and token(2) = 'E' then
+            debug = true; */
+        else if token(1) = 'E' then
+            search$ops = search$ops or s$exclude;
+        else if token(1) = 'F'then
+            if token(2) = 'F' then
+                formfeeds = true;
+            else if token(2) = 'U' then
+                format = form$full;
+            else goto op$err;  
+        else if token(1) = 'H' then
+            call help;
+        else if token(1) = 'M' then
+            message = true;
+        else if token(1) = 'N' then
+            if token(4) = 'X' then
+                search$ops = search$ops or s$nonxfcb;
+            else if token(3) = 'S' then
+                sort$op = false;
+            else goto op$err;
+        else if token(1) = 'P' then
+            search$ops = search$ops or s$pass;
+        else if token(1) = 'S' then
+            if token(2) = 'Y' then
+                search$ops = search$ops or s$sys;
+            else if token(2) = 'H' then
+                format = form$short;
+            else if token(2) = 'I' then
+                format = form$size;
+            else if token(2) = 'O' then
+                sort$op = true;
+            else goto op$err;
+        else if token(1) = 'R' and token(2) = 'O' then
+            search$ops = search$ops or s$ro;
+        else if token(1) = 'R' and token(2) = 'W' then
+            search$ops = search$ops or s$rw;
+        else if token(1) = 'X' then
+            search$ops = search$ops or s$xfcb;
+        else goto op$err; 
+        call scan(.pcb);
+      end;
+      else
+      do; /* options with modifiers */
+        if token(1) = 'L' then
+        do;
+            call scan(.pcb);
+            if (pcb.tok$typ and t$numeric) <> 0 then
+                if make$numeric(.token(1),pcb.token$len,.page$len) then
+                     if page$len < 5 then
+                         goto op$err;
+                     else call scan(.pcb);
+                else goto op$err;
+            else goto op$err;
+        end;
+        else if token(1) = 'U' then
+        do;
+          if debug then
+              call print(.(cr,lf,'In User option$'));
+          call scan(.pcb); 
+          if ((pcb.tok$typ and t$mod) = 0) or bdos < bdos20 then
+              goto op$err;
+          do while (pcb.tok$typ and t$mod) <> 0 and
+            pcb.scan$adr <> 0ffffh;
+            if token(1) = 'A' and token(2) = 'L' then
+                usr$vector = 0ffffh;
+            else if (pcb.tok$typ and t$numeric) <> 0
+                and pcb.token$len < 3 then
+                do;
+                if pcb.token$len = 1 then
+                    temp = token(1) - '0';
+                else
+                    temp = (token(1) - '0') * 10 + (token(2) - '0');
+                if temp >= 0 and temp <= 15 then
+                    call set$vec(.usr$vector,temp);
+                else goto op$err;
+                end;
+            else goto op$err;
+            call scan(.pcb);
+          end;
+        end;
+        else if token(1) = 'D' and (token(2) = 'R' or token(2) = 'I') then
+        do;                         /* allow DRIVE or DISK */
+          call scan(.pcb); 
+          if (pcb.tok$typ and t$mod) = 0  then
+              goto op$err;
+          do while (pcb.tok$typ and t$mod ) <> 0 and
+            pcb.scan$adr <> 0ffffh;
+            if token(1) = 'A' and token(2) = 'L' then
+            do;
+                drv$vector = 0ffffh;
+                drv$vector = drv$vector and get$login;
+            end;
+            else if token(1) >= 'A' and token(1) <= 'P' then
+                call set$vec(.drv$vector,token(1) - 'A');
+            else goto op$err;
+            call scan(.pcb);
+          end;
+        end; /* drive option */
+      else goto op$err;
+      end; /* options with modifiers */
+    end; /* do while */
+
+    got$options = true;
+    return;
+
+    op$err:
+        call print(.('Illegal Option or Modifier$'));
+        call terminate;
+end get$options;
+
+get$file$spec: procedure;
+    dcl i byte;
+    if num$s$files < max$search$files then
+    do;
+        call move(f$namelen + f$typelen,.token(1),
+           .search(num$s$files).name(0));
+        
+        if search(num$s$files).name(f$name - 1) = ' ' and
+           search(num$s$files).name(f$type - 1) = ' ' then
+           search(num$s$files).anyfile = true;   /* match on any file */
+        else search(num$s$files).anyfile = false;
+
+        if token(0) = 0 then
+            search(num$s$files).drv = 0ffh;       /* no drive letter with   */
+        else                                      /* file spec              */
+            search(num$s$files).drv = token(0) - 1;
+        /* 0ffh in drv field indicates to look on all drives that will be   */
+        /* scanned as set by the "drive =" option, see "match:" proc in     */
+        /* dsearch module         */
+
+        num$s$files = num$s$files + 1;
+    end;                              
+    else
+    do; call print(.('File Spec Limit is $'));
+        call p$decimal(max$search$files,100,true);
+        call crlf;
+    end;
+    call scan(.pcb);                  
+end get$file$spec;
+
+set$defaults: procedure;             
+           /* set defaults if not explicity set by user */ 
+    if ((search$ops and s$dir) = 0 and (search$ops and s$sys) = 0) then
+        search$ops = search$ops or s$dir or s$sys;
+    if ((search$ops and s$ro) = 0 and (search$ops and s$rw) = 0) then
+        search$ops = search$ops or s$rw or s$ro;
+
+    if ((search$ops and s$xfcb) <> 0 or (search$ops and s$nonxfcb) <> 0) then
+       do; if format = form$short then
+            format = form$full;
+       end;
+    else            /* both xfcb and nonxfcb are off */
+       search$ops = search$ops or s$nonxfcb or s$xfcb;
+
+    if num$s$files = 0 then
+    do;
+        search(num$s$files).anyfile = true;
+        search(num$s$files).drv = 0ffh;
+        num$s$files = 1;
+    end;
+
+    if drv$vector = 0 then
+        do i = 0 to num$s$files - 1;
+            if search(i).drv = 0ffh then search(i).drv = cur$drv;
+            call set$vec(.drv$vector,search(i).drv);
+        end;
+    else                            /* a "[drive =" option was found */
+        do i = 0 to num$s$files - 1;
+            if search(i).drv <> 0ffh and search(i).drv <> cur$drv then
+            do; call print(.('Illegal Global/Local Drive Spec Mixing$'));
+                call terminate;
+            end;
+        end;
+    if usr$vector = 0 then
+       call set$vec(.usr$vector,get$usr); 
+end set$defaults;
+
+dcl (save$uvec,temp) address;
+dcl i byte;
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+    os = high(get$version);
+    bdos = low(get$version); 
+
+    /* note - initialized declarations set defaults */
+    cur$drv = get$cur$drv;
+    call scan$init(.pcb);
+    call scan(.pcb);
+    got$options = false;
+    do while pcb.scan$adr <> 0ffffh;
+        if (pcb.tok$typ and t$op) <> 0 then
+            if got$options = false then
+                call get$options;
+            else
+            do;
+                call print (.('Only One Set of Options Allowed$'));
+                call terminate;
+            end;
+        else if (pcb.tok$typ and t$filespec) <> 0 then
+            call get$file$spec;
+        else
+        do;
+            call print(.('Illegal File Spec$'));
+            call terminate;
+        end;
+    end;
+
+    call set$defaults;
+    /*  call set$mem$buffer; allocate memory on 8086 if ever needed */
+    end$adr = .hash$table + size(hash$table) - size(file$info);
+    /* end$adr is a constant, set here and used by dshow to find the  */
+    /* end of the file$info records when not sorted                   */
+
+    /* main control loop */
+
+    do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh;
+        call select$drive(cur$drv);
+        save$uvec <20> usr$vector;      /* user numbers to search on each drive*/
+        active$usr$vector = 0;           /* users active on cur$drv      */
+        cur$usr = get$nxt(.usr$vector);  /* get first user num and mask  */ 
+        get$all$dir$entries = false;     /* off it off                   */
+        if usr$vector <> 0 then          /* find high water mark if      */
+        do;                              /* more than one user requested */
+            fcb(f$drvusr) = '?';
+            i = search$first(.fcb);  /* get first directory entry      */
+            temp = 0;
+            do while i <> 255;
+                temp = temp + 1;
+                i = search$next;
+            end;                        /* is there enough space in the */
+                                        /* worst case ?                 */
+            if maxb > mult23(temp + 1) + shl(temp,1) then
+                get$all$dir$entries = true;  /* location of last possible   */
+        end;                                 /* file info record and add    */
+        first$pass = true;                   /* room for sort indices       */
+        active$usr$vector = 0ffffh;
+        do while cur$usr <> 0ffh;
+            if debug then
+                call print(.(cr,lf,'in user loop $'));
+            call set$vec(.temp,cur$usr);
+            if (temp and active$usr$vector) <> 0 then
+            do;
+                if format <> form$short and
+                    (first$pass or not get$all$dir$entries)  then
+                do;
+                    call getfiles;      /* collect files in memory and  */
+                    first$pass = false; /* build the active usr vector  */
+                    sorted = false;     /* sort module will set sorted  */
+                    if sort$op then     /* to true, if successful sort  */
+                        call sort;
+                end;
+                call show$files;
+            end;
+            cur$usr = get$nxt(.usr$vector);
+        end;
+        usr$vector = save$uvec;             /* restore user vector for nxt  */
+    end; /* do while drv$usr                   drive scan                   */
+
+
+    if  not file$displayed and not message then
+        call print(.('File Not Found.$'));
+error:
+    call terminate;
+
+end sdir;

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dp.plm

@@ -0,0 +1,133 @@
+$title ('SDIR - Print')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+dprint:
+do;
+              /* print routines for extended directory */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        word lit 'address',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10';
+
+mon1: procedure(f,a) external;
+    declare f byte, a address;
+end mon1;
+
+dcl debug byte external;
+
+break: procedure external;
+end break;
+
+             /* fcb and dma buffer constants */
+declare
+    f$name           lit '1',        /* file name                           */
+    fnamelen         lit '8',        /* file name length                    */
+    f$type           lit '9',        /* file type field                     */
+    f$typelen        lit '3';        /* type length                         */
+
+        /* BDOS calls */
+
+print$char: procedure(char) public;
+    declare char byte;
+    call mon1(2,char);
+end print$char;
+
+print: procedure(string$adr) public;
+    dcl string$adr address;
+    call mon1(9,string$adr);
+    if debug then
+       call break; 
+end print;
+
+printb: procedure public;
+    call print$char(' ');
+end printb;
+ 
+crlf: procedure public;
+    call print$char(cr);
+    call print$char(lf);
+end crlf;
+
+printfn: procedure(fname$adr) public;
+    dcl fname$adr address,
+        file$name based fname$adr (1) byte,
+        i byte;                                /* <filename> ' ' <filetype> */
+
+    do i = 0 to f$namelen - 1;
+        call printchar(file$name(i) and 7fh);
+    end;
+    call printchar(' ');
+    do i = f$namelen to f$namelen + f$typelen - 1;
+        call printchar(file$name(i) and 7fh);
+    end;
+end printfn;
+
+pdecimal: procedure(v,prec,zerosup) public;
+                         /* print value v, field size = (log10 prec) + 1  */
+                         /* with leading zero suppression if zerosup = true */
+    declare v address,                          /* value to print           */
+            prec address,                       /* precision                */
+            zerosup boolean,                    /* zero suppression flag    */
+            d byte;                             /* current decimal digit    */
+
+    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;
+
+p3byte: procedure(byte3adr,prec) public;
+                                   /* print 3 byte value with 0 suppression */
+      dcl byte3adr address,        /* assume high order bit is < 10         */
+          prec address,
+          b3 based byte3adr structure (
+          lword address,
+          hbyte byte),
+          i byte;
+
+                                       /* prec = 1 for 6 chars, 2 for 7 */
+      if b3.hbyte <> 0 then
+      do;
+          call pdecimal(b3.hbyte,prec,true);  /* 3 for 8 chars printed      */
+          call pdecimal(b3.lword,10000,false);
+      end;
+      else
+      do;
+          i = 1;
+          do while i <= prec;
+              call printb;
+              i = i * 10;
+          end;
+          call pdecimal(b3.lword,10000,true);
+      end;
+end p3byte;
+
+end dprint;
+
+                        
+
+                                                                      
+                                              
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dse.plm

@@ -0,0 +1,489 @@
+$title ('SDIR - Search')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+dsearch:
+do;
+                /* search module for extended dir */
+
+                /* commonly used macros */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        word lit 'address',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10';
+
+                /* definitions for assembly interface module        */
+declare
+    maxb  address external,        /* addr field of jmp BDOS        */
+    fcb (33) byte external,        /* default file control block    */
+    fcb16(16)byte external,
+    tbuff(128)byte external,
+    buff(128)byte external;        /* default buffer                */
+
+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;
+
+dcl debug boolean external;
+
+                 /* version information */
+
+dcl (os,bdos) byte external,
+    bdos20 lit '20H',
+    bdos30 lit '30H',
+    mpm    lit '10H';
+
+dcl first$pass boolean external;
+dcl get$all$dir$entries boolean external;
+dcl usr$vector address external;
+dcl active$usr$vector address external;
+dcl used$de address public;                /* used directory entries        */
+dcl filesfound address public;             /* num files collected in memory */
+
+                /* fcb and dma buffer constants */
+declare
+    sectorlen         lit '128',      /* sector length                 */
+    f$drvusr          lit '0',        /* drive and user byte           */
+    f$name            lit '1',        /* file name                     */
+    fnamelen          lit '8',        /* file name length              */
+    f$type            lit '9',        /* file type field               */
+    f$typelen         lit '3',        /* type length                   */
+    f$rw              lit '9',        /* high bit is R/W attribute     */
+    f$dirsys          lit '10',       /* high bit is dir/sys attribute */
+    f$arc             lit '11',       /* high bit is archive attribute */
+    f$ex              lit '12',       /* extent                        */
+    f$s1              lit '13',       /* module byte                   */
+    f$rc              lit '15',       /* record count                  */
+    f$diskmap         lit '16',       /* file disk map                 */
+    diskmaplen        lit '16',       /* disk map length               */
+    f$drvusr2         lit '16',       /* fcb2                          */
+    f$name2           lit '17',
+    f$type2           lit '25',
+    f$rrec            lit '33',       /* random record                 */
+    f$rreco           lit '35';       /*   "      "    overflow        */
+
+declare
+    deleted$type lit '0E5H';
+
+declare                                 /* XFCB                        */
+    xfcb$type          lit '10h',       /* identifier on disk          */
+    xf$passmode        lit '12',        /* pass word protection mode   */
+    xf$pass            lit '16',        /* XFCB password               */
+    passlen            lit '8',         /* password length             */
+    xf$create          lit '24',        /* creation/access time stamp  */
+    xf$update          lit '28';        /* update time stamp           */
+
+declare                       /* directory label: special case of XFCB */
+    dirlabeltype       lit '20h',       /* identifier on disk          */
+    dl$password        lit '128',       /* masks on data byte          */
+    dl$access          lit '64',
+    dl$update          lit '32',
+    dl$makexfcb        lit '16',
+    dl$exists          lit '1';
+
+                                   /* search variables                     */
+dcl search$ops address external,   /* search options or'd in here          */
+    s$dir lit '1',
+    s$sys lit '2',
+    s$ro  lit '4',
+    s$rw  lit '8',
+    s$pass lit '16',
+    s$xfcb lit '32',
+    s$nonxfcb lit '64',
+    s$exclude lit '128';
+
+dcl format byte external,
+    form$short lit '0';
+
+dcl max$search$files lit '10',  /* files to search for on each pass through */
+    num$s$files byte external,  /* the directory */
+    search (max$search$files) structure(
+    name(8) byte,
+    type(3) byte,
+    drv byte,
+    anyfile boolean) external;
+
+        /* logical drive information                                        */
+
+/* function call 32 in 2.0 or later BDOS, returns the address of the disk
+parameter block for the currently selected disk, which consists of:
+        spt                   (2 bytes) number of sectors per track
+        blkshf                (1 byte) log2 of blocksize (2**blkshf=blksize)
+        blkmsk                (1 byte) 2**blkshf-1
+        extmsk                (1 byte) logical/physical extents
+        blkmax                (2 bytes) max alloc number
+        dirmax                (2 bytes) size of directory-1
+        dirblk                (2 bytes) reservation bits for directory
+        chksiz                (2 bytes) size of checksum vector
+        offset                (2 bytes) offset for operating system
+*/
+
+dcl dpb$adr address public,          /* disk parameter block address        */
+    dpb based dpb$adr structure
+        (spt address, blkshf byte, blkmsk byte, extmsk byte, blkmax address,
+         dirmax address, dirblk address, chksiz address, offset address),
+    bytes$per$block address;                /* bytes per block         */
+
+        /* other globals        */
+
+dcl cur$usr byte external,
+    cur$drv byte external,        /* current drive   "     "           */
+    dir$label byte public;      /* directory label for BDOS 3.0      */
+        /* error flags                */
+
+        /* BDOS calls */
+
+read$char: procedure byte;
+    return mon2 (1,0);
+end read$char;
+
+print: procedure(string$adr) external;
+    dcl string$adr address;
+end print;
+
+print$char: procedure(char) external;
+    dcl char byte;
+end print$char;
+
+pdecimal:procedure(val,prec,zsup) external;
+    dcl (val, prec) address;
+    dcl zsup boolean;
+end pdecimal;
+
+printfn: procedure(fnameadr) external;
+    dcl fnameadr address;
+end printfn;
+
+check$console$status: procedure byte;
+    return mon2 (11,0);
+end check$console$status;
+
+search$first: procedure (fcb$address) byte public;
+    declare fcb$address address;
+    return mon2 (17,fcb$address);
+end search$first;
+
+search$next: procedure byte public;
+    return mon2 (18,0);
+end search$next;
+
+get$dpb: procedure address;        /* return base of dpb   */
+    return mon3(31,0);        
+end get$dpb;
+
+terminate: procedure external;
+end terminate;
+
+set$vec: procedure(vector,value) external;
+dcl vector address,
+    value byte;
+end set$vec;
+
+mult23: procedure (f$i$num) address external;
+dcl f$i$num address;
+end mult23;
+
+        /* Utility routines */
+
+crlf: procedure external;   /* print carriage return, linefeed */
+end crlf;
+
+set$drive: procedure public;           /* base of disk parm block for the  */
+    dpb$adr = get$dpb;                 /* currently selected drive         */
+    bytes$per$block = shl(double(1),dpb.blkshf) * sectorlen;
+end set$drive;
+
+break: procedure public;
+    dcl x byte;
+    if check$console$status then
+    do;
+        x = read$char;
+        call terminate;
+    end;
+end break;
+
+number: procedure (char) boolean;
+    dcl char byte;
+    return(char >= '0' and char <= '9');
+end number;
+
+add3byte: procedure(byte3adr,num) external;
+      dcl (byte3adr,num) address;
+end add3byte;
+
+        /* add three byte number to 3 byte accumulater */ 
+add3byte3: procedure(totalb,numb) external;
+      dcl (totalb,numb) address;
+end add3byte3;
+
+        /* divide 3 byte value by 8 */
+shr3byte: procedure(byte3adr) external;
+      dcl byte3adr address;
+end shr3byte;
+
+add$block: procedure(ak,ab);
+    declare (ak, ab) address;
+    /* add one block to the kilobyte accumulator       */
+    declare kaccum based ak address; /* kilobyte accum */
+    declare baccum based ab address; /* byte accum     */
+    baccum = baccum + bytes$per$block;
+    do while baccum >= 1024;
+        baccum = baccum - 1024;
+        kaccum = kaccum + 1;
+    end;
+end add$block;
+
+declare
+        buf$fcb$adr address public,     /* index into directory buffer */
+        buf$fcb based buf$fcb$adr (32) byte,
+                                        /* fcb template for dir        */
+
+        (f$i$adr, end$adr, last$f$i$adr) address public,
+                                   /* indices into file$info array    */
+        file$info based f$i$adr structure(
+            usr byte,             /* user number                      */
+            name (8) byte,
+            type (3) byte,
+            bytes address,        /* byte count (mod kilobyte)        */
+            kbytes address,       /* kilobyte count                   */
+            recs$lword address,   /* record count is 3 byte value     */
+            recs$hbyte byte,      /* low word, high byte              */
+            hash$link address,    /* link for collison                */
+            x$i$adr address),     /* index into time stamp array for  */
+                                  /* this file                        */
+
+        x$i$adr address public,
+        xfcb$info based x$i$adr structure (
+            create (4) byte,
+            update (4) byte,
+            passmode byte);
+
+compare: procedure(length, str1$adr, str2$adr) boolean;
+    dcl (length,i) byte,
+        (str1$adr, str2$adr) address,
+        str1 based str1$adr (1) byte,
+        str2 based str2$adr (1) byte;
+    do i = 0 to length - 1;
+        if ((str1(i) and 7fh) <> (str2(i) and 7fh)) and str2(i) <> '?' then
+            return(false);
+    end;
+    return(true);
+end compare;
+
+match: procedure boolean public;
+dcl i byte,
+    temp word;
+    if (i := (buf$fcb(f$drvusr) and 0fh)) <> cur$usr then
+        if not get$all$dir$entries then       /* Not looking for this user  */
+            return(false);                    /* and not buffering all other*/
+        else                                  /* specified user files on    */
+        do; temp = 0;                         /* this drive.                */
+            call set$vec(.temp,i);
+            if (temp and usr$vector) = 0 then /* Getting all dir entries,   */
+                return(false);                /* with user number corresp'g */
+        end;                                  /* to a bit on in usr$vector  */
+    if usr$vector <> 0 then
+        if i <> 0 and first$pass and usr$vector <> 0 then
+            call set$vec(.active$usr$vector,i);
+                                  /* build active usr vector for this drive */
+    do i = 0 to num$s$files - 1;
+        if search(i).drv = 0ffh or search(i).drv = cur$drv then
+                      /* match on any drive if 0ffh */
+            if search(i).anyfile = true then
+                 return((search$ops and s$exclude) = 0);
+            else if compare(11,.buf$fcb(f$name),.search(i).name(0)) then
+                 return((search$ops and s$exclude) = 0);
+    end;
+    return((search$ops and s$exclude) <> 0);
+end match;
+
+dcl hash$table$size lit '128',               /* must be power of 2         */
+    hash$tabl<62> (hash$table$size<7A> address public at (.memory),
+                                             /* must be initialized on each*/
+    hash$entry$adr address,                  /* disk scan                  */
+    hash$entry based hash$entry$adr address; /* where to put a new entry's */
+                                             /* address                    */
+
+hash$look$up: procedure boolean;
+    dcl (i,found,hash$index) byte;
+    hash$index = 0;
+    do i = f$name to f$namelen + f$typelen by 2;
+        hash$index = hash$index + (buf$fcb(i) and 7fh); /* attributes may   */
+    end;                                     /* only be set w/ 1st extent   */
+    hash$index = hash$index + cur$usr;
+    hash$index = hash$index and (hash$table$size - 1);
+    hash$entry$adr = .hash$table(hash$index);
+    f$i$adr = hash$table(hash$index);
+    
+    found = false;
+    do while f$i$adr <> 0 and not found;
+        if file$info.usr = (buf$fcb(f$drvusr) and 0fh) and
+            compare(f$namelen + f$typelen,.file$info.name(0),.buf$fcb(f$name))
+            then
+            found = true;
+        else
+            do; hash$entry$adr = .file$info.hash$link;   /* assuming no '?' */
+            f$i$adr = file$info.hash$link;               /* in file name     */
+            end;
+    end;
+    if f$i$adr = 0 then
+        return(false);
+    else return(true); 
+end hash$look$up;
+
+store$file$info: procedure boolean;
+        /* Look for file name of last found fcb or xfcb in fileinfo       */
+        /* array, if not found put name in fileinfo array.   Copy other   */
+        /* info to fileinfo or xfcbinfo.   The lookup is hash coded with  */
+        /* collisions handled by linking up file$info records through     */
+        /* the hash$link field of the previous file$info record.          */
+        /* The file$info array grows upward in memory and the xfcbinfo    */
+        /* grows downward.                                                */
+        /*
+                          
+                        -------------------------<---.memory
+       __               |      HASH TABLE       |
+hash = \ of filename -->| root of file$info list|------------>---|
+func   /__ letters      |          .            |                |
+                        |          .            |                |
+        lower memory    -------------------------                |
+                        |    file$info entry    |                |
+                -----<--|          .            | <--------------|
+    (collision) |       |          .            |
+                ------->|          .            |
+                        |          .            |-------------------->|
+                        | last file$info entry  | <- last$f$i$adr     |
+                        |-----------------------|                     |
+                        |                       |                     |
+                        |                       |                     |
+                        |   unused by dsearch,  |                     |
+                        |     used by dsort     |                     |
+                        |      for indices      |                     |
+                        |                       |                     |
+                        |                       |                     | 
+                        |-----------------------|                     |
+                        |    last$xfcb entry    | <- x$i$adr          |
+                        |           .           |                     |
+                        |           .           |                     |
+                        |           .           | <-------------------|
+                        |   first xfcb entry    |
+                        |-----------------------|
+                        |   un-usuable memory   | <- maxb
+  higher memory         -------------------------                        */
+
+
+    dcl (i, j) byte,
+        block$num address;
+
+    if not hash$look$up then           /* not in table already          */ 
+                           /* hash$entry is where to put adr of new entry */ 
+    do;                    /* copy to new position in file info array   */
+        if f$i$adr + 2 * size(file$info) > x$i$adr then
+            return(false);                     /* out of memory         */
+        f$i$adr = (last$f$i$adr := last$f$i$adr + size(file$info));
+        filesfound = filesfound + 1;
+        call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name);
+        file$info.usr = buf$fcb(f$drvusr) and 0fh;
+        file$info.bytes,file$info.kbytes,file$info.recs$lword,
+            file$info.recs$hbyte, file$info.x$i$adr,file$info.hash$link = 0;
+        hash$entry = f$i$adr;           /* save the address of file$info    */
+    end;                                /* zero totals for the new file     */
+
+    /* else hash$lookup has set f$i$adr to the file entry already in the    */
+    /* hash table                       */  
+
+                                        /* save xfcb or fcb type info       */
+    if (buf$fcb(f$drvusr) and xfcb$type) <> 0 then
+    do;                                        /* XFCB                      */
+        if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then
+            return(false);                /* out of memory                  */
+        x$i$adr = x$i$adr - size(xfcb$info);
+        call move(8,.buf$fcb(xf$create),.xfcb$info.create);
+        xfcb$info.passmode = buf$fcb(xf$passmode);
+        file$info.x$i$adr = x$i$adr;
+    end;
+    else            /* regular fcb, file$info  is already positioned        */
+    do;                                  /* add to number of records        */
+        call add3byte(.file$info.recs$lword, buf$fcb(f$rc)
+            + shl(double(buf$fcb(f$ex) and dpb.extmsk) , 7));
+        file$info.name(f$arc-1) = file$info.name(f$arc-1) and buf$fcb(f$arc);
+                               /* 0 archive bit if it is 0 in any dir entry */
+                                          /* count kilobytes                */
+        i = 1;                            /* 1 or 2 byte block numbers ?    */
+        if dpb.blk$max > 255 then
+            i = 2;
+        do j = f$diskmap to f$diskmap + diskmaplen - 1 by i;
+            block$num = buf$fcb(j);
+            if i = 2 then                      /* word block numbers        */
+                block$num = block$num or buf$fcb(j+1);
+            if block$num <> 0 then             /* allocated                 */
+                call add$block(.file$info.kbytes,.file$info.bytes);
+        end;
+    end;
+    return(true);                             /* success                    */
+end store$file$info;
+
+get$files: procedure public;       /* with one scan through directory get   */
+    dcl dcnt byte;                 /* files from currently selected drive   */
+
+    last$f$i$adr = end$adr;
+    /* last$f$i$adr is the address of the highest file info record    */
+    /* in memory                                                      */
+
+    do dcnt = 0 to hash$table$size - 1;   /* init hash table                */
+        hash$table(dcnt) = 0;
+    end;
+
+    x$i$adr = maxb;               /* top of mem, put xfcb info here         */
+    call set$drive;
+    dir$label,filesfound, used$de = 0;
+    
+    fcb(f$drvusr) = '?';          /* match all dir entries                  */
+    dcnt = search$first(.fcb);
+    do while dcnt <> 255;
+        buf$fcb$adr = shl(dcnt and 11b,5)+.buff;  /* dcnt mod 4 * 32        */
+        if buf$fcb(f$drvusr) <> deleted$type then
+        do;
+          used$de = used$de + 1;
+          if buf$fcb(f$drvusr) = dirlabel$type then   /* dir label ?        */
+              dir$label = buf$fcb(f$ex);           /* save label info       */
+          else if match then
+          do;
+              if not store$file$info then         /* store fcb or xfcb info */
+              do;                                 /* out of space           */
+                  call print (.(cr,lf,lf,'Out of Memory',cr,lf,lf,'$'));
+                  return; 
+              end;
+          end;
+        end;
+        call break;
+        dcnt = search$next;                   /* to next entry in directory */
+    end; /* of do while dcnt <> 255 */
+
+end get$files;
+
+end dsearch;
+
+                                                           
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dsh.plm

@@ -0,0 +1,571 @@
+$title ('SDIR - Show')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+dshow:
+do;
+               /* display module for extended directory */
+
+               /* commonly used macros                  */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10',
+        ff literally '12';
+
+dcl buff(128) byte external,
+    fcb (35) byte external;
+
+dcl (cur$drv, cur$usr) byte external;
+
+dcl (os,bdos) byte external,
+    bdos20 lit '20H',
+    bdos30 lit '30H',
+    mpm    lit '10H';
+
+dcl used$de address external;        /* number of used directory entries */
+
+dcl sorted boolean external;
+dcl filesfound address external;
+
+dcl search$ops address external,     /* search options                      */
+    s$dir  lit '1',
+    s$sys  lit '2',
+    s$ro   lit '4',
+    s$rw   lit '8',
+    s$xfcb lit '32',            /* show files with xfcbs                    */
+    s$nonxfcb lit '64',         /*  "     "   without xfcbs                 */
+    s$exclude lit '128';
+
+dcl format byte external,       /* format is one of the following */
+    page$len address external,  /* page size before printing new headers */
+    message boolean external,   /* print titles and msg when no file found */
+    formfeeds boolean external, /* use form feeds to separate headers */
+    form$short lit '0', 
+    form$size lit '1',
+    form$full lit '2';
+
+dcl file$displayed boolean public initial (false);
+
+declare                       /* directory label: special case of XFCB */
+    dirlabel byte external,
+    dirlabeltype       lit '20',        /* identifier on disk          */
+    dl$databyte        lit '12',        /* data byte                   */
+    dl$password        lit '128',       /* masks on data byte          */
+    dl$access          lit '64',
+    dl$update          lit '32',
+    dl$makexfcb        lit '16',
+    dl$exists          lit '1';
+
+dcl
+        buf$fcb$adr address external,       /* index into directory buffer  */
+        buf$fcb based buf$fcb$adr (32) byte,
+                                            /* fcb template for dir         */
+
+        (f$i$adr,last$f$i$adr,end$adr) address external,
+        cur$file address,                   /* number of file currently     */
+                                            /* being displayed              */
+
+                                            /* structure of file info       */ 
+        file$info based f$i$adr structure(
+            usr byte,
+            name (8) byte,
+            type (3) byte,
+            bytes address,        /* byte count (mod kilobyte)        */
+            kbytes address,       /* kilobyte count                   */
+            recs$lword address,   /* record count is 3 byte value     */
+            recs$hbyte byte,      /* low word, high byte              */
+            hash$link address,
+            x$i$adr address),     /* index into time stamp array for  */
+                                  /* this file                        */
+
+        x$i$adr address external,
+        xfcb$info based x$i$adr structure (
+            create (4) byte,
+            update (4) byte,
+            passmode byte);
+
+dcl     f$i$indices$base address external,  /* if sorted then f$i$indices   */
+        f$i$indices based f$i$indices$base (1) address; /* are here         */
+
+dcl dpb$adr address external,        /* disk parameter block address        */
+    dpb based dpb$adr structure
+        (spt address, blkshf byte, blkmsk byte, extmsk byte, blkmax address,
+         dirmax address, dirblk address, chksiz address, offset address);
+
+printchar: procedure (char) external;
+    dcl char byte;
+end printchar;
+
+print: procedure (string$adr) external;      /* BDOS call # 9               */
+    dcl string$adr address;
+end print;
+
+search$first: procedure(fcb$adr) byte external;
+    dcl fcb$adr address;
+end search$first;
+
+search$next: procedure byte external;
+end search$next;
+
+break: procedure external;
+end break;
+
+display$time$stamp: procedure (ts$adr) external;     /* in dts.plm */
+    dcl ts$adr address;
+end display$time$stamp;
+
+printb: procedure external;
+end printb;
+
+crlf: procedure external;
+end crlf;
+
+printfn: procedure(fname$adr) external;
+    dcl fname$adr address;
+end printfn;
+
+pdecimal: procedure(v,prec,zerosup) external;
+                       /* print value val, field size = (log10 prec) + 1  */
+                       /* with leading zero suppression if zerosup = true */
+    declare v address,                           /* value to print        */
+            prec address,                        /* precision             */
+            zerosup boolean;                     /* zero suppression flag */
+end pdecimal;
+
+p3byte: procedure(byte3adr,prec)external;
+                                /* print 3 byte value with 0 suppression */
+      dcl (byte3adr,prec) address; /* assume high order bit is < 10         */
+end p3byte;
+
+terminate: procedure external;
+end terminate;
+
+match: procedure boolean external;
+    dcl fcb$adr address;
+end match;
+
+add3byte: procedure (byte3$adr,word$amt) external;
+    dcl (byte3$adr, word$amt) address;
+end add3byte;            /* add word to 3 byte structure */
+
+add3byte3: procedure (byte3$adr,byte3) external;
+    dcl (byte3$adr, byte3) address;
+end add3byte3;            /* add 3 byte quantity to 3 byte total */
+
+shr3byte: procedure (byte3$adr) external;
+    dcl byte3$adr address;
+end shr3byte;
+
+set$drive: procedure external;
+end set$drive;
+
+/* routines local to this module */
+
+dcl     total$kbytes structure (    /* grand total k bytes of files matched */
+          lword address,
+          hbyte byte),
+        total$recs structure (      /* grand total records of files matched */
+          lword address,
+          hbyte byte),
+        total$1k$blocks structure(  /* how many 1k blocks are allocated     */
+          lword address,
+          hbyte byte);
+ 
+add$totals: procedure;
+dcl temp structure (lword address, hbyte byte);
+
+    call add3byte(.total$kbytes,file$info.kbytes);
+    if file$info.bytes > 0 then           /* round up to nearest k */
+        call add3byte(.total$kbytes,1);   /* actual disk space allocated */
+
+    call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */
+    temp.lword = file$info.recs$lword;
+    temp.hbyte = file$info.recs$hbyte;
+    call shr3byte(.temp);                 /* disk space if 1k blksiz */
+    call add3byte3(.total$1k$blocks,.temp);
+    if (file$info.recs$lword and 07h) <> 0 then
+         call add3byte(.total$1k$blocks,1);    /* round up */
+    
+end add$totals;
+
+mult23: procedure(index) address external;
+    dcl index address;
+end mult23;
+
+                /* fcb and dma buffer constants */
+declare
+    f$drvusr          lit '0',        /* drive and user field          */
+    f$name            lit '1',        /* file name                     */
+    f$rw              lit '9',        /* high bit is R/W attribute     */
+    f$dirsys          lit '10',       /* high bit is dir/sys attribute */
+    f$arc             lit '11',       /* high bit is archive attribute */
+    f$ex              lit '12';
+
+declare                                 /* XFCB                        */
+    xfcb$type          lit '10',        /* identifier on disk          */
+    xf$passmode        lit '12',        /* pass word protection mode   */
+    xf$pass            lit '16',        /* XFCB password               */
+    passlen            lit '8',         /* password length             */
+    xf$create          lit '25',        /* creation/access time stamp  */
+    xf$update          lit '29';        /* update time stamp           */
+
+declare                                 /* password mode of xfcb       */
+    pm$read            lit '80h',
+    pm$write           lit '40h',
+    pm$delete          lit '20h';
+
+dcl files$per$line byte;
+dcl cur$line address;
+
+dcl hdr (*) byte data      ('    Name     Bytes   Recs   Attributes $');
+dcl hdr$bars (*) byte data ('------------ ------ ------ ------------$');
+dcl hdr$pu (*) byte data        ('  Prot      Update    $');
+dcl hdr$xfcb$bars (*) byte data (' ------ --------------  --------------$');
+dcl hdr$access (*) byte data                          ('      Access    $');
+dcl hdr$create (*) byte data                          ('      Create    $');
+                                   /* example date        04/02/55 00:34  */
+
+display$file$info: procedure;
+                                                    /* print filename.typ   */
+    call printfn(.file$info.name(0));
+    call printb;
+    call pdecimal(file$info.kbytes,10000,true);
+    cal<61> printchar('k')<29>                           /<2F> u<> t<> 3<> Me<4D> - Byte<74>  */
+                                                   /* or 32,000k            */
+    call printb;
+    call p3byte(.file$info.recs$lword,1);          /* records               */
+    call printb;
+    if rol(file$info.name(f$dirsys-1),1) then      /* Type                  */
+       call print(.('Sys$'));
+    else call print(.('Dir$'));
+    call printb;
+    if rol(file$info.name(f$rw-1),1) then
+        call print(.('RO$'));
+    else call print(.('RW$'));
+    call printb;
+    if  rol(file$info.name(f$arc-1),1) then        /* arc bit was on in all */
+        call print$char('A');                      /* dir entries           */
+    else call printb;
+    if rol(file$info.name(0),1) then
+        call print$char('1');
+    else call printb;
+    if rol(file$info.name(1),1) then
+        call print$char('2');
+    else call printb;
+    if rol(file$info.name(2),1) then
+        call print$char('3');
+    else call printb;
+    if rol(file$info.name(3),1) then
+        call print$char('4');
+    else call printb;
+end display$file$info;
+
+display$xfcb$info: procedure;
+        if file$info.x$i$adr <> 0 then
+        do;
+            call printb;
+            x$i$adr = file$info.x$i$adr;
+            if (xfcb$info.passmode and pm$read) <> 0 then
+                call print(.('Read  $'));
+            else if (xfcb$info.passmode and pm$write) <> 0 then
+                call print(.('Write $'));
+            else if (xfcb$info.passmode and pm$delete) <> 0 then
+                call print(.('Delete$'));
+            else
+                call print(.('None  $'));
+            call printb;
+            if (xfcb$info.update(0) <> 0 or xfcb$info.update(1) <> 0) then
+                call display$timestamp(.xfcb$info.update);
+            else call print(.('              $'));
+                call printb; call printb;
+            if (xfcb$info.create(0) <> 0 or xfcb$info.create(1) <> 0) then
+                 call display$timestamp(.xfcb$info.create(0));
+                                                /* Create/Access */
+        end;
+end display$xfcb$info;
+
+dcl first$title boolean initial (true);
+
+display$title: procedure;
+
+    if formfeeds then
+        call print$char(ff);
+    else if not first$title then
+        call crlf;
+    call print(.('Directory For Drive $'));
+    call printchar('A'+ cur$drv); call printchar(':');
+    if bdos >= bdos20 then 
+    do;
+        call print(.('  User $'));
+        call pdecimal(cur$usr,10,true);
+    end;
+    call crlf;
+    cur$line = 2;
+    first$title = false;
+end display$title;
+
+short$display: procedure (fname$adr);
+    dcl fname$adr address;
+    if cur$file mod files$per$line = 0 then
+        do;
+            if cur$line mod page$len = 0 then
+            do; call crlf;
+                call display$title;
+                call crlf;
+            end;
+            else
+                call crlf;
+            cur$line = cur$line + 1;
+            call printchar(cur$drv + 'A');
+        end;
+    else call printb;
+    call print(.(': $'));
+    call printfn(fname$adr);
+    call break;
+    cur$file = cur$file + 1;
+end short$display;
+
+test$att: procedure(char,off,on) boolean;
+    dcl (char,off,on) byte;
+    if (80h and char) <> 80h and (off and search$ops) <> 0 then
+        return(true);
+    if (80h and char) = 80h and (on and search$ops) <> 0 then
+        return(true);
+    return(false);
+end test$att;
+
+right$attributes: procedure(name$adr) boolean;
+    dcl name$adr address,
+        name based name$adr (1) byte;
+    return 
+        test$att(name(f$rw-1),s$rw,s$ro) and
+        test$att(name(f$dirsys-1),s$dir,s$sys);
+end right$attributes;
+
+short$dir: procedure;
+    dcl dcnt byte;
+    fcb(f$drvusr) = '?';
+    files$per$line = 4;
+    dcnt = search$first(.fcb);
+    call set$drive;
+    do while dcnt <> 0ffh;
+        buf$fcb$adr = shl(dcnt and 11b,5)+.buff;  /* dcnt mod 4 * 32        */
+        if (buf$fcb(f$drvusr) and 0f0h) = 0 and buf$fcb(f$ex)<= dpb.extmsk
+            then                            /* no dir labels, xfcbs */
+            if match then
+                if right$attributes(.buf$fcb(f$name)) then
+                    call short$display(.buf$fcb(f$name));
+        dcnt = search$next;
+    end;
+end short$dir;
+
+dcl index address;
+
+getnxt$file$info: procedure;
+dcl right$usr boolean;
+    right$usr = false;
+    if sorted then
+        do while not right$usr;
+           if index < filesfound then 
+           do; f$i$adr = mult23(f$i$indices(index));
+               index = index + 1;
+               right$usr = file$info.usr = cur$usr;
+           end;
+           else
+           do; f$i$adr = end$adr;      /* no more file$info recs */
+               right$usr = true;
+           end;
+        end;
+    else
+        do while not right$usr and f$i$adr <> end$adr;
+            f$i$adr = f$i$adr - size(file$info);
+            right$usr = file$info.usr = cur$usr;
+        end;
+end getnxt$file$info;
+
+size$display: procedure;
+    if (format and form$size) <> 0 then
+        files$per$line = 3;
+    else files$per$line = 4;
+    do while f$i$adr <> end$adr;
+    if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb)   <> 0) or
+        (file$info.x$i$adr  = 0 and (search$ops and s$nonxfcb) <> 0)) and
+        right$attributes(.file$info.name(0)) then 
+        do;
+            cal<61> add$totals;
+            call short$display(.file$info.name(0));
+            call pdecimal(file$info.kbytes,10000,true);
+            call print(.('k$'));
+        end;
+        call getnxt$file$info;
+    end;
+end size$display;
+
+display$no$dirlabel: procedure;
+    files$per$line = 2;
+    do while f$i$adr <> end$adr;
+     if right$attributes(.file$info.name(0)) then
+     do;
+      if cur$file mod files$per$line = 0 then  /* need new line */
+      do;
+        if cur$line mod page$len = 0 then
+        do; call crlf;
+            call display$title;
+            call crlf;
+            call print(.hdr);
+            if (not sorted and f$i$adr <> end$adr + size(file$info)) or
+               (sorted and index < filesfound) then
+            do; call printb;                     /* then two sets of hdrs  */
+                call print(.hdr);                /* more than 1 file left  */
+            end;
+            call crlf;
+            call print(.hdr$bars);
+            if (not sorted and f$i$adr <> end$adr + size(file$info)) or
+               (sorted and index < filesfound) then
+            do; call printb;
+                call print(.hdr$bars);
+            end;
+            call crlf;
+            cur$line = cur$line + 3;
+        end;
+        else
+        do; call crlf;
+            cur$line = cur$line + 1;
+        end; 
+      end;
+      else
+        call printb;                           /* separate the files        */
+
+      call display$file$info;
+      cur$file = cur$file + 1;
+      call add$totals;
+      call break;
+     end; 
+     call getnxt$file$info;
+    end;
+end display$no$dirlabel;
+
+display$with$dirlabel: procedure;
+    files$per$line = 1;
+    do while f$i$adr <> end$adr;
+      if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb) <> 0) or
+         (file$info.x$i$adr  = 0 and (search$ops and s$nonxfcb) <> 0)) and
+         right$attributes(.file$info.name(0)) then 
+      do;
+        cur$file = cur$file + 1;
+        if cur$line mod page$len = 0 then
+        do; call crlf;
+            call display$title; 
+            call crlf;
+            call print(.hdr);
+            call print(.hdr$pu);
+            if (dirlabel and dl$access) <> 0 then
+                call print(.hdr$access);
+            else
+                call print(.hdr$create);
+            call crlf;
+            call print(.hdr$bars);
+            call print(.hdr$xfcb$bars);
+            cur$line = cur$line + 2;
+        end;
+        call crlf;
+        call display$file$info;        /* display non bdos 3.0 file info    */
+        call display$xfcb$info;
+        call break;
+        cur$line = cur$line + 1;
+        call add$totals;
+      end;
+      call getnxt$file$info;
+    end;
+end display$with$dirlabel;
+
+show$files: procedure public;    /* MODULE ENTRY POINT         */
+                                 /* display the collected data */
+    cur$line, cur$file = 0;      /* force titles and new line  */
+    totalkbytes.lword, totalkbytes.hbyte, totalrecs.lword, totalrecs.hbyte =0;
+    total$1k$blocks.lword, total$1k$blocks.hbyte = 0;
+    f$i$adr = last$f$i$adr + size(file$info);  /* initial if no sort */
+    index = 0;                                 /* initial if sorted  */
+    call getnxt$file$info;       /* base file info record      */
+
+    if format > 2 then
+    do;
+        call print(.('Illegal Format Value$'));
+        call terminate;
+    end;
+    do case format;              /* format = */   
+        call short$dir;                       /* form$short          */
+        call size$display;                    /* form$size           */
+                                              /* form = full         */
+        if (dir$label and dl$exists) = 0 or ((search$ops and s$xfcb) = 0 and
+            (search$ops and s$nonxfcb) <> 0) then
+            call display$no$dirlabel;
+        else
+        call display$with$dirlabel;
+    end;
+
+    if cur$file > 1 and format <> form$short then        /* print totals */
+    do;
+        if (page$len <> 0) and (cur$line + 4 > page$len) and formfeeds then
+        do;
+            call printchar(cr);
+            call printchar(ff);                 /* need a new page ? */
+        end;
+        else
+        do;
+            call crlf;
+            call crlf;
+        end;
+        call print(.(      'Total Bytes     = $'));
+        call p3byte(.total$kbytes,1);         /* 6 digit max */
+        call printchar('k');
+        call print(.('  Total Records = $'));
+        call p3byte(.total$recs,10);      /* 7 digit max */
+        call print(.('  Files Found = $'));
+        call pdecimal(cur$file,1000,true);    /* 4 digit max */
+        call print(.(cr,lf,'Total 1k Blocks = $'));
+        call p3byte(.total$1k$blocks,1);           /* 6 digit max */
+        call print(.('   Used/Max Dir Entries For Drive $'));
+        call print$char('A' + cur$drv);
+        call print$char(':'); call printb;
+        call pdecimal(used$de,1000,true);
+        call print$char('/');
+        call pdecimal(dpb.dirmax + 1,1000,true);
+    end;
+
+    if cur$file = 0 then
+    do;
+        if message then
+        do; call crlf;
+            call display$title;
+            call print(.('File Not Found.',cr,lf,'$'));
+        end;
+        call break;
+    end;
+    else
+    do; file$displayed = true;
+        if not formfeeds then
+            call print(.(cr,lf,'$'));
+    end;
+
+end show$files;
+
+end dshow;
+
+                                   
+
+                         
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dso.plm

@@ -0,0 +1,158 @@
+$title ('SDIR - Sort')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+dsort:
+do;
+                /* sort module for extended dir */
+
+                /* commonly used macros */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        word lit 'address',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10';
+
+print: procedure(str$adr) external;
+dcl str$adr address;
+end print;
+
+dcl sorted boolean public;         /* set by this module if successful sort */
+
+declare
+        buf$fcb$adr address external,     /* index into directory buffer */
+        buf$fcb based buf$fcb$adr (32) byte,
+                                        /* fcb template for dir        */
+
+        (f$i$adr, end$adr, last$f$i$adr, x$i$adr, filesfound)
+             address external,
+                                    /* indices into file$info array    */
+        file$info based f$i$adr structure(
+            user byte,
+            name (8) byte,
+            type (3) byte,
+            bytes address,        /* byte count (mod kilobyte)        */
+            kbytes address,       /* kilobyte count                   */
+            recs$lword address,   /* record count is 3 byte value     */
+            recs$hbyte byte,      /* low word, high byte              */
+            hash$link address,
+            x$i$adr address),     /* index into time stamp array for  */
+                                  /* this file                        */
+        mid$adr address,
+        mid$file$info based mid$adr structure(
+            user byte,
+            name (8) byte,
+            type (3) byte,
+            bytes address,        /* byte count (mod kilobyte)        */
+            kbytes address,       /* kilobyte count                   */
+            recs$lword address,   /* record count is 3 byte value     */
+            recs$hbyte byte,      /* low word, high byte              */
+            hash$link address,
+            x$i$adr address);     /* index into time stamp array for  */
+                                  /* this file                        */
+
+mult23: procedure(index) address public;
+    dcl index address;   /* return address of file$info numbered by index */
+    return shl(index, 4) + shl(index,2) + shl(index,1) + index + end$adr +
+        size(file$info);
+        /* index * size(file$info) + base of file$info array */
+end mult23;
+
+lessthan: procedure( str1$adr, str2$adr) boolean;
+    dcl (i,c1,c2) byte,                   /* true if str1 < str2            */
+        (str1$adr, str2$adr) address,     /* sorting on name and type field */
+        str1 based str1$adr (1) byte,     /* only, assumed to be first in   */
+        str2 based str2$adr (1) byte;     /* file$info record */
+    do i = 0 to 10;
+        if (c1:=(str1(i) and 7fh)) <> (c2:=(str2(i) and 7fh)) then
+            return(c1 < c2);
+    end;
+    return(false);
+end lessthan;
+
+dcl f$i$indices$base address public,
+    f$i$indices based f$i$indices$base (1) address;
+
+qsort: procedure(l,r);
+dcl (l,r,i,j,temp) address,
+    stacksiz lit '14',     /* should always be able to sort 2 ** stacksiz */
+    stack (stack$siz) structure (l address, r address),
+    sp byte;
+
+    sp = 0; stack(0).l = l; stack(0).r = r;
+
+    do while sp < stack$siz - 1;
+        l = stack(sp).l; r = stack(sp).r; sp = sp - 1;
+        do while l < r;
+            i = l; j = r;
+            mi<6D>$adr <20> mult23(f$i$indices(shr(l+r,1))<29>;
+            do while i <= j;
+                f$i$adr = mult23(f$i$indices(i));
+                do while lessthan(f$i$adr,mid$adr);
+                    i = i + 1;
+                    f$i$adr = mult23(f$i$indices(i));
+                end;
+                f$i$adr = mult23(f$i$indices(j));
+                do while lessthan(mid$adr,f$i$adr);
+                    j = j - 1;
+                    f$i$adr = mult23(f$i$indices(j));
+                end;
+                if i <= j then
+                do; temp = f$i$indices(i); f$i$indices(i) = f$i$indices(j); 
+                    f$i$indices(j) = temp;
+                    i = i + 1;
+                    if j > 0 then j = j - 1;
+                end;
+            end;  /* while i <= j    */
+            if j - l < r - i then
+            do; if i < r then
+                do; sp = sp + 1; stack(sp).l = i; stack(sp).r = r;
+                end;
+                r = j;     /* continue sorting left partition */
+            end;
+            else
+            do; if l < j then
+                do; sp = sp + 1; stack(sp).l = l; stack(sp).r = j;
+                end;
+                l = i;     /* continue sorting right partition */
+            end;
+        end;      /* while l < r              */
+    end;          /* while sp < stack$siz - 1 */
+    if sp <> 255 then
+        call print(.(cr,lf,lf,'Sort Stack Overflow',cr,lf,'$'));
+    else sorted = true;
+end qsort;
+
+sort: procedure public;
+    dcl i address;
+    f$i$indices$base = last$f$i$adr + size(file$info);
+    if filesfound < 2 then
+        return;
+    if shr((x$i$adr - f$i$indices$base),1) < filesfound then
+    do;
+        call print(.(cr,lf,lf,'Not enough memory for sort',cr,lf,lf,'$'));
+        return;
+    end;
+    do i = 0 to filesfound - 1;
+        f$i$indices(i) = i;                       /* initialize f$i$indices */
+    end;
+    call qsort(0,filesfound - 1);
+    sorted = true;
+end sort;
+
+end dsort;
+
+                                     
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/dts.plm

@@ -0,0 +1,248 @@
+$title ('SDIR - Time Stamp')
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+dtimestamp:
+do;
+       /* Display time stamp module for extended directory */
+       /* Time & Date ASCII Conversion Code	           */
+       /* From MP/M 1.1 TOD program		           */
+
+       /* commonly used macros                             */
+
+declare dcl literally 'declare',
+        lit literally 'literally',
+        word lit 'address',
+        true literally '1',
+        false literally '0',
+        boolean literally 'byte',
+        cr literally '13',
+        lf literally '10';
+
+print$char: procedure (char) external;
+    declare char byte;
+end print$char;
+
+terminate: procedure external;
+end terminate;
+
+declare tod$adr address;
+declare tod based tod$adr structure (
+  opcode byte,
+  date address,
+  hrs byte,
+  min byte,
+  sec byte,
+  ASCII (21) byte );
+
+declare string$adr address;
+declare string based string$adr (1) byte;
+declare index byte;
+
+emitchar: procedure(c);
+    declare c byte;
+    string(index := index + 1) = c;
+    end emitchar;
+
+emitn: procedure(a);
+    declare a address;
+    declare c based a byte;
+    do while c <> '$';
+      string(index := index + 1) = c;
+      a = a + 1;
+    end;
+    end emitn;
+
+emit$bcd: procedure(b);
+    declare b byte;
+    call emitchar('0'+b);
+    end emit$bcd;
+
+emit$bcd$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(shr(b,4));
+    call emit$bcd(b and 0fh);
+    end emit$bcd$pair;
+
+emit$colon: procedure(b);
+    declare b byte;
+    call emit$bcd$pair(b);
+    call emitchar(':');
+    end emit$colon;
+
+emit$bin$pair: procedure(b);
+    declare b byte;
+    call emit$bcd(b/10);	/* makes garbage if not < 10 */
+    call emit$bcd(b mod 10);
+    end emit$bin$pair;
+
+emit$slant: procedure(b);
+    declare b byte;
+    call emit$bin$pair(b);
+    call emitchar('/');
+    end emit$slant;
+
+declare
+    base$year lit '78',   /* base year for computations */
+    base$day  lit '0',    /* starting day for base$year 0..6 */
+    month$days (*) word data
+    /* jan feb mar apr may jun jul aug sep oct nov dec */
+    (  000,031,059,090,120,151,181,212,243,273,304,334);
+
+leap$days: procedure(y,m) byte;
+    declare (y,m) byte;
+    /* compute days accumulated by leap years */
+    declare yp byte;
+    yp = shr(y,2); /* yp = y/4 */
+    if (y and 11b) = 0 and month$days(m) < 59 then
+        /* y not 00, y mod 4 = 0, before march, so not leap yr */
+        return yp - 1;
+    /* otherwise, yp is the number of accumulated leap days */
+    return yp;
+    end leap$days;
+
+declare word$value word;
+
+get$next$digit: procedure byte;
+    /* get next lsd from word$value */
+    declare lsd byte;
+    lsd = word$value mod 10;
+    word$value = word$value / 10;
+    return lsd;
+    end get$next$digit;
+
+bcd:
+  procedure (val) byte;
+    declare val byte;
+    return shl((val/10),4) + val mod 10;
+  end bcd;
+
+declare (month, day, year, hrs, min, sec) byte;
+
+bcd$pair: procedure(a,b) byte;
+    declare (a,b) byte;
+    return shl(a,4) or b;
+    end bcd$pair;
+
+
+compute$year: procedure;
+    /* compute year from number of days in word$value */
+    declare year$length word;
+    year = base$year;
+        do while true;
+        year$length = 365;
+        if (year and 11b) = 0 then /* leap year */
+            year$length = 366;
+        if word$value <= year$length then
+            return;
+        word$value = word$value - year$length;
+        year = year + 1;
+        end;
+    end compute$year;
+
+declare
+    week$day  byte, /* day of week 0 ... 6 */
+    day$list (*) byte data
+    ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
+    leap$bias byte; /* bias for feb 29 */
+
+compute$month: procedure;
+    month = 12;
+        do while month > 0;
+        if (month := month - 1) < 2 then /* jan or feb */
+            leapbias = 0;
+        if month$days(month) + leap$bias < word$value then return;
+        end;
+    end compute$month;
+
+declare
+    date$test byte,    /* true if testing date */
+    test$value word;   /* sequential date value under test */
+
+get$date$time: procedure;
+    /* get date and time */
+    hrs = tod.hrs;
+    min = tod.min;
+    sec = tod.sec;
+    word$value = tod.date;
+    /* word$value contains total number of days */
+    week$day = (word$value + base$day - 1) mod 7;
+    call compute$year;
+    /* year has been set, word$value is remainder */
+    leap$bias = 0;
+    if (year and 11b) = 0 and word$value > 59 then
+        /* after feb 29 on leap year */ leap$bias = 1;
+    call compute$month;
+    day = word$value - (month$days(month) + leap$bias);
+    month = month + 1;
+    end get$date$time;
+
+emit$date$time: procedure;
+    if tod.opcode = 0 then
+      do;
+      call emitn(.day$list(shl(week$day,2)));
+      call emitchar(' ');
+      end;
+    call emit$slant(month);
+    call emit$slant(day);
+    call emit$bin$pair(year);
+    call emitchar(' ');
+    call emit$colon(hrs);
+    call emit$colon(min);
+    if tod.opcode = 0 then
+      call emit$bcd$pair(sec);
+    end emit$date$time;
+
+tod$ASCII:
+  procedure (parameter);
+    declare parameter address;
+    declare ret address;
+
+    ret = 0;
+    tod$adr = parameter;
+    string$adr = .tod.ASCII;
+    if	(tod.opcode = 0) or (tod.opcode = 3) then
+    do;
+      call get$date$time;
+      index = -1;
+      call emit$date$time;
+    end;
+    else
+      call terminate;             /* error */
+end tod$ASCII;
+
+  declare lcltod structure (
+    opcode byte,
+    date address,
+    hrs byte,
+    min byte,
+    sec byte,
+    ASCII (21) byte );
+
+display$time$stamp: procedure (tsadr) public;
+    dcl tsadr address,
+	i byte;
+
+     lcltod.opcode = 3;		/* display time and date stamp, no seconds */
+     call move (4,tsadr,.lcltod.date);	/* don't copy seconds */
+     	
+     call tod$ASCII (.lcltod);
+     do i = 0 to 13;
+       call printchar (lcltod.ASCII(i));
+     end;	
+end display$time$stamp;
+
+dcl last$data$byte byte initial(0);
+
+end dtimestamp;
+
+                                         
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_5/sn.plm

@@ -0,0 +1,773 @@
+$title ('SDIR - Scanner')
+scanner:
+do;
+
+/*
+  Copyright (C) 1981
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+
+  Revised:
+    14 Sept 81 by Danny Horovitz
+*/
+
+declare lit literally 'literally',
+        dcl lit 'declare',
+        tab lit '09',
+        cr  lit '13',
+        lf  lit '10',
+        boolean lit 'byte',
+        true lit '0ffffh',
+        false lit '0',
+        f$namelen lit '8',
+        f$typelen lit '3';
+
+dcl debug boolean initial (false);
+
+dcl buff(128) byte external;
+dcl fcb (35) byte external;
+dcl eob lit '0';			/* end of buffer */
+
+mon1: procedure(func,adr) external;
+    dcl func byte,
+        adr address;
+end mon1;
+
+printchar: procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+printb: procedure;
+    call printchar(' ');
+end printb;
+
+crlf: procedure;
+    call printchar(cr);
+    call printchar(lf);
+end crlf;
+
+pdecimal: procedure(v,prec,zerosup);
+    /* print value v with precision prec (1,10,100,1000,10000)
+    with leading zero suppression if zerosup = true */
+    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;
+
+show$buf: procedure;
+dcl i byte;
+i = 1;
+call crlf;
+call mon1(9,.('buff = $'));
+do while buff(i) <> 0;
+    i = i + 1;
+end;
+buff(i) = '$';
+call mon1(9,.buff(1));
+buff(i) = 0;
+end show$buf;
+
+white$space: procedure (str$adr) byte;
+    dcl str$adr address,
+        str based str$adr (1) byte,
+        i byte;
+    i = 0;
+    do while (str(i) = ' ') or (str(i) = tab);
+        i = i + 1;
+    end;
+    return(i);
+end white$space;
+
+delimiter: procedure(char) boolean;
+    dcl char byte;
+    if char = '[' or char = ']' or char = '(' or char = ')' or
+        char = '=' or char = ',' or char = 0 then
+        return (true);
+    return(false);
+end delimiter;
+
+dcl string$marker lit '05ch';
+
+deblank: procedure(buf$adr);
+    dcl (buf$adr,dest) address,
+        buf based buf$adr (128) byte,
+        (i,numspaces) byte,
+        string boolean;
+
+    string = false;
+    if (numspaces := white$space(.buf(1))) > 0 then
+        call move(buf(0) - numspaces + 1,.buf(numspaces+1),.buf(1));
+    i = 1;
+    do while buf(i) <> 0;
+        
+/*      call show$buf;*/
+
+        do while ((numspaces := white$space(.buf(i))) = 0 and (buf(i) <> 0))
+              and not string;
+       /*     call mon1(9,.(cr,lf,'2numspaces = $'));
+            call pdecimal(numspaces,100,false);*/
+/*          call show$buf;*/
+            if buf(i) = '"' then
+            do; 
+                string = true;
+                buf(i) = string$marker;
+            end;
+            i = i + 1;
+        end;
+
+        do while string and buf(i) <> 0; 
+            if buf(i) = '"' then
+                if buf(i+1) = '"' then
+                    call move(buf(0) - i + 1,.buf(i+1), .buf(i));
+                else
+                do;
+                    buf(i) = string$marker;
+                    string = false;
+                end;
+            i = i + 1;
+        end;
+
+        if (numspaces := white$space(.buf(i))) > 0 then
+        do;
+/*            call mon1(9,.(cr,lf,'1numspaces = $'));
+            call pdecimal(numspaces,100,false);*/
+            buf(i) = ' ';
+            dest = .buf(i+1);                    /* save space for ','    */
+            if i > 1 then
+                if delimiter(buf(i-1)) or delimiter(buf(i+numspaces)) then
+                                                 /* write over ' ' with   */
+                    dest = dest - 1;             /* a = [ ] ( )           */
+
+            call move(((buf(0)+1)-(i+numspaces-1)),
+                .buf(i+numspaces),dest);
+            if buf(i) = '"' then
+                string = true;
+            i = i + 1;
+        end;
+
+    end;
+    if buf(i - 1) = ' ' then      /* no trailing blanks */
+        buf(i - 1) = 0;
+    if debug then
+        call show$buf;
+end deblank;
+
+upper$case: procedure (buf$adr);
+     dcl buf$adr address,
+         buf based buf$adr (1) byte,
+         i byte;
+
+     i = 0;
+     do while buf(i) <> eob;
+         if buf(i) >= 'a' and buf(i) <= 'z' then
+             buf(i) = buf(i) - ('a' - 'A');
+         i = i + 1;
+     end;
+end upper$case;
+
+dcl option$max lit '11';
+dcl done$scan lit '0ffffh';
+dcl ident$max lit '11';
+dcl token$max lit '11';
+
+dcl t$null lit '0',
+    t$param  lit '1',
+    t$option lit '2',
+    t$modifier lit '4',
+    t$identifier lit '8',
+    t$string lit '16',
+    t$numeric lit '32',
+    t$filespec lit '64',
+    t$error lit '128';
+
+dcl pcb$base address;
+dcl pcb based pcb$base structure (
+            state address,
+            scan$adr address,
+            token$adr address,
+            token$type byte,
+            token$len byte,
+            p$level byte,
+            nxt$token byte);
+
+dcl     scan$adr address,
+        inbuf based scan$adr (1) byte,
+        in$ptr byte,
+        token$adr address,
+        token based token$adr (1) byte,
+        t$ptr byte,
+        (char, nxtchar, tcount) byte;
+
+digit<EFBFBD> procedur<75> (char) boolean;
+    dcl char byte;
+    return (char >= '0' and char <= '9');
+end digit;
+
+letter: procedure (char) boolean;
+    dcl char byte;
+    return (char >= 'A' and char <= 'Z');
+end letter; 
+
+    eat$char: procedure;
+        char = inbuf(in$ptr := inptr + 1);
+        nxtchar = inbuf(in$ptr + 1);
+    end eat$char;
+ 
+    put$char: procedure(charx);
+        dcl charx byte;
+        if pcb.token$adr <> 0ffffh then
+            token(t$ptr := t$ptr + 1) = charx;
+    end put$char;
+
+    get$identifier: procedure (max) byte;
+        dcl max byte;
+
+        tcount = 0;
+     /* call mon1(9,.(cr,lf,'getindentifier$'));*/
+        if not letter(char) and char <> '$' then
+            return(tcount);
+        do while (letter(char) or digit(char) or char = '_' or
+            char = '$' ) and tcount <= max;
+            call put$char(char);
+            call eat$char;
+            tcount = tcount + 1;
+        end;
+        do while letter(char) or digit(char) or char = '_'
+            or char = '$' ;
+            call eat$char;
+            tcount = tcount + 1;
+        end;
+        pcb.token$type = t$identifier;
+/*      call mon1(9,.(cr,lf,'end of getident$'));  */
+        pcb.token$len = tcount;
+        return(tcount);
+    end get$identifier;
+
+    file$char: procedure (x) boolean;
+        dcl x byte;
+        return(letter(x) or digit(x) or x = '*' or x = '?'
+               or x = '_' or x = '$');
+    end file$char;
+
+    expand$wild$cards: procedure(field$size) boolean;
+        dcl (i,leftover,field$size) byte,
+            save$inptr address;
+
+        field$size = field$size + t$ptr;
+        do while filechar(char) and t$ptr < field$size;
+           if char = '*' then
+           do; leftover = t$ptr;
+               save$inptr = inptr;
+               call eatchar;
+               do while filechar(char);
+                   leftover = leftover + 1;
+                   call eatchar;
+               end;
+               if leftover >= field$size then	/* too many chars */
+               do; inptr = save$inptr;
+                   return(false);
+               end;  
+               do i = 1 to field$size - leftover;
+                   call putchar('?');
+               end;
+               inptr = save$inptr;
+           end;
+           else
+               call putchar(char);
+           call eatchar;
+        end;
+        return(true);
+    end expand$wild$cards;
+
+    get$file$spec: procedure boolean;
+        dcl i byte;
+        do i = 1 to fname$len + ftype$len;
+            token(i) = ' ';
+        end;
+        if nxtchar = ':' then
+           if char >= 'A' and char <= 'P' then
+           do;
+               call putchar(char - 'A' + 1);
+               call eat$char;        /* skip ':'              */ 
+               call eat$char;        /* 1st char of file name */
+        /*     if delimiter(char) or char = ' ' then
+               do i = 1 to fname$len + ftype$len;
+                   token(i) = '?';
+               end;*/
+           end;
+           else
+               return(false);
+        else
+           call putchar(0);                  /* use default drive */
+        
+        if not (letter(char) or char = '$' or char = '_' or char = '*'
+            or char = '?' ) then
+            if token(0) = 0 then
+                return(false);
+
+        if not expand$wild$cards(f$namelen) then
+            return(false);                   /* blank name is illegal */
+        if char = '.' then
+            do; call eat$char;
+            if filechar(char) then
+                do; t$ptr = f$namelen;
+                if not expand$wild$cards(f$typelen) then
+                    return(false);
+                end;
+            end;
+       
+        pcb.token$len = f$name$len + f$type$len + 1;
+        pcb.token$type = t$file$spec; 
+        return(true);
+    end get$file$spec;       
+    
+    get$numeric: procedure(max) boolean;
+        dcl max byte;
+        if not digit(char) then
+             return(false);
+        do while digit(char) and pcb.token$len <= max and
+            char <> eob;
+            call putchar(char);
+            call eat$char;
+            pcb.token$len = pcb.token$len + 1;
+        end;
+        if char = 'H' or char = 'D' or char = 'B' then
+            if pcb.token$len < max then
+            do;
+                 call putchar(char);
+                 call eat$char;
+                 pcb.token$len = pcb.token$len + 1;
+            end;
+            else
+                 return(false);   
+        pcb.token$type = t$numeric;
+        return(true);
+    end get$numeric;   
+
+    get$string: procedure(max) boolean;
+        dcl max byte;
+        if char <> string$marker then
+            return(false);
+        call eatchar;
+        do while char <> string$marker and char <> eob
+            and pcb.token$len < token$max;
+            call putchar(char);
+            call eatchar;
+            pcb.token$len = pcb.token$len + 1;
+        end;
+        
+        do while char <> string$marker and char <> eob;
+            call eat$char;
+        end;
+        if char <> string$marker then
+            return(false);
+        pcb.token$type = t$string;
+        call eat$char;
+        return(true);
+    end get$string;
+
+    get$token$all: procedure boolean;
+        dcl save$inptr byte;
+
+/*      call mon1(9,.(cr,lf,'gettokenall$'));*/
+
+        save$inptr = in$ptr;
+	if get$file$spec then
+            return(true);
+
+/*        call mon1(9,.(cr,lf,'gettokenall - no file$')); */
+        in$ptr = save$inptr - 1; /* need to re-scan, reset buffer pointers */
+        call eat$char;
+        t$ptr = 255;
+        call putchar(0);              /* zero drive byte */
+        
+        if get$identifier(token$max) = 0 then
+            if not get$string(token$max) then
+                 if not get$numeric(token$max) then
+                      return(false);
+ /*       call mon1(9,.(cr,lf,'end gettokenall$'));*/
+        return(true);
+   end get$token$all;
+
+   get$modifier: procedure boolean;
+        if char = ',' or char = ')' or char = 0 then
+        do;
+            pcb.token$type = t$modifier or t$null;
+            return(true);
+        end;
+        if get$token$all then
+        do;
+            pcb.token$type = pcb.token$type or t$modifier;
+            return(true);
+        end;
+        return(false);
+    end get$modifier;
+
+    get$option: procedure boolean;
+        call putchar(0);
+        if get$identifier(token$max) > 0 then
+        do;
+            pcb.token$type = pcb.token$type or t$option;
+            if pcb.token$len > token$max then
+                pcb.token$len = token$max;
+            return(true);
+        end;
+        return(false);
+  end get$option;
+
+   get$param: procedure boolean;
+        if char = ',' or char = ')' or char = 0 then
+        do;
+            pcb.token$type = t$param or t$null;
+            return(true);
+        end;
+        if get$token$all then
+        do;
+            pcb.token$type = pcb.token$type or t$param;
+            return(true);
+        end;
+        return(false);
+    end get$param;
+
+    dcl gotatoken boolean;
+    dcl parens byte initial (0);
+
+    end$state: procedure boolean;
+        if gotatoken then
+        do;
+            pcb.state = .end$state;
+            return(true);
+        end;
+        pcb.token$type = t$null;
+        pcb.scan$adr = 0ffffh;
+        return(true);
+    end end$state;
+   
+    state8: procedure boolean reentrant;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state8, char = $'));
+        call printchar(char); end;
+        if char = 0 then
+            return(end$state);
+        if char = ']' then
+        do;
+            call eatchar;
+            if char = ',' or nxtchar = '(' or nxtchar = ')' then
+                return(state2);
+            else if char = 0 then
+                return(end$state);
+            else
+                return(state1);
+        end;
+        else if char = ' ' or char = ',' then
+        do;
+            call eatchar;
+            return(state3);
+        end;
+        return(state3);
+    end state8;
+
+    state7:procedure boolean reentrant;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state7, char = $'));
+        call printchar(char); end;
+        if char = 0 then
+            return(end$state);
+        if char = ' ' or char = ',' then
+        do;
+            call eat$char;
+            return(state6);
+        end;
+        else
+            if char = ')' then
+            do;
+               call eat$char;
+               return(state8);
+            end;
+        return(false);
+    end state7;
+
+    state6: procedure boolean reentrant;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state6, char = $'));
+        call printchar(char); end;
+        if gotatoken then
+        do;
+            pcb.state = .state6;
+            pcb.nxt$token = t$modifier;
+            return(true);
+        end;
+        if (gotatoken := get$modifier) then
+            return(state7);
+        return(false);
+    end state6;
+
+    state5:procedure boolean reentrant;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state5, nxtchar = $'));
+        call printchar(nxtchar); end;
+        if char = '(' then
+        do;
+            call eat$char;
+            return(state6);
+        end;
+        if gotatoken then
+        do;
+            pcb.state = .state5;
+            pcb.nxt$token = t$modifier;
+            return(true);
+        end;
+        if (gotatoken := get$modifier) then
+               return(state8);
+        return(false);
+    end state5;
+ 
+    state4: procedure boolean reentrant;
+        dcl temp byte;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state4, char = $'));
+        call printchar(char); end;
+        if char = 0 then
+            return(end$state);
+        temp = char;
+        call eatchar;
+        if temp = ',' or temp = ' ' then
+            return(state3);
+        if temp = ']' then
+            if char = '(' or char = ','  or char = ')' then
+                return(state2);
+            else if char = 0 then
+                return(end$state);
+            else
+                return(state1);
+        if temp = '=' then
+            return(state5);
+        return(false);
+    end state4;
+
+    state3: procedure boolean reentrant;
+       if debug then do;
+       call mon1(9,.(cr,lf,'state3, char = $'));
+       call printchar(char); end;
+       if gotatoken then
+       do;
+           pcb.state = .state3;
+           pcb.nxt$token = t$option;
+           return(true);
+       end;
+       if (pcb.plevel := parens ) > 128 then
+            return(false);
+       if (gotatoken := get$option) then
+            return(state4);
+       return(false);
+    end state3;
+
+    state2: procedure boolean reentrant;
+        if debug then do;
+        call mon1(9,.(cr,lf,'state2, char = $'));
+        call printchar(char); end;
+        do while char = ')' or char = 0;
+            if char = 0 then
+                return(end$state);
+            call eat$char;
+            parens = parens - 1;
+        end;
+        if char = '[' then
+        do;
+            call eat$char;
+            return(state3);
+        end;
+        if char = ' ' or char = ','  or char = '(' then
+        do;
+            if char = '(' then
+                 parens = parens + 1;
+            call eat$char;
+            return(state1);
+        end;
+        return(state1);
+    end state$2; 
+    
+    state1: procedure boolean reentrant;
+        if debug then do; 
+        call mon1(9,.(cr,lf,'state1, char = $'));
+        call printchar(char); end;
+
+        if gotatoken then
+        do;
+            pcb.nxt$token = t$param;
+            pcb.state = .state1;
+            return(true);
+        end;
+        do while char = '(' ;
+            parens = parens + 1;
+            call eat$char;
+        end;
+        if (pcb.plevel := parens) > 128 then
+            return(false); 
+        if (gotatoken := get$param) then
+            return(state2);
+        return(false);
+     end state1;
+
+    start$state: procedure boolean;
+        /*if char = '@' then do;
+           debug = true;
+           call eat$char;
+           call mon1(9,.(cr,lf,'startstate, char = $'));
+           call printchar(char); end; */
+
+        if char = 0 then
+            return(end$state);
+        if char = ')' then
+            return(false);
+        if char = '(' then
+        do;
+           parens = parens + 1;
+           call eat$char;
+           return(state1);
+        end;
+        if char = '[' then
+        do;
+            call eat$char;
+            return(state3);
+        end;
+        if (gotatoken := get$param) then
+            return(state2);
+        return(false);
+    end start$state;
+
+/* display$all: procedure;     /* called if debug set */
+
+/*    call mon1(9,.(cr,lf,'scanadr=$'));
+    call pdecimal(pcb.scanadr,10000,false);
+    call mon1(9,.(', tadr=$'));
+    call pdecimal(pcb.token$adr,10000, false);
+    call mon1(9,.(', tlen=$'));
+    call pdecimal(double(pcb.token$len),100, false);
+    call mon1(9,.(', ttype=$'));
+    call pdecimal(double(pcb.token$type),100,false);
+    call mon1(9,.(', plevel=$'));
+    call pdecimal(double(pcb.plevel),100,false);
+    call mon1(9,.(', ntok=$'));
+    call pdecimal(double(pcb.nxt$token),100,false);
+  
+    if (pcb.token$type and t$option) <> 0 then
+        call mon1(9,.(cr,lf,'option  =$'));
+    if (pcb.token$type and t$param) <> 0 then
+        call mon1(9,.(cr,lf,'parm    =$'));
+    if (pcb.token$type and t$modifier) <> 0 then
+        call mon1(9,.(cr,lf,'modifier=$'));
+
+    if (pcb.token$type and t$filespec) <> 0 then
+    do;
+        if fcb(0) =0 then 
+            call print$char('0');
+        else call print$char(fcb(0) + 'A');
+        call print$char(':');
+        fcb(12) = '$';
+        call mon1(9,.fcb(1));
+        call mon1(9,.('			(filespec)$')); 
+    end;
+    if ((pcb.token$type and t$string) or (pcb.token$type and
+        t$identifier) or (pcb.token$type and t$numeric)) <> 0 then
+    do;
+        fcb(pcb.token$len + 1) = '$';  
+        call mon1(9,.fcb(1));
+    end;
+    if pcb.token$type = t$error then
+    do;
+        call mon1(9,.(cr,lf,'scanner error$'));
+        return;
+    end;
+
+    if (pcb.token$type and t$identifier) <> 0 then
+         call mon1(9,.(' (identifier)$'));
+    if (pcb.token$type and t$string) <> 0 then
+         call mon1(9,.(' (string)$'));
+    if (pcb.token$type and t$numeric) <> 0 then
+         call mon1(9,.(' (numeric)$'));
+
+    if (pcb.nxt$token and t$option) <> 0 then
+        call mon1(9,.(cr,lf,'nxt tok = option  $'));
+    if (pcb.nxt$token and t$param) <> 0 then
+        call mon1(9,.(cr,lf,'nxt tok = parm    $'));
+    if (pcb.nxt$token and t$modifier) <> 0 then
+        call mon1(9,.(cr,lf,'nxt tok = modifier$'));
+    call crlf;
+
+end display$all; */
+
+scan: procedure (pcb$adr) public;
+
+    dcl status boolean,
+        pcb$adr address;
+
+    pcb$base = pcb$adr;
+    scan$adr = pcb.scan$adr;
+    token$adr = pcb.token$adr;
+
+    in$ptr, t$ptr = 255;
+    call eatchar;
+
+    gotatoken = false;
+    pcb.nxt$token = t$null;
+    pcb.token$len = 0;
+
+    if pcb.token$type = t$error then         /* after one error, return */
+        return;                              /* on any following calls  */
+    else if pcb.state = .start$state then
+        status = start$state;
+    else if pcb.state = .state$1 then
+        status = state$1;
+    else if pcb.state = .state$3 then
+        status = state$3;
+    else if pcb.state = .state$5 then
+        status = state$5;
+    else if pcb.state = .state$6 then
+        status = state$6;
+    else if pcb.state = .end$state then      /* repeated calls go here   */
+        status = end$state;                  /* after first end$state    */
+    else
+        status = false;
+ 
+    if not status then
+        pcb.token$type = t$error;
+
+    if pcb.scan$adr <> 0ffffh then
+        pcb.scan$adr = pcb.scan$adr + inptr;
+/*  if debug then
+        call display$all;*/
+end scan;
+
+scan$init: procedure(pcb$adr) public; 
+    dcl pcb$adr address;
+
+    pcb$base = pcb$adr;
+    call deblank(pcb.scan$adr);
+    call upper$case(pcb.scan$adr := pcb.scan$adr + 1);
+    pcb.state = .start$state;
+end scan$init;
+
+end scanner;
+
+                                         
+
+                                                                      
+                                                  
+