mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 16:34:07 +00:00
1479 lines
40 KiB
Plaintext
1479 lines
40 KiB
Plaintext
$title('CP/M 3 System Generation')
|
|
gencpm:
|
|
do;
|
|
|
|
/*
|
|
Copyright (C) 1982
|
|
Digital Research
|
|
P.O. Box 579
|
|
Pacific Grove, CA 93950
|
|
*/
|
|
|
|
/*
|
|
Revised:
|
|
02 Dec 82 by Bruce Skidmore
|
|
*/
|
|
|
|
declare true literally '0FFH';
|
|
declare false literally '0';
|
|
declare forever literally 'while true';
|
|
declare boolean literally 'byte';
|
|
declare cr literally '0dh';
|
|
declare lf literally '0ah';
|
|
|
|
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;
|
|
|
|
relfix:
|
|
procedure byte external;
|
|
end relfix;
|
|
|
|
setbuf:
|
|
procedure external;
|
|
end setbuf;
|
|
|
|
getdef:
|
|
procedure external;
|
|
end getdef;
|
|
|
|
crtdef:
|
|
procedure external;
|
|
end crtdef;
|
|
|
|
declare reset label external;
|
|
|
|
declare fcb (1) byte external;
|
|
declare fcb16 (1) byte external;
|
|
declare tbuff (1) byte external;
|
|
declare maxb address external;
|
|
declare bitmap (128) byte external;
|
|
|
|
declare FCBin address public;
|
|
|
|
declare bios$fcb (36) byte initial (
|
|
0,'BNKBIOS3','SPR',0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
|
|
|
declare res$fcb (36) byte initial (
|
|
0,'RESBDOS3','SPR',0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
|
|
|
declare bnk$fcb (36) byte initial (
|
|
0,'BNKBDOS3','SPR',0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
|
|
|
declare FCBout (36) byte initial (
|
|
0,'CPM3 ','SYS',0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
|
|
|
declare data$fcb (36) byte public initial (
|
|
0,'GENCPM ','DAT',0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
|
|
|
declare offset byte public;
|
|
declare prgsiz address public;
|
|
declare bufsiz address public;
|
|
declare codsiz address public;
|
|
declare bios$pg byte public;
|
|
declare scb$pg byte public;
|
|
declare res$pg byte public;
|
|
declare bnk$pg byte public;
|
|
declare bnk$off byte public;
|
|
declare res$len byte public;
|
|
declare non$bnk byte public;
|
|
declare dma address public;
|
|
|
|
declare hexASCII (16) byte public data (
|
|
'0123456789ABCDEF');
|
|
|
|
declare lnbfr (14) byte public initial (12);
|
|
|
|
declare sctbfr (1) structure (
|
|
record (128) byte) public at (.memory);
|
|
|
|
declare fcb$msg (13) byte initial (' . $');
|
|
|
|
declare query boolean public;
|
|
|
|
/*
|
|
B D O S P r o c e d u r e & F u n c t i o n C a l l s
|
|
*/
|
|
|
|
system$reset:
|
|
procedure public;
|
|
call mon1 (0,0);
|
|
end system$reset;
|
|
|
|
write$console:
|
|
procedure (char) public;
|
|
declare char byte;
|
|
if display then
|
|
call mon1 (2,char);
|
|
end write$console;
|
|
|
|
print$console$buffer:
|
|
procedure (buffer$address) public;
|
|
declare buffer$address address;
|
|
if display then
|
|
call mon1 (9,buffer$address);
|
|
end print$console$buffer;
|
|
|
|
read$console$buffer:
|
|
procedure (buffer$address) public;
|
|
declare buffer$address address;
|
|
declare buf based buffer$address (1) byte;
|
|
buf(1) = 0;
|
|
if automatic then
|
|
do;
|
|
if not query then
|
|
return;
|
|
end;
|
|
call mon1 (10,buffer$address);
|
|
buf(buf(1)+2) = 0;
|
|
end read$console$buffer;
|
|
|
|
crlf:
|
|
procedure public;
|
|
call write$console (cr);
|
|
call write$console (lf);
|
|
end crlf;
|
|
|
|
error:
|
|
procedure(term$code,err$type,err$msg$adr) public;
|
|
declare (term$code,err$type) byte;
|
|
declare err$msg$adr address;
|
|
display = true;
|
|
call print$console$buffer (.(cr,lf,
|
|
'ERROR: $'));
|
|
call print$console$buffer (err$msg$adr);
|
|
if err$type = 1 then
|
|
call print$console$buffer(.fcb$msg);
|
|
call crlf;
|
|
if term$code then
|
|
call system$reset;
|
|
if automatic and not query then
|
|
do;
|
|
fcb(1),
|
|
fcb16(1) = ' ';
|
|
goto reset;
|
|
end;
|
|
end error;
|
|
|
|
open$file:
|
|
procedure (fcb$address) byte public;
|
|
declare fcb$address address;
|
|
declare fcb based fcb$address (1) byte;
|
|
fcb(12), /* ex = 0 */
|
|
fcb(32) = 0; /* cr = 0 */
|
|
return mon2 (15,fcb$address);
|
|
end open$file;
|
|
|
|
close$file:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
call mon1 (16,fcb$address);
|
|
end close$file;
|
|
|
|
delete$file:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
call mon1 (19,fcb$address);
|
|
end delete$file;
|
|
|
|
read$record:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
if mon2 (20,fcb$address) <> 0 then
|
|
do;
|
|
call error(true,1,.(
|
|
'Reading file: $'));
|
|
end;
|
|
end read$record;
|
|
|
|
write$record:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
if mon2 (21,fcb$address) <> 0 then
|
|
do;
|
|
call error(true,1,.(
|
|
'Writing file: ','$'));
|
|
end;
|
|
end write$record;
|
|
|
|
create$file:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
declare fcb based fcb$address (1) byte;
|
|
if mon2 (22,fcb$address) = 255 then
|
|
do;
|
|
call error(true,0,.(
|
|
'Directory full','$'));
|
|
end;
|
|
fcb(32) = 0; /* set cr = 0 */
|
|
end create$file;
|
|
|
|
set$DMA$address:
|
|
procedure (DMA$address) public;
|
|
declare DMA$address address;
|
|
call mon1 (26,DMA$address);
|
|
end set$DMA$address;
|
|
|
|
read$random$record:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
if mon2 (33,fcb$address) <> 0 then
|
|
do;
|
|
call error(true,1,.(
|
|
'Reading file: ','$'));
|
|
end;
|
|
end read$random$record;
|
|
|
|
write$random$record:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
if mon2 (34,fcb$address) <> 0 then
|
|
do;
|
|
call error(true,1,.(
|
|
'Writing file: ','$'));
|
|
end;
|
|
end write$random$record;
|
|
|
|
set$random$record:
|
|
procedure (fcb$address) public;
|
|
declare fcb$address address;
|
|
call mon1 (36,fcb$address);
|
|
end set$random$record;
|
|
|
|
|
|
/*
|
|
D a t a S t r u c t u r e s
|
|
*/
|
|
|
|
|
|
declare automatic boolean;
|
|
declare display boolean public;
|
|
|
|
declare nmb$sect address;
|
|
|
|
declare link address at (.memory);
|
|
|
|
declare bios$atts(3) address public;
|
|
declare res$atts(3) address public;
|
|
declare bnk$atts(3) address public;
|
|
|
|
declare res$bios$len byte public;
|
|
declare res$base byte public;
|
|
declare pg$dif byte public;
|
|
declare xmove$implemented boolean public;
|
|
declare os$top address;
|
|
|
|
declare system$data (256) byte;
|
|
|
|
declare common$len byte public at (.system$data(1));
|
|
declare banked$len byte public at (.system$data(3));
|
|
declare sys$entry address public at (.system$data(4));
|
|
|
|
declare prt$msg$ptr byte;
|
|
|
|
declare dont$hash boolean;
|
|
|
|
declare wordadr address;
|
|
declare word based wordadr address;
|
|
|
|
declare len byte;
|
|
declare off address;
|
|
declare res$flg byte;
|
|
declare save$mem$top byte;
|
|
|
|
declare drvtbl$adr address public;
|
|
declare drvtbl based drvtbl$adr (16) address;
|
|
|
|
declare dph$adr address public;
|
|
declare dph based dph$adr structure (
|
|
xlt address,
|
|
scratch1(4) address,
|
|
scratch2 byte,
|
|
mf byte,
|
|
dpb address,
|
|
csv address,
|
|
alv address,
|
|
dirbcb address,
|
|
dtabcb address,
|
|
hash address,
|
|
hbank byte);
|
|
|
|
declare dpb$adr address public;
|
|
declare dpb based dpb$adr structure (
|
|
spt address,
|
|
bsh byte,
|
|
blm byte,
|
|
exm byte,
|
|
dsm address,
|
|
drm address,
|
|
al0 byte,
|
|
al1 byte,
|
|
cks address,
|
|
off address,
|
|
psh byte,
|
|
phm byte);
|
|
|
|
declare bnk$swt boolean external;
|
|
declare dbl$alv boolean external;
|
|
declare mem$top byte external;
|
|
declare bnk$top byte external;
|
|
declare lerror boolean external;
|
|
declare bdrive byte external;
|
|
declare con$wid byte external;
|
|
declare con$pag byte external;
|
|
declare bck$spc boolean external;
|
|
declare rubout boolean external;
|
|
declare prt$msg boolean external;
|
|
declare hash(16) boolean external;
|
|
declare num$seg byte external;
|
|
declare crdatf boolean external;
|
|
|
|
declare mem$tbl (17) structure(
|
|
base byte,
|
|
len byte,
|
|
bank byte,
|
|
attr address) external;
|
|
|
|
declare record(16) structure(
|
|
size address,
|
|
attr byte,
|
|
altbnks byte,
|
|
no$dirrecs byte,
|
|
no$dtarecs byte,
|
|
ovlydir$dr byte,
|
|
ovlydta$dr byte,
|
|
dir$resp byte,
|
|
dta$resp byte) external;
|
|
|
|
declare quest(157) boolean external;
|
|
|
|
declare hash$data(16) address public;
|
|
declare hash$space address public;
|
|
declare alloc(16) address public;
|
|
declare alloc$space address public;
|
|
declare chk(16) address public;
|
|
declare chk$space address public;
|
|
|
|
/*
|
|
L o c a l P r o c e d u r e s
|
|
*/
|
|
|
|
movef:
|
|
procedure (count,source$adr,dest$adr) public;
|
|
declare count byte;
|
|
declare (source$adr,dest$adr) address;
|
|
|
|
if count = 0
|
|
then return;
|
|
else call move (count,source$adr,dest$adr);
|
|
|
|
end movef;
|
|
|
|
shift$left:
|
|
procedure (pattern, count) address public;
|
|
declare count byte;
|
|
declare pattern address;
|
|
|
|
if count = 0
|
|
then return pattern;
|
|
else return shl(pattern,count);
|
|
|
|
end shift$left;
|
|
|
|
upper:
|
|
procedure(b) byte public;
|
|
declare b byte;
|
|
|
|
if b < ' ' then return cr; /* 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 upper;
|
|
|
|
valid$drive:
|
|
procedure(drv) boolean public;
|
|
declare drv byte;
|
|
if (drv >= 0) and (drv <= 15) then
|
|
return true;
|
|
call error(false,0,.('Invalid drive.$'));
|
|
return false;
|
|
end valid$drive;
|
|
|
|
get$response:
|
|
procedure (val$adr) public;
|
|
declare val$adr address;
|
|
declare val based val$adr byte;
|
|
call write$console ('(');
|
|
if val = 0ffh
|
|
then call write$console ('Y');
|
|
else call write$console ('N');
|
|
call print$console$buffer (.(') ? ','$'));
|
|
call read$console$buffer (.lnbfr);
|
|
if lnbfr(1) = 0
|
|
then return; /* accept default */
|
|
val = (upper(lnbfr(2)) = 'Y');
|
|
end get$response;
|
|
|
|
dsply$hex:
|
|
procedure (val) public;
|
|
declare val byte;
|
|
call write$console (hexASCII(shr (val,4)));
|
|
call write$console (hexASCII(val and 0fh));
|
|
end dsply$hex;
|
|
|
|
dsply$hex$adr:
|
|
procedure (val) public;
|
|
declare val address;
|
|
call write$console (' ');
|
|
call dsply$hex (high (val));
|
|
call dsply$hex (low (val));
|
|
call write$console ('H');
|
|
end dsply$hex$adr;
|
|
|
|
dsply$hex$high$adr:
|
|
procedure (val) public;
|
|
declare val byte;
|
|
call dsply$hex$adr (double (val)*256);
|
|
end dsply$hex$high$adr;
|
|
|
|
dsply$dec$adr:
|
|
procedure (val) public;
|
|
declare val address;
|
|
declare big address;
|
|
declare (digit,i) byte;
|
|
declare pdigit boolean;
|
|
|
|
pdigit = false;
|
|
digit = '0';
|
|
big = 10000;
|
|
if val = 0 then
|
|
call write$console(digit);
|
|
else
|
|
do;
|
|
do i = 0 to 4;
|
|
do while val >= big;
|
|
pdigit = true;
|
|
digit = digit + 1;
|
|
val = val - big;
|
|
end;
|
|
if pdigit then
|
|
do;
|
|
call write$console(digit);
|
|
digit = '0';
|
|
end;
|
|
big = big / 10;
|
|
end;
|
|
end;
|
|
end dsply$dec$adr;
|
|
|
|
dsply$param:
|
|
procedure (val,base) public;
|
|
declare (val,base) byte;
|
|
call write$console ('(');
|
|
if base = 10 then
|
|
do;
|
|
call write$console ('#');
|
|
call dsply$dec$adr(double(val));
|
|
end;
|
|
else
|
|
do;
|
|
call dsply$hex (val);
|
|
end;
|
|
call print$console$buffer (.(') ? ','$'));
|
|
end dsply$param;
|
|
|
|
get$param:
|
|
procedure (string$adr,val$adr,pbase) public;
|
|
declare (string$adr,val$adr) address;
|
|
declare pbase byte;
|
|
declare base byte;
|
|
declare val based val$adr byte;
|
|
declare string based string$adr (1) byte;
|
|
declare char byte;
|
|
declare lbindx byte;
|
|
|
|
prompt$read:
|
|
procedure;
|
|
call print$console$buffer (string$adr);
|
|
if string(0) = ' ' then
|
|
do;
|
|
call write$console ('(');
|
|
call dsply$hex (val);
|
|
do lbindx = 1 to 2;
|
|
val$adr = val$adr + 1;
|
|
if (lbindx=2) and (not bnk$swt) then
|
|
do;
|
|
val = 0;
|
|
end;
|
|
else
|
|
do;
|
|
call write$console (',');
|
|
call dsply$hex (val);
|
|
end;
|
|
end;
|
|
val$adr = val$adr - 2;
|
|
call print$console$buffer (.(') ? ','$'));
|
|
end;
|
|
else
|
|
do;
|
|
call dsply$param (val,pbase);
|
|
end;
|
|
base = 16;
|
|
lbindx = 1;
|
|
call read$console$buffer (.lnbfr);
|
|
end prompt$read;
|
|
|
|
call prompt$read;
|
|
if lnbfr(1) = 0 then
|
|
do;
|
|
/* accept default value */
|
|
call crlf;
|
|
return;
|
|
end;
|
|
val = 0;
|
|
do while (char := upper(lnbfr(lbindx:=lbindx+1))) <> cr;
|
|
if char = ',' then
|
|
do;
|
|
val$adr = val$adr + 1;
|
|
val = 0;
|
|
base = 16;
|
|
end;
|
|
else
|
|
do;
|
|
if char = '#' then
|
|
do;
|
|
base = 10;
|
|
end;
|
|
else
|
|
do;
|
|
char = char - '0';
|
|
if (base = 16) and (char > 9) then
|
|
do;
|
|
if char > 16
|
|
then char = char - 7;
|
|
else char = 255;
|
|
end;
|
|
if char < base then
|
|
do;
|
|
val = val*base + char;
|
|
end;
|
|
else
|
|
do;
|
|
char,
|
|
val = 0;
|
|
call error (false,0,.(
|
|
'Bad character, re-enter $'));
|
|
call prompt$read;
|
|
val = 0;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
call crlf;
|
|
end get$param;
|
|
|
|
get$seg:
|
|
procedure(type,record$size) byte public;
|
|
|
|
declare (type,k,seg$no) byte;
|
|
declare (record$size,max$attr) address;
|
|
|
|
if not bnk$swt then
|
|
return 0;
|
|
|
|
seg$no = 0ffh;
|
|
max$attr = 0ffffh;
|
|
do k = 1 to num$seg;
|
|
if mem$tbl(k).attr >= record$size then
|
|
if type = 1 then
|
|
do;
|
|
if (mem$tbl(k).bank = 0) and
|
|
(mem$tbl(k).attr < max$attr) then
|
|
do;
|
|
seg$no = k;
|
|
max$attr = mem$tbl(k).attr;
|
|
end;
|
|
end;
|
|
else
|
|
do;
|
|
if (mem$tbl(k).bank <> 0) and
|
|
(mem$tbl(k).attr < max$attr) then
|
|
do;
|
|
seg$no = k;
|
|
max$attr = mem$tbl(k).attr;
|
|
end;
|
|
end;
|
|
end;
|
|
if (seg$no = 0ffh) and (type = 2) then
|
|
do k = 1 to num$seg;
|
|
if (mem$tbl(k).attr >= record$size) and
|
|
(mem$tbl(k).bank = 0) and
|
|
(mem$tbl(k).attr < max$attr) then
|
|
do;
|
|
seg$no = k;
|
|
max$attr = mem$tbl(k).attr;
|
|
end;
|
|
end;
|
|
return seg$no;
|
|
|
|
end get$seg;
|
|
|
|
plm:
|
|
procedure public;
|
|
|
|
st$ascii$hex:
|
|
procedure(string$adr,val);
|
|
declare string$adr address;
|
|
declare string based string$adr (6) byte;
|
|
declare val address;
|
|
declare i byte;
|
|
string(0) = ' ';
|
|
string(1) = ' ';
|
|
string(2) = hexASCII(shr(high(val),4));
|
|
string(3) = hexASCII(high(val) and 0fh);
|
|
string(4) = hexASCII(shr(low(val),4));
|
|
string(5) = hexASCII(low(val) and 0fh);
|
|
end st$ascii$hex;
|
|
|
|
setup$scb:
|
|
procedure;
|
|
declare scb$adr address;
|
|
declare scb$dat based scb$adr (100) byte;
|
|
|
|
scb$adr = .memory + shl(double(scb$pg-res$pg),8) + 09ch;
|
|
|
|
scb$dat(13h) = bdrive;
|
|
scb$dat(1ah) = con$wid;
|
|
scb$dat(1ch) = con$pag;
|
|
scb$dat(2eh) = bck$spc;
|
|
scb$dat(2fh) = rubout;
|
|
call movef(5,.(012h,07h,0,0,0),.scb$dat(58h)); /* December 15, 1982 */
|
|
if not lerror then
|
|
scb$dat(57h) = scb$dat(57h) and 7fh;
|
|
if not dbl$alv and not bnk$swt then
|
|
scb$dat(57h) = scb$dat(57h) or 0100$0000B;
|
|
else
|
|
scb$dat(57h) = scb$dat(57h) and 1011$1111B;
|
|
scb$dat(5eh) = bnk$top;
|
|
|
|
end setup$scb;
|
|
|
|
get$drvtbl$adr:
|
|
procedure address;
|
|
declare temp$adr address;
|
|
declare temp2 based temp$adr address;
|
|
declare temp3 address;
|
|
|
|
temp$adr = .memory(43h);
|
|
temp3 = temp2 + 1 + .memory;
|
|
temp$adr = temp3;
|
|
if temp2 = 0fffeh
|
|
then res$flg = 2;
|
|
else res$flg = 0;
|
|
if temp2 < 0fffeh
|
|
then return temp2 + .memory;
|
|
else return 0ffffh;
|
|
end get$drvtbl$adr;
|
|
|
|
page$chop:
|
|
procedure;
|
|
declare i byte;
|
|
|
|
drvtbl$adr = get$drvtbl$adr;
|
|
|
|
dont$hash = true;
|
|
if (drvtbl$adr <> 0ffffh) then
|
|
do;
|
|
do i = 0 to 15;
|
|
if drvtbl(i) <> 0 then
|
|
do;
|
|
dph$adr = drvtbl(i) + .memory;
|
|
if dph.hash <> 0ffffh then
|
|
dont$hash = false;
|
|
end;
|
|
end;
|
|
if dont$hash and not bnk$swt then
|
|
res$flg = 2;
|
|
else
|
|
res$flg = 0;
|
|
end;
|
|
|
|
end page$chop;
|
|
|
|
get$xmove:
|
|
procedure boolean;
|
|
declare xmove$adr address;
|
|
declare xmove$val based xmove$adr byte;
|
|
|
|
call movef(2,.memory(58h),.xmove$adr);
|
|
xmove$adr = xmove$adr + .memory;
|
|
if xmove$val = 0c9h /* ret instr. */ then
|
|
return false;
|
|
else
|
|
return true;
|
|
end get$xmove;
|
|
|
|
display$layout:
|
|
procedure(string$adr,base,length);
|
|
declare string$adr address;
|
|
declare base address;
|
|
declare length byte;
|
|
|
|
call print$console$buffer (.(cr,lf,' ','$'));
|
|
call print$console$buffer (string$adr);
|
|
call write$console(' ');
|
|
call dsply$hex$adr (base);
|
|
call write$console(' ');
|
|
call dsply$hex$high$adr (length);
|
|
if prt$msg then
|
|
do;
|
|
call movef(12,string$adr,.system$data(prt$msg$ptr));
|
|
prt$msg$ptr = prt$msg$ptr + 12;
|
|
call st$ascii$hex(.system$data(prt$msg$ptr),base);
|
|
prt$msg$ptr = prt$msg$ptr + 6;
|
|
call st$ascii$hex(.system$data(prt$msg$ptr),
|
|
double(length)*256);
|
|
prt$msg$ptr = prt$msg$ptr + 6;
|
|
call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr));
|
|
prt$msg$ptr = prt$msg$ptr + 3;
|
|
end;
|
|
end display$layout;
|
|
|
|
reloc$module:
|
|
procedure (fcb$adr);
|
|
declare fcb$adr address;
|
|
FCBin = fcb$adr;
|
|
if relfix <> 0 then
|
|
do;
|
|
call error(true,1,.('Disk read error: $'));
|
|
end;
|
|
call close$file(fcb$adr);
|
|
end reloc$module;
|
|
|
|
load:
|
|
procedure (fcb$adr,atts$adr);
|
|
declare fcb$adr address;
|
|
declare atts$adr address;
|
|
declare atts based atts$adr (3) address;
|
|
declare (i,rdcnt) byte;
|
|
|
|
prgsiz = atts(0);
|
|
bufsiz = atts(1);
|
|
codsiz = atts(2);
|
|
call movef(8,fcb$adr+1,.fcb$msg);
|
|
call movef(3,fcb$adr+9,.fcb$msg+9);
|
|
if shr(prgsiz+255,7) > nmb$sect then
|
|
do;
|
|
call error(true,1,.('File cannot fit into GENCPM buffer: ','$'));
|
|
end;
|
|
rdcnt = low(shr(prgsiz-1,7)) + 1;
|
|
i = 0;
|
|
do while (i < rdcnt);
|
|
call set$dma$address(dma:=.sctbfr(i));
|
|
call read$record(fcb$adr);
|
|
i = i + 1;
|
|
end;
|
|
call movef(128,dma,.bitmap); /* copy the last sector read, into */
|
|
/* the bitmap buffer, relocation */
|
|
/* info might be that last sector */
|
|
dma = prgsiz + .memory;
|
|
end load;
|
|
|
|
wrtbuf:
|
|
procedure (wrtlen,wrtoff$adr);
|
|
declare (i,wrtlen,wrtcnt) byte;
|
|
declare wrtoff$adr address;
|
|
declare wrtoff based wrtoff$adr address;
|
|
if wrtlen <> 0 then
|
|
do;
|
|
call movef(8,.FCBout+1,.fcb$msg);
|
|
call movef(3,.FCBout+9,.fcb$msg+9);
|
|
FCBout(33) = low(wrtoff);
|
|
FCBout(34) = high(wrtoff);
|
|
call write$random$record(.FCBout);
|
|
dma = dma + low(256 - low(dma - .memory));
|
|
wrtcnt = wrtlen * 2 - 1;
|
|
do i = 0 to wrtcnt;
|
|
call set$dma$address(dma:=dma-80h);
|
|
call write$record(.FCBout);
|
|
end;
|
|
call set$random$record(.FCBout);
|
|
call movef(2,.FCBout(33),wrtoff$adr);
|
|
end;
|
|
end wrtbuf;
|
|
|
|
get$file$info:
|
|
procedure;
|
|
declare fcb$adr address;
|
|
declare atts$adr address;
|
|
declare file$atts based atts$adr(3) address;
|
|
declare header$record structure (
|
|
fill1 byte,
|
|
psize address,
|
|
fill2 byte,
|
|
dsize address,
|
|
fill3 (4) byte,
|
|
csize address,
|
|
fill4 (116) byte) at (.memory);
|
|
|
|
|
|
get$atts:
|
|
procedure;
|
|
call movef(8,fcb$adr+1,.fcb$msg);
|
|
call movef(3,fcb$adr+9,.fcb$msg+9);
|
|
if open$file(fcb$adr) = 0ffh
|
|
then call error(true,1,.('Unable to open: $'));
|
|
call set$dma$address(.header$record);
|
|
call read$record(fcb$adr);
|
|
file$atts(0) = header$record.psize;
|
|
file$atts(1) = header$record.dsize;
|
|
file$atts(2) = header$record.csize;
|
|
call read$record(fcb$adr);
|
|
end get$atts;
|
|
|
|
if not bnk$swt then
|
|
do;
|
|
call movef(8,.('BDOS3 '),.res$fcb+1);
|
|
call movef(8,.('BIOS3 '),.bios$fcb+1);
|
|
end;
|
|
else
|
|
do;
|
|
fcb$adr = .bnk$fcb;
|
|
atts$adr = .bnk$atts;
|
|
call get$atts;
|
|
end;
|
|
fcb$adr = .bios$fcb;
|
|
atts$adr = .bios$atts;
|
|
call get$atts;
|
|
fcb$adr = .res$fcb;
|
|
atts$adr = .res$atts;
|
|
call get$atts;
|
|
end get$file$info;
|
|
|
|
need$tbl:
|
|
procedure byte;
|
|
declare (all$some,i) byte;
|
|
|
|
all$some = false;
|
|
|
|
if drvtbl$adr = 0ffffh
|
|
then return false;
|
|
else
|
|
do i = 0 to 15;
|
|
if drvtbl(i) <> 0 then
|
|
do;
|
|
dph$adr = drvtbl(i) + .memory;
|
|
/* zero the reserved bytes in the DPH */
|
|
call movef(9,.(0,0,0,0,0,0,0,0,0),dph$adr+2);
|
|
if (dph.dirbcb = 0fffeh) or (dph.dtabcb = 0fffeh) or
|
|
(dph.hash = 0fffeh) or (dph.alv = 0fffeh) or
|
|
(dph.csv = 0fffeh)
|
|
then all$some = true;
|
|
end;
|
|
end;
|
|
return all$some;
|
|
|
|
end need$tbl;
|
|
|
|
setup$hash:
|
|
procedure;
|
|
declare (i,j,printed,seg$no,seg0$no,h$bank,hohash) byte;
|
|
declare (size,h$attr,max$attr,max0$attr) address;
|
|
declare nohash boolean;
|
|
|
|
printed = false;
|
|
nohash = true;
|
|
|
|
do i = 0 to 15;
|
|
dph$adr = drvtbl(i) + .memory;
|
|
if drvtbl(i) <> 0 then
|
|
do;
|
|
if dph.hash < 0fffeh then
|
|
nohash = false;
|
|
if dph.hash = 0fffeh then
|
|
do;
|
|
if not printed then
|
|
do;
|
|
printed = true;
|
|
call print$console$buffer(.
|
|
(lf,cr,'Setting up directory hash tables:',
|
|
lf,cr,'$'));
|
|
end;
|
|
query = quest(27 + i);
|
|
dpb$adr = dph.dpb + .memory;
|
|
size = shl(dpb.drm+1,2);
|
|
call print$console$buffer(.
|
|
(' Enable hashing for drive $'));
|
|
call write$console('A'+i);
|
|
call print$console$buffer(.(': $'));
|
|
call get$response(.hash(i));
|
|
call crlf;
|
|
if not hash(i) then
|
|
do;
|
|
dph.hash = 0ffffh;
|
|
end;
|
|
else
|
|
if not bnk$swt then
|
|
do;
|
|
nohash = false;
|
|
hash$data(i) = size;
|
|
hash$space = hash$space + size;
|
|
end;
|
|
else
|
|
do;
|
|
if (seg$no := get$seg(2,size)) = 0ffh then
|
|
call error(false,0,.(
|
|
'Unable to allocate space for hash table.$'));
|
|
else
|
|
do;
|
|
dph.hbank = mem$tbl(seg$no).bank;
|
|
dph.hash = shl(double(mem$tbl(seg$no).base),8) +
|
|
(shl(double(mem$tbl(seg$no).len),8) -
|
|
mem$tbl(seg$no).attr);
|
|
mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - size;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if (not bnk$swt) and (nohash) then
|
|
do;
|
|
res$flg = 2;
|
|
scb$pg = scb$pg + 2;
|
|
res$pg = res$pg + 2;
|
|
end;
|
|
end setup$hash;
|
|
|
|
get$alloc$chk:
|
|
procedure;
|
|
declare (i,dbl$alloc) byte;
|
|
declare printed boolean;
|
|
|
|
do i = 0 to 15;
|
|
alloc(i) = 0;
|
|
chk(i) = 0;
|
|
end;
|
|
|
|
if not dbl$alv and not bnk$swt then
|
|
dbl$alloc = 1;
|
|
else
|
|
dbl$alloc = 2;
|
|
|
|
alloc$space = 0;
|
|
chk$space = 0;
|
|
printed = false;
|
|
do i = 0 to 15;
|
|
if drvtbl(i) <> 0 then
|
|
do;
|
|
dph$adr = drvtbl(i) + .memory;
|
|
dpb$adr = dph.dpb + .memory;
|
|
if dph.alv = 0fffeh then
|
|
do;
|
|
call print$console$buffer(.(cr,lf,
|
|
'Setting up Allocation vector for drive $'));
|
|
call write$console('A'+i);
|
|
call write$console(':');
|
|
printed = true;
|
|
alloc(i) = (dpb.dsm/8 + 1) * dbl$alloc;
|
|
alloc$space = alloc$space + alloc(i);
|
|
end;
|
|
if dph.csv = 0fffeh then
|
|
do;
|
|
call print$console$buffer(.(cr,lf,
|
|
'Setting up Checksum vector for drive $'));
|
|
call write$console('A'+i);
|
|
call write$console(':');
|
|
printed = true;
|
|
chk(i) = (dpb.drm + 4)/4;
|
|
chk$space = chk$space + chk(i);
|
|
dpb.cks = (dpb.cks and 8000h) or chk(i);
|
|
end;
|
|
end;
|
|
end;
|
|
if printed then
|
|
call crlf;
|
|
end get$alloc$chk;
|
|
|
|
setup$mem$seg$tbl:
|
|
procedure;
|
|
declare (i,j,ok,accept,mlow,mhigh,tlow,thigh) byte;
|
|
declare mem$temp address;
|
|
|
|
/* Create first memory segment table entry */
|
|
mem$tbl(0).base = bnk$pg;
|
|
mem$tbl(0).len = bnk$top - bnk$pg;
|
|
mem$tbl(0).attr = 0;
|
|
mem$tbl(0).bank = 0;
|
|
|
|
accept = false;
|
|
|
|
call print$console$buffer(
|
|
.(lf,cr,
|
|
'*** Bank 1 and Common are not included ***',
|
|
lf,cr,
|
|
'*** in the memory segment table. ***',
|
|
lf,cr,lf,cr,'$'));
|
|
query = quest(10);
|
|
call get$param (.('Number of memory segments $'),
|
|
.num$seg,10);
|
|
call print$console$buffer(.(cr,lf,
|
|
'CP/M 3 Base,size,bank ($'));
|
|
call dsply$hex(mem$tbl(0).base);
|
|
call write$console(',');
|
|
call dsply$hex(mem$tbl(0).len);
|
|
call write$console(',');
|
|
call dsply$hex(mem$tbl(0).bank);
|
|
call print$console$buffer(.(')',lf,cr,'$'));
|
|
|
|
do while not accept;
|
|
/* Bank switched memory segment table input */
|
|
call print$console$buffer (.(cr,lf,
|
|
'Enter memory segment table:',lf,cr,'$'));
|
|
do j = 1 to num$seg;
|
|
ok = false;
|
|
do while not ok;
|
|
query = quest(11 + j - 1);
|
|
call get$param (.(' Base,size,bank ','$'),
|
|
.mem$tbl(j),16);
|
|
mem$tbl(j).attr = shl(double(mem$tbl(j).len),8);
|
|
if mem$tbl(j).len = 0 then
|
|
do;
|
|
call error(false,0,.(
|
|
'Zero length segment not allowed.$'));
|
|
end;
|
|
else
|
|
if mem$tbl(j).bank = 1 then
|
|
do;
|
|
call error(false,0,.(
|
|
'Bank one not allowed.$'));
|
|
end;
|
|
else
|
|
do;
|
|
tlow = mem$tbl(j).base;
|
|
mem$temp = double(tlow) + double(mem$tbl(j).len);
|
|
if (high(mem$temp) <> 0) or (low(mem$temp) > bnk$top) then
|
|
do;
|
|
call print$console$buffer(.(cr,lf,'ERROR: ',
|
|
'Memory conflict - segment trimmed.',
|
|
cr,lf,'$'));
|
|
mem$tbl(j).len = bnk$top - tlow;
|
|
mem$tbl(j).attr = shl(double(bnk$top - tlow),8);
|
|
end;
|
|
else
|
|
do;
|
|
thigh = low(mem$temp);
|
|
i = 0;
|
|
ok = true;
|
|
do while ((i < j) and ok);
|
|
mlow = mem$tbl(i).base;
|
|
mhigh = mlow + mem$tbl(i).len;
|
|
if mem$tbl(i).bank = mem$tbl(j).bank then
|
|
do;
|
|
if (mhigh >= thigh) and (tlow >= mlow) then
|
|
do;
|
|
call error(false,0,.(
|
|
'Memory conflict - cannot trim segment.$'));
|
|
ok = false;
|
|
end;
|
|
else
|
|
if ((thigh > mhigh) and (mhigh > tlow)) then
|
|
do;
|
|
call print$console$buffer(.(cr,lf,'ERROR: ',
|
|
'Memory conflict - segment trimmed.',
|
|
cr,lf,'$'));
|
|
mem$tbl(j).base = mhigh;
|
|
ok = false;
|
|
end;
|
|
else
|
|
if ((thigh > mlow) and (mlow > tlow)) then
|
|
do;
|
|
call print$console$buffer(.(cr,lf,'ERROR: ',
|
|
'Memory conflict - segment trimmed.',
|
|
cr,lf,'$'));
|
|
mem$tbl(j).len = mlow - tlow;
|
|
mem$tbl(j).attr = shl(double(mlow-tlow),8);
|
|
ok = false;
|
|
end;
|
|
end;
|
|
i = i + 1;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
call crlf;
|
|
do j = 0 to num$seg;
|
|
if j = 0 then
|
|
call print$console$buffer (.(' CP/M 3 Sys ','$'));
|
|
else
|
|
do;
|
|
call print$console$buffer (.(' Memseg No. ','$'));
|
|
call dsply$hex(j-1);
|
|
end;
|
|
call dsply$hex$high$adr (mem$tbl(j).base);
|
|
call dsply$hex$high$adr (mem$tbl(j).len);
|
|
if bnk$swt then
|
|
do;
|
|
call print$console$buffer (.(' Bank ','$'));
|
|
call dsply$hex (mem$tbl(j).bank);
|
|
end;
|
|
call crlf;
|
|
end;
|
|
query = false;
|
|
accept = true;
|
|
call print$console$buffer (.(cr,lf,
|
|
'Accept new memory segment table entries ','$'));
|
|
call get$response (.accept);
|
|
end; /* do while not accept */
|
|
call crlf;
|
|
end setup$mem$seg$tbl;
|
|
|
|
get$default$file:
|
|
procedure;
|
|
declare ret byte;
|
|
|
|
call print$console$buffer(.(
|
|
'Default entries are shown in (parens).',cr,lf,
|
|
'Default base is Hex, precede entry with # for decimal',
|
|
cr,lf,'$'));
|
|
if (ret:=open$file(.data$fcb)) <> 255 then
|
|
do;
|
|
call movef(8,.data$fcb+1,.fcb$msg);
|
|
call movef(3,.data$fcb+9,.fcb$msg+9);
|
|
call print$console$buffer(.(
|
|
cr,lf,'Use GENCPM.DAT for defaults $'));
|
|
ret = 0ffh;
|
|
call get$response(.ret);
|
|
call crlf;
|
|
if ret then
|
|
call getdef;
|
|
call close$file(.data$fcb);
|
|
end;
|
|
else
|
|
do;
|
|
display = true;
|
|
automatic = false;
|
|
end;
|
|
|
|
end get$default$file;
|
|
|
|
setup$system$dat:
|
|
procedure;
|
|
declare (i,j,ok,temp) byte;
|
|
ok = false;
|
|
call get$default$file;
|
|
do while not ok;
|
|
query = quest(155);
|
|
call crlf;
|
|
call print$console$buffer(.('Create a new GENCPM.DAT file $'));
|
|
call get$response(.crdatf);
|
|
query = quest(0);
|
|
call crlf;
|
|
call crlf;
|
|
call print$console$buffer(.('Display Load Map at Cold Boot $'));
|
|
call get$response(.prt$msg);
|
|
call crlf;
|
|
call crlf;
|
|
query = quest(1);
|
|
con$wid = con$wid + 1;
|
|
call get$param (.('Number of console columns $'),
|
|
.con$wid,10);
|
|
con$wid = con$wid - 1;
|
|
query = quest(2);
|
|
con$pag = con$pag + 1;
|
|
call get$param (.('Number of lines in console page $'),
|
|
.con$pag,10);
|
|
con$pag = con$pag - 1;
|
|
query = quest(3);
|
|
call print$console$buffer(.
|
|
('Backspace echoes erased character $'));
|
|
call get$response (.bck$spc);
|
|
call crlf;
|
|
query = quest(4);
|
|
call print$console$buffer(.
|
|
('Rubout echoes erased character $'));
|
|
call get$response (.rubout);
|
|
call crlf;
|
|
call crlf;
|
|
query = quest(5);
|
|
err1:
|
|
call print$console$buffer(.('Initial default drive ($'));
|
|
call write$console('A'+bdrive);
|
|
call print$console$buffer(.(':) ? $'));
|
|
call read$console$buffer(.lnbfr);
|
|
if lnbfr(1) <> 0 then
|
|
do;
|
|
temp = upper(lnbfr(2))-'A';
|
|
if not valid$drive(temp) then
|
|
goto err1;
|
|
bdrive = temp;
|
|
end;
|
|
call crlf;
|
|
call crlf;
|
|
query = quest(6);
|
|
call get$param (.('Top page of memory $'),
|
|
.mem$top,16);
|
|
os$top = shl(double(mem$top),8) + 100h;
|
|
query = quest(7);
|
|
call print$console$buffer(.('Bank switched memory $'));
|
|
call get$response (.bnk$swt);
|
|
call crlf;
|
|
non$bnk = not bnk$swt;
|
|
if bnk$swt then
|
|
do;
|
|
query = quest(8);
|
|
call get$param (.('Common memory base page $'),
|
|
.bnk$top,16);
|
|
call crlf;
|
|
query = quest(9);
|
|
call print$console$buffer(.('Long error messages $'));
|
|
call get$response(.lerror);
|
|
call crlf;
|
|
end;
|
|
else
|
|
do;
|
|
query = quest(156);
|
|
call crlf;
|
|
call print$console$buffer(.('Double allocation vectors $'));
|
|
call get$response(.dbl$alv);
|
|
call crlf;
|
|
bnk$top = 0;
|
|
end;
|
|
query = false;
|
|
ok = true;
|
|
call crlf;
|
|
call print$console$buffer(.('Accept new system definition $'));
|
|
call get$response(.ok);
|
|
call crlf;
|
|
end;
|
|
save$mem$top = mem$top;
|
|
mem$top = mem$top + 1;
|
|
rubout = not rubout;
|
|
end setup$system$dat;
|
|
|
|
setup$CPM80$sys:
|
|
procedure;
|
|
declare i byte;
|
|
call print$console$buffer (.( cr,lf,lf,
|
|
'CP/M 3.0 System Generation',cr,lf,
|
|
'Copyright (C) 1982, Digital Research',
|
|
cr,lf,cr,lf,'$'));
|
|
call delete$file (.fcbout);
|
|
call create$file (.fcbout);
|
|
FCBout(32) = 0;
|
|
do i = 0 to 127;
|
|
system$data(i) = 0;
|
|
end;
|
|
do i = 128 to 255;
|
|
system$data(i) = '$';
|
|
end;
|
|
prt$msg$ptr = 128;
|
|
call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr));
|
|
prt$msg$ptr = 131;
|
|
call movef(8,.FCBout+1,.fcb$msg);
|
|
call movef(3,.FCBout+9,.fcb$msg+9);
|
|
call set$DMA$address (.sctbfr);
|
|
call write$record (.FCBout);
|
|
call write$record (.FCBout);
|
|
end setup$CPM80$sys;
|
|
|
|
initialization:
|
|
procedure;
|
|
declare i byte;
|
|
|
|
nmb$sect = shr ((maxb-.sctbfr+1),7);
|
|
|
|
do i = 0 to 15;
|
|
hash$data(i) = 0;
|
|
end;
|
|
hash$space = 0;
|
|
|
|
if fcb(1) = 'A' then
|
|
do;
|
|
automatic = true;
|
|
display = false;
|
|
do i = 0 to 154;
|
|
quest(i) = false;
|
|
end;
|
|
end;
|
|
else
|
|
do;
|
|
automatic = false;
|
|
display = true;
|
|
end;
|
|
if fcb16(1) = 'D' then
|
|
do;
|
|
display = true;
|
|
end;
|
|
query = false;
|
|
|
|
end initialization;
|
|
|
|
|
|
/*
|
|
G E N C P M M a i n P r o g r a m
|
|
*/
|
|
|
|
res$flg = 0;
|
|
display = true;
|
|
call setup$CPM80$sys;
|
|
call initialization;
|
|
call setup$system$dat;
|
|
|
|
call get$file$info;
|
|
|
|
if bios$atts(2) <> 0
|
|
then res$bios$len = high(bios$atts(2) + 255);
|
|
else res$bios$len = high(bios$atts(0) + 255);
|
|
bios$pg = mem$top - res$bios$len;
|
|
bnk$off = bnk$top - (high(bios$atts(0) + 255) - res$bios$len);
|
|
bnk$pg = bnk$off - high(bnk$atts(0) + 255);
|
|
|
|
call load(.bios$fcb,.bios$atts);
|
|
|
|
call page$chop;
|
|
|
|
|
|
if not bnk$swt then
|
|
do;
|
|
scb$pg = bios$pg - (3 - res$flg);
|
|
res$pg = bios$pg - high(res$atts(0) + 255) + res$flg;
|
|
end;
|
|
else
|
|
do;
|
|
scb$pg = bios$pg - 1;
|
|
res$pg = bios$pg - high(res$atts(0) + 255);
|
|
end;
|
|
|
|
if need$tbl then
|
|
do;
|
|
call get$alloc$chk;
|
|
if bnk$swt then
|
|
do;
|
|
bnk$off = bnk$top - (high(bios$atts(0) + alloc$space +
|
|
chk$space + 255) - res$bios$len);
|
|
bnk$pg = bnk$off - high(bnk$atts(0) + 255);
|
|
xmove$implemented = get$xmove;
|
|
call setup$mem$seg$tbl;
|
|
if (not xmove$implemented) then
|
|
do len = 0 to 15;
|
|
record(len).altbnks = false;
|
|
end;
|
|
end;
|
|
else
|
|
xmove$implemented = false;
|
|
if not dont$hash then
|
|
call setup$hash;
|
|
call setbuf;
|
|
end;
|
|
|
|
res$len = res$bios$len;
|
|
|
|
offset = bios$pg;
|
|
call reloc$module(.bios$fcb);
|
|
|
|
if bnk$swt
|
|
then call display$layout(.('BNKBIOS3 SPR$'),
|
|
double(bios$pg)*256,res$bios$len);
|
|
else call display$layout(.('BIOS3 SPR$'),
|
|
double(bios$pg)*256,res$bios$len);
|
|
if not bnk$swt then
|
|
do;
|
|
len = res$bios$len;
|
|
off = 2;
|
|
call wrtbuf(len,.off);
|
|
common$len = len;
|
|
banked$len = 0;
|
|
end;
|
|
else
|
|
do;
|
|
len = high(bios$atts(0) + 255) - res$bios$len;
|
|
off = (high(res$atts(0) + 255) + res$bios$len) * 2 + 2;
|
|
call display$layout(.('BNKBIOS3 SPR$'),double(bnk$off)*256,len);
|
|
call wrtbuf(len,.off);
|
|
banked$len = len;
|
|
len = res$bios$len;
|
|
off = 2;
|
|
dma = dma - 80h;
|
|
call wrtbuf(len,.off);
|
|
common$len = len;
|
|
end;
|
|
|
|
res$len = high(res$atts(0) + 255) - res$flg;
|
|
offset = res$pg;
|
|
call load(.res$fcb,.res$atts);
|
|
call reloc$module(.res$fcb);
|
|
call setup$scb;
|
|
dma = dma - (res$flg * 256);
|
|
len = high(res$atts(0) + 255) - res$flg;
|
|
if not bnk$swt
|
|
then call display$layout(.('BDOS3 SPR$'),double(res$pg)*256,len);
|
|
else call display$layout(.('RESBDOS3 SPR$'),double(res$pg)*256,len);
|
|
call wrtbuf(len,.off);
|
|
common$len = common$len + len;
|
|
|
|
if bnk$swt then
|
|
do;
|
|
res$len = 0ffh;
|
|
offset = bnk$pg;
|
|
call load(.bnk$fcb,.bnk$atts);
|
|
call reloc$module(.bnk$fcb);
|
|
len = high(bnk$atts(0) + 255);
|
|
off = off + (high(bios$atts(0) + 255) - res$bios$len) * 2;
|
|
call display$layout(.('BNKBDOS3 SPR$'),double(bnk$pg)*256,len);
|
|
call wrtbuf(len,.off);
|
|
banked$len = banked$len + len;
|
|
end;
|
|
if not prt$msg then prt$msg$ptr = prt$msg$ptr - 3;
|
|
call movef(12,.(lf,cr,' 64K TPA',lf,cr),.system$data(prt$msg$ptr));
|
|
res$pg = shr(res$pg,2);
|
|
system$data(prt$msg$ptr+3) = res$pg/10 + '0';
|
|
system$data(prt$msg$ptr+4) = res$pg mod 10 + '0';
|
|
prt$msg$ptr = prt$msg$ptr + 12;
|
|
sys$entry = bios$pg * 256;
|
|
call movef(36,.('Copyright (C) 1982, Digital Research'),.system$data(10h));
|
|
call movef(6,.memory,.system$data(35h)); /* Copy Serial No. into header */
|
|
FCBout(33) = 0; FCBout(34) = 0; FCBout(35) = 0;
|
|
system$data(0) = mem$top;
|
|
system$data(2) = bnk$top;
|
|
call movef(8,.FCBout+1,.fcb$msg);
|
|
call movef(3,.FCBout+9,.fcb$msg+9);
|
|
call set$DMA$address(.system$data);
|
|
call write$random$record(.FCBout);
|
|
FCBout(33) = 1;
|
|
call set$DMA$address(.system$data(128));
|
|
call write$random$record(.FCBout);
|
|
call close$file(.fcbout);
|
|
|
|
if crdatf then
|
|
do; /* create a new data file for GENCPM */
|
|
crdatf = false;
|
|
mem$top = save$mem$top;
|
|
rubout = not rubout;
|
|
call movef(8,.data$fcb+1,.fcb$msg);
|
|
call movef(3,.data$fcb+9,.fcb$msg+9);
|
|
call crtdef;
|
|
end;
|
|
|
|
display = true;
|
|
call print$console$buffer (.(cr,lf,lf,
|
|
'*** CP/M 3.0 SYSTEM GENERATION DONE ***','$'));
|
|
return;
|
|
|
|
end plm;
|
|
end gencpm;
|