Upload

Digital Research

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/PRLB1.OLD

@@ -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/UTIL5/PRLB1.SUB

@@ -0,0 +1,85 @@
+pip a:=e:cns.plm
+seteof cns.plm
+isx
+plm80 cns.plm pagewidth(80) 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
+ren console.lst=cns.lst
+ren console.lin=cns1.lin
+ren console.sym=cns1.sym
+vax console.lst $$stan
+vax console.sym $$stan
+vax console.lin $$stan
+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 e:console.prl=a:xcns.prl
+pip b:console.prl=a:xcns.prl
+era xcns.prl
+pip a:=e:drst.plm
+seteof drst.plm
+isx
+plm80 drst.plm pagewidth(80) 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
+ren dskreset.lst=drst.lst
+ren dskreset.lin=drst1.lin
+ren dskreset.sym=drst1.sym
+vax dskreset.lst $$stan
+vax dskreset.sym $$stan
+vax dskreset.lin $$stan
+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 e:dskreset.prl=a:xdrst.prl
+pip b:dskreset.prl=a:xdrst.prl
+era xdrst.*
+pip a:=e:print.plm
+seteof print.plm
+isx
+plm80 print.plm pagewidth(80) 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
+ren printer.lst=print.lst
+ren printer.lin=print1.lin
+ren printer.sym=print1.sym
+submit e:prlb1b
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB1B.SUB

@@ -0,0 +1,19 @@
+vax printer.lst $$stan
+vax printer.sym $$stan
+vax printer.lin $$stan
+era print1.com
+pip print.hex=print1.hex,print2.hex
+era print1.hex
+era print2.hex
+zero
+genmod print.hex xprint.prl 
+era *.hex
+pip e:printer.prl=a:xprint.prl
+pip b:printer.prl=a:xprint.prl
+era *.lst
+era *.lin
+era *.sym
+era *.plm
+era xprint*.*
+submit e:prlb2
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB2.OLD

@@ -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/UTIL5/PRLB2.SUB

@@ -0,0 +1,100 @@
+pip a:=e:prlcm.plm
+seteof prlcm.plm
+isx
+plm80 prlcm.plm pagewidth(80) 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
+ren prlcom.lst=prlcm.lst
+ren prlcom.lin=prlcm1.lin
+ren prlcom.sym=prlcm1.sym
+vax prlcom.lst $$stan
+vax prlcom.sym $$stan
+vax prlcom.lin $$stan
+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 e:prlcom.prl=a:xprlcm.prl
+pip b:prlcom.prl=a:xprlcm.prl
+pip a:=e:sub.plm
+seteof sub.plm
+isx
+plm80 sub.plm pagewidth(80) 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
+ren submit.lst=sub.lst
+ren submit.lin=sub1.lin
+ren submit.sym=sub1.sym
+vax submit.lst $$stan
+vax submit.sym $$stan
+vax submit.lin $$stan
+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 e:submit.prl=a:xsub.prl
+pip b:submit.prl=a:xsub.prl
+pip a:=e:tod.plm
+seteof tod.plm
+isx
+plm80 tod.plm pagewidth(80) 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
+ren tod.sym=tod1.sym
+ren tod.lin=tod1.lin
+vax tod.lst $$stan
+vax tod.sym $$stan
+vax tod.lin $$stan
+era tod1.com
+pip tod.hex=tod1.hex,tod2.hex
+era tod1.hex
+era tod2.hex
+zero
+genmod tod.hex xtod.prl 
+era *.hex
+pip e:tod.prl=a:xtod.prl
+pip b:tod.prl=a:xtod.prl
+era *.lst
+era *.lin
+era *.sym
+era xtod*.*
+era xsub.prl
+era xprlcm.*
+submit e:prlb3
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB3.OLD

@@ -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/UTIL5/PRLB3.SUB

@@ -0,0 +1,85 @@
+pip a:=e:user.plm
+seteof user.plm
+isx
+plm80 user.plm pagewidth(80) 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
+ren user.sym=user1.sym
+ren user.lin=user1.lin
+vax user.lst $$stan
+vax user.sym $$stan
+vax user.lin $$stan
+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 e:user.prl=a:xuser.prl
+pip b:user.prl=a:xuser.prl
+era xuser.*
+pip a:=e:abort.plm
+seteof abort.plm
+isx
+plm80 abort.plm pagewidth(80) 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
+ren abortp.lst=abort.lst
+ren abortp.sym=abort1.sym
+ren abortp.lin=abort1.lin
+vax abortp.lst $$stan
+vax abortp.sym $$stan
+vax abortp.lin $$stan
+pip abort.hex=abort1.hex,abort2.hex
+era abort1.hex
+era abort2.hex
+zero
+genmod abort.hex xabort.prl 
+era *.hex
+pip e:abort.prl=a:xabort.prl
+pip b:abort.prl=a:xabort.prl
+era xabort.*
+pip a:=e:mschd.plm
+seteof mschd.plm
+isx
+plm80 mschd.plm pagewidth(80) 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
+ren schedp.lst=mschd.lst
+ren schedp.sym=mschd1.sym
+ren schedp.lin=mschd1.lin
+submit e:prlb3b
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB3B.SUB

