Files
Digital-Research-Source-Code/MPM OPERATING SYSTEMS/MPM I/MPM I SOURCE/10/gensys.plm
Sepp J Morris 31738079c4 Upload
Digital Research
2020-11-06 18:50:37 +01:00

679 lines
19 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

$title('MP/M 1.1 System Generation')
gensys:
do;
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
/* Gensys Gensys Gensys Gensys Gensys Gensys */
$include (copyrt.lit)
/*
Revised:
7 Jan 80 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);
declare copyright (*) byte data (
'COPYRIGHT (C) 1980, DIGITAL RESEARCH ');
declare serial$number (6) byte data (
'654321');
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;
call mon1 (0,0);
end system$reset;
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$console$buffer:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$console$buffer;
read$console$buffer:
procedure (buffer$address);
declare buffer$address address;
declare buf based buffer$address (1) byte;
buf(1) = 0;
do while buf(1) = 0;
call mon1 (10,buffer$address);
if buf(1) = 0
then call print$console$buffer (.(0ah,'?','$'));
end;
buf(buf(1)+2) = 0;
end read$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);
declare fcb$address address;
call mon1 (16,fcb$address);
end close$file;
search$first:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (17,fcb$address);
end search$first;
search$next:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (18,fcb$address);
end search$next;
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);
declare fcb$address address;
if mon2 (21,fcb$address) <> 0 then
do;
call print$console$buffer (.(
'Disk write error','$'));
call system$reset;
end;
end write$record;
create$file:
procedure (fcb$address);
declare fcb$address address;
if mon2 (22,fcb$address) = 255 then
do;
call print$console$buffer (.(
'Directory full','$'));
call system$reset;
end;
end create$file;
set$DMA$address:
procedure (DMA$address);
declare DMA$address address;
call mon1 (26,DMA$address);
end set$DMA$address;
crlf:
procedure;
call write$console (0dh);
call write$console (0ah);
end crlf;
gnctran:
procedure(b) byte;
declare b byte;
if b < ' ' then return 0dh; /* all non-graphics */
/* translate alpha to upper case */
if b >= 'a' and b <= 'z' then
b = b and 101$1111b; /* upper case */
return b;
end gnctran;
parse:
procedure (pcb$adr) address;
declare pcb$adr address;
declare pcb based pcb$adr structure (
filename$adr address,
fcb$adr address );
declare pcb$filename$adr address;
declare pcb$fcb$adr address;
declare filename based pcb$filename$adr (1) byte;
declare fcb based pcb$fcb$adr (1) byte;
declare
/* return conditions */
endline literally '00000H',
badfile literally '0FFFFH',
/* useful literals */
disk literally 'fcb(0)',
fcbname literally '8', /* end of name */
fcbtype literally '11', /* end of type field */
fcbsize literally '16'; /* partial size of fcb */
declare char byte; /* global temp for current char */
declare fnp byte; /* index into file name buffer */
declare fnlen byte;
gnc:
procedure;
char = gnctran(filename(fnp := fnp + 1));
end gnc;
delimiter:
procedure byte;
declare i byte;
declare del(*) byte data
(0dh,' =.:<>_[],');
do i = 0 to last(del);
if char = del(i) then return true;
end;
return false;
end delimiter;
putchar:
procedure;
fcb(fnlen:=fnlen+1) = char;
/* can check here for ambig ref's "char = '?'" */
end putchar;
fillq:
procedure(len);
/* fill current name or type with question marks */
declare len byte;
char = '?'; /* question mark */
do while fnlen < len;
call putchar;
end;
end fillq;
/* initialize local bases */
pcb$filename$adr = pcb.filename$adr;
pcb$fcb$adr = pcb.fcb$adr;
/* initialize file control block to empty */
char = ' ';
fnlen = 0;
fnp = -1;
do while fnlen < fcbsize-1;
if fnlen = fcbtype then char = 0;
call putchar;
end;
disk = 0;
/* scan next name */
do forever;
/* deblank command buffer */
call gnc;
do while char = ' ';
call gnc;
end;
if delimiter then return badfile;
fnlen = 0;
do while not delimiter;
if fnlen >= fcbname then /* error, file name too long */
return badfile;
if char = '*' then call fillq(fcbname); else call putchar;
call gnc;
end;
/* check for disk name */
if char = ':' then
do;
if not (disk = 0 and fnlen = 1) then
return badfile;
/* must be a disk name */
if (disk := fcb(1) - 'A' + 1) > 26
/* invalid disk name */
then return badfile;
/* valid disk name replace space in name */
else fcb(fnlen) = ' ';
end;
else
do;
/* char is not ':', so file name is set. scan remainder */
/* at least one char scanned */
fnlen = fcbname;
if char = '.' then /* scan file type */
do;
call gnc;
do while not delimiter;
if fnlen >= fcbtype then
/* error, type field too long */
return badfile;
if char = '*'
then call fillq(fcbtype);
else call putchar;
call gnc;
end;
end;
if char = 0dh
then return endline;
else return .filename(fnp);
end;
end; /* of forever */
end parse;
declare pcb structure (
filename$adr address,
fcb$adr address );
declare nxt$chr$adr address;
declare old$nxt$chr$adr address at (.pcb.filename$adr);
declare char byte;
declare ret byte at (.char);
declare delim based nxt$chr$adr byte;
declare fcbin (33) byte;
declare fcbout (33) byte initial (
0,' ',' ',0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0);
declare default$fcb (33) byte data (
0,' ',' ',0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0);
declare rspfcb (33) byte initial (
0,'????????','RSP',0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0);
declare nmb$sect literally '32';
declare buffer (nmb$sect) structure (
record (128) byte);
declare sysdatpg (256) byte at (.buffer(1));
setup$output$file:
procedure;
pcb.filename$adr = .tbuff(1);
pcb.fcb$adr = .fcbout;
nxt$chr$adr = parse (.pcb);
if delim <> '=' then
do;
if nxt$chr$adr = 0 then
do;
call print$console$buffer (.(
'No input files specified','$'));
go to error;
end;
if nxt$chr$adr = 0ffffh then
do;
call print$console$buffer (.(
'Bad output file name','$'));
go to error;
end;
call print$console$buffer (.(
'A ''='' delimeter expected after output file name','$'));
go to error;
end;
call set$DMA$address (.buffer);
if open$file (.fcbout) <> 255
then call delete$file (.fcbout);
call create$file (.fcbout);
end setup$output$file;
setup$input$file:
procedure;
pcb.filename$adr = nxt$chr$adr + 1;
pcb.fcb$adr = .fcbin;
call move (33,.default$fcb,.fcbin);
if (nxt$chr$adr := parse (.pcb)) = 0ffffh then
do;
call print$console$buffer (.(
'Bad input file name','$'));
go to error;
end;
call set$DMA$address (.buffer);
if open$file (.fcbin) = 255 then
do;
call print$console$buffer (.(
'No such input file','$'));
go to error;
end;
end setup$input$file;
copy$file:
procedure;
declare (i,cnt) byte;
declare ok boolean;
do forever;
cnt = 0;
ok = true;
do while ok;
call set$DMA$address (.buffer(cnt));
if (ok := (read$record (.fcbin) = 0)) then
do;
ok = ((cnt:=cnt+1) <> nmb$sect);
end;
else
do;
if cnt = 0 then return;
end;
end;
do i = 0 to cnt-1;
call set$DMA$address (.buffer(i));
call write$record (.fcbout);
end;
if cnt <> nmb$sect then return;
end;
end copy$file;
declare lnbfr (14) byte initial (12);
response:
procedure byte;
call read$console$buffer (.lnbfr);
return (lnbfr(2) = 'y') or (lnbfr(2) = 'Y');
end response;
get$param:
procedure (string$adr,val$adr);
declare (string$adr,val$adr) address;
declare val based val$adr byte;
declare char byte;
declare lbindx byte;
call print$console$buffer (string$adr);
val = 0;
call read$console$buffer (.lnbfr);
lbindx = 1;
do while (char := gnctran(lnbfr(lbindx:=lbindx+1))) <> 0dh;
if char = ',' then
do;
val$adr = val$adr + 1;
val = 0;
end;
else
do;
char = char - '0';
if char > 9 then
do;
if char > 16
then char = char - 7;
else char = 255;
end;
if char < 16 then
do;
val = val*16 + char;
end;
else
do;
char,
val = 0;
call print$console$buffer (.(
'<- bad character, re-enter',0ah,0dh,'$'));
call print$console$buffer (string$adr);
call read$console$buffer (.lnbfr);
end;
end;
end;
call crlf;
end get$param;
make$system$dat:
procedure;
declare i byte;
call move (12,.(0,'SYSTEM DAT'),.fcb);
call set$DMA$address (.buffer);
if open$file (.fcb) <> 255
then call delete$file (.fcb);
call create$file (.fcb);
do i = 0 to 255;
sysdatpg(i) = 0;
end;
call move (43,.copyright,.sysdatpg(144));
call print$console$buffer (.( 0ah,0dh,
'MP/M 1.1 System Generation',0dh,0ah,
'==========================',0dh,0ah,0ah,'$'));
call get$param (.('Top page of memory = ','$'),
.sysdatpg(0));
call get$param (.('Number of consoles = ','$'),
.sysdatpg(1));
call get$param (.('Breakpoint RST # = ','$'),
.sysdatpg(2));
call print$console$buffer (
.('Add system call user stacks (Y/N)? ','$'));
sysdatpg(3) = response;
call print$console$buffer (.(0dh,0ah,
'Z80 CPU (Y/N)? ','$'));
sysdatpg(5) = response;
call print$console$buffer (.(0dh,0ah,
'Bank switched memory (Y/N)? ','$'));
sysdatpg(4) = response;
if sysdatpg(4) then
do;
call print$console$buffer (.(0dh,0ah,
'Banked BDOS file manager (Y/N)? ','$'));
sysdatpg(6) = response;
/* Bank switched memory segment table input */
call print$console$buffer (.(0ah,0dh,
'Enter memory segment table: (ff terminates list)',
0ah,0dh,'$'));
sysdatpg(15) = 0;
i = 16;
do while sysdatpg(i) <> 0ffh;
if i = 48 then
do;
call print$console$buffer (.(
' Entry terminated, 8 segments maximum',0dh,0ah,'$'));
sysdatpg(48) = 0ffh;
end;
else
do;
call get$param (.(' Base,size,attrib,bank = ','$'),
.sysdatpg(i));
if sysdatpg(i) <> 0ffh then
do;
sysdatpg(15) = sysdatpg(15) + 1;
i = i + 4;
end;
end;
end;
end;
else
do;
call print$console$buffer (.(0ah,0dh,
'Memory segment bases, (ff terminates list)',0ah,0dh,'$'));
sysdatpg(i:=112) = 0;
do while sysdatpg(i) <> 0ffh;
i = i + 1;
if i = 121 then
do;
sysdatpg(121) = 0ffh;
call print$console$buffer (.(
' : ff <- forced end, 8 segments maximum',0dh,0ah));
end;
else
do;
call get$param (.(' : ','$'),.sysdatpg(i));
if i = 113 then
do;
if sysdatpg(113) = 0ffh then
do;
sysdatpg(113) = 0;
sysdatpg(114) = 0ffh;
i = 114;
end;
end;
else
do;
if sysdatpg(i) <= sysdatpg(i-1) then
do;
i = i - 1;
call print$console$buffer (.(
'*** error ***',
' segment base must be greater than previous',
0dh,0ah,'$'));
end;
end;
end;
end;
sysdatpg(15) = i - 113;
end;
call set$DMA$address (.sysdatpg);
call write$record (.fcb);
call set$DMA$address (.sysdatpg(128));
call write$record (.fcb);
call close$file (.fcb);
end make$system$dat;
declare rsp$filename (12) byte initial (
'-------- ? ','$');
setup$cmd$tail:
procedure;
declare (i,ret,ptr) byte;
declare actual$rspfcb$adr address;
declare actual$rspfcb based actual$rspfcb$adr (1) byte;
declare nchars literally '45';
call move (nchars,.('mpm.sys=system.dat,xios.spr,',
'bdos.spr,xdos.spr'),.tbuff(1));
if sysdatpg(6)
then tbuff(29) = 'o';
call set$DMA$address (.buffer);
ret = search$first (.rspfcb);
ptr = nchars;
if ret <> 255 then
do;
call print$console$buffer (.(
'Select Resident System Processes: (Y/N)',0dh,0ah,'$'));
do while ret <> 255;
actual$rspfcb$adr = .buffer + (ret mod 4)*32;
call move (8,.actual$rspfcb(1),.rsp$filename);
call print$console$buffer (.rsp$filename);
if response then
do;
tbuff(ptr:=ptr+1) = ',';
do i = 1 to 11;
if i = 9
then tbuff(ptr:=ptr+1) = '.';
if actual$rspfcb(i) <> ' '
then tbuff(ptr:=ptr+1) = actual$rspfcb(i);
end;
end;
call crlf;
ret = search$next (.rspfcb);
end;
end;
tbuff(ptr:=ptr+1) = 0;
tbuff(0) = ptr;
end setup$cmd$tail;
/*
F i l e C o n c a t e n a t i o n
*/
declare last$dseg$byte byte
initial (0);
start:
if fcb(1) = ' ' then
do;
call make$system$dat;
call setup$cmd$tail;
end;
call setup$output$file;
do forever;
call setup$input$file;
call copy$file;
if nxt$chr$adr = 0 then
do;
call close$file (.fcbout);
call system$reset;
end;
end;
error:
call crlf;
tbuff(tbuff(0)+1) = '$';
call print$console$buffer (old$nxt$chr$adr);
call system$reset;
end gensys;