@@ -0,0 +1,18 @@
+vax schedp.lst $$stan
+vax schedp.sym $$stan
+vax schedp.lin $$stan
+pip mschd.hex=mschd1.hex,mschd2.hex
+era mschd1.hex
+era mschd2.hex
+zero
+genmod mschd.hex xmschd.prl 
+era *.hex
+pip e:sched.prl=a:xmschd.prl
+pip b:sched.prl=a:xmschd.prl
+era *.lst
+era *.lin
+era *.sym
+era *.obj
+era xmschd.*
+submit e:prlb4
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB4.OLD

@@ -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/UTIL5/PRLB4.SUB

@@ -0,0 +1,68 @@
+pip a:=e:mspl.plm
+seteof mspl.plm
+isx
+plm80 mspl.plm pagewidth(80) 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
+ren spoolp.lst=mspl.lst
+ren spoolp.lin=mspl1.lin
+ren spoolp.sym=mspl1.sym
+vax spoolp.lst $$stan
+vax spoolp.sym $$stan
+vax spoolp.lin $$stan
+era mspl1.com
+pip mspl.hex=mspl1.hex,mspl2.hex
+era mspl1.hex
+era mspl2.hex
+zero
+genmod mspl.hex xmspl.prl 
+pip e:spool.prl=a:xmspl.prl
+pip b:spool.prl=a:xmspl.prl
+era xmspl.prl
+era *.hex
+pip a:=e:mscmn.plm
+seteof mscmn.plm
+pip a:=e:msts.plm
+seteof msts.plm
+isx
+plm80 msts.plm pagewidth(80) 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
+ren mpmstatp.lst=msts.lst
+ren mpmstatp.lin=msts1.lin
+ren mpmstatp.sym=msts1.sym
+vax mpmstatp.lst $$stan
+vax mpmstatp.sym $$stan
+vax mpmstatp.lin $$stan
+era msts1.com
+pip msts.hex=msts1.hex,msts2.hex
+era msts1.hex
+era msts2.hex
+zero
+genmod msts.hex xmsts.prl 
+pip e:mpmstat.prl=a:xmsts.prl
+pip b:mpmstat.prl=a:xmsts.prl
+era *.hex
+era xmsts.*
+submit e:prlb4b

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB4B.BAK

@@ -0,0 +1,60 @@
+pip a:=e:stpsp.plm
+seteof stpsp.plm
+isx
+plm80 stpsp.plm pagewidth(80) 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
+ren stopsplr.lst=stpsp.plm
+ren stopsplr.sym=stpsp1.sym
+ren stopsplr.lin=stpsp1.lin
+vax stopsplr.lst $$stan
+vax stopsplr.sym $$stan
+vax stopsplr.lin $$stan
+era stpsp1.com
+pip stpsp.hex=stpsp1.hex,stpsp2.hex
+era stpsp1.hex
+era stpsp2.hex
+zero
+genmod stpsp.hex xstpsp.prl 
+pip e:stopsplr.prl=a:xstpsp.prl
+pip b:stopsplr.prl=a:xstpsp.prl
+era xstpsp.*
+era *.hex
+pip a:=e:dump.asm
+seteof dump.asm
+pip a:=e:extrn.asm
+seteof extrn.asm
+rmac dump
+xref dump
+vax dump.xrf $$stan
+era dump.asm
+rmac extrn
+xref extrn
+vax extrn.xrf $$stan
+era extrn.asm
+link xdump=dump,extrn[op]
+era dump.rel
+era extrn.rel
+era dump.xrf
+era dump.prn
+era extrn.xrf
+era extrn.prn
+pip e:dump.prl=a:xdump.prl
+pip b:dump.prl=a:xdump.prl
+era xdump.*
+era *.lst
+era *.lin
+era *.sym
+era *.obj
+;end prlb 1 2 3 4 submit
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/PRLB4B.SUB

@@ -0,0 +1,60 @@
+pip a:=e:stpsp.plm
+seteof stpsp.plm
+isx
+plm80 stpsp.plm pagewidth(80) 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
+ren stopsplr.lst=stpsp.lst
+ren stopsplr.sym=stpsp1.sym
+ren stopsplr.lin=stpsp1.lin
+vax stopsplr.lst $$stan
+vax stopsplr.sym $$stan
+vax stopsplr.lin $$stan
+era stpsp1.com
+pip stpsp.hex=stpsp1.hex,stpsp2.hex
+era stpsp1.hex
+era stpsp2.hex
+zero
+genmod stpsp.hex xstpsp.prl 
+pip e:stopsplr.prl=a:xstpsp.prl
+pip b:stopsplr.prl=a:xstpsp.prl
+era xstpsp.*
+era *.hex
+pip a:=e:dump.asm
+seteof dump.asm
+pip a:=e:extrn.asm
+seteof extrn.asm
+rmac dump
+xref dump
+vax dump.xrf $$stan
+era dump.asm
+rmac extrn
+xref extrn
+vax extrn.xrf $$stan
+era extrn.asm
+link xdump=dump,extrn[op]
+era dump.rel
+era extrn.rel
+era dump.xrf
+era dump.prn
+era extrn.xrf
+era extrn.prn
+pip e:dump.prl=a:xdump.prl
+pip b:dump.prl=a:xdump.prl
+era xdump.*
+era *.lst
+era *.lin
+era *.sym
+era *.obj
+;end prlb 1 2 3 4 submit
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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/UTIL5/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;
+