mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 16:34:07 +00:00
664 lines
18 KiB
Plaintext
664 lines
18 KiB
Plaintext
$ TITLE('CP/M 3.0 --- SUBMIT')
|
|
sub:
|
|
do;
|
|
$include (copyrt.lit)
|
|
/*
|
|
Revised:
|
|
26 July 79 for CP/M 2.0
|
|
01 July 82 for CP/M 3.0 by John Knight
|
|
23 Aug 82 for CP/M 3.0 by Doug Huskey
|
|
11 Sept 82 for CP/M 3.0 by Doug Huskey
|
|
1 Nov 82 for CP/M 3.0 by Doug Huskey
|
|
|
|
*/
|
|
|
|
/*
|
|
generation procedure
|
|
|
|
seteof submit.plm
|
|
seteof copyrt.lit
|
|
is14
|
|
asm80 mcd80a.asm debug
|
|
asm80 getf.asm debug
|
|
asm80 parse.asm debug
|
|
plm80 submit.plm pagewidth(100) debug optimize
|
|
link mcd80a.obj,submit.obj,parse.obj,getf.obj,plm80.lib to submit.mod
|
|
locate submit.mod code(0100H) stacksize(100)
|
|
era submit.mod
|
|
cpm
|
|
objcpm submit
|
|
rmac getrsx
|
|
xref getrsx
|
|
link getrsx[op]
|
|
era get.rsx
|
|
ren get.rsx=getrsx.prl
|
|
gencom submit.com get.rsx
|
|
|
|
*/
|
|
|
|
declare plm label public;
|
|
|
|
|
|
/*********************************
|
|
* *
|
|
* B D O S I N T E R F A C E *
|
|
* *
|
|
*********************************/
|
|
|
|
declare
|
|
sfcb(33) byte external, /* default fcb */
|
|
buff(128) byte external; /* default buffer */
|
|
|
|
declare cmdrv byte external; /* command drive */
|
|
declare fcb (1) byte external; /* 1st default fcb */
|
|
declare fcb16 (1) byte external; /* 2nd default fcb */
|
|
declare pass0 address external; /* 1st password ptr */
|
|
declare len0 byte external; /* 1st passwd length */
|
|
declare pass1 address external; /* 2nd password ptr */
|
|
declare len1 byte external; /* 2nd passwd length */
|
|
declare tbuff (1) byte external; /* default dma buffer */
|
|
|
|
mon1: procedure(f,a) external;
|
|
declare f byte, a address;
|
|
/* bdos interface, no returned value */
|
|
end mon1;
|
|
|
|
mon2a: procedure(f,a) external;
|
|
declare f byte, a byte;
|
|
/* bdos interface, no returned value */
|
|
end mon2a;
|
|
|
|
mon2: procedure(f,a) byte external;
|
|
declare f byte, a address;
|
|
/* bdos interface, return byte value */
|
|
end mon2;
|
|
|
|
mon3: procedure(func,info) address external;
|
|
declare func byte;
|
|
declare info address;
|
|
end mon3;
|
|
|
|
parse:
|
|
procedure (pfcb) address external;
|
|
declare pfcb address;
|
|
end parse;
|
|
|
|
getf:
|
|
procedure (input$type) external; /* does submit file processing */
|
|
declare input$type address;
|
|
end getf;
|
|
|
|
/************************************
|
|
* *
|
|
* L I T E R A L S *
|
|
* *
|
|
************************************/
|
|
|
|
declare lit literally 'literally',
|
|
dcl lit 'declare',
|
|
proc lit 'procedure',
|
|
addr lit 'address',
|
|
ctll lit '0ch',
|
|
lca lit '110$0001b', /* lower case a */
|
|
lcz lit '111$1010b', /* lower case z */
|
|
endfile lit '1ah', /* cp/m end of file */
|
|
sysin$endfile lit '0ffh',
|
|
true literally '1',
|
|
false literally '0',
|
|
forever literally 'while true',
|
|
cr literally '13',
|
|
lf literally '10',
|
|
what literally '63',
|
|
temp$file$drive$offset literally '50h',
|
|
con$type literally '0',
|
|
cpmversion literally '30h',
|
|
ctrli literally '09h';
|
|
|
|
/****************************************
|
|
* *
|
|
* G L O B A L V A R I A B L E S *
|
|
* *
|
|
****************************************/
|
|
|
|
declare
|
|
ln(9) byte initial('00001 : $'),
|
|
ln1 byte at(.ln(0)),
|
|
ln2 byte at(.ln(1)),
|
|
ln3 byte at(.ln(2)),
|
|
ln4 byte at(.ln(3)),
|
|
ln5 byte at(.ln(4)),
|
|
dfcb(36) byte initial(0,'SYSIN $$$',0,0,0),
|
|
drec byte at(.dfcb(32)), /* current record */
|
|
drrec address at(.dfcb(33)), /* random record */
|
|
drr2 byte at(.dfcb(35)), /* random record byte 3 */
|
|
dcnt byte,
|
|
get$init$pb byte initial(128), /* getrsx sub-functions */
|
|
get$kill$pb byte initial(129),
|
|
get$fcb$pb byte initial(130),
|
|
sstring(128) byte, /* substitute string */
|
|
sbp byte, /* source buffer pointer */
|
|
ssbp byte, /* sub string buffer pointer */
|
|
ver address,
|
|
a address, /* calling program's stack pointer */
|
|
prog$flag based a address;
|
|
|
|
declare scbpd structure
|
|
(offset byte,
|
|
set byte,
|
|
value address);
|
|
|
|
declare parse$fn structure
|
|
(buff$adr address,
|
|
fcb$adr address);
|
|
|
|
declare subpb structure
|
|
(io$type byte,
|
|
echo$flag byte,
|
|
filtered$flag byte,
|
|
program$flag byte)
|
|
initial (con$type,true,true,false);
|
|
|
|
|
|
declare
|
|
ctrlc literally '3',
|
|
ctrlx literally '18h',
|
|
bksp literally '8',
|
|
submit$file$drv literally '15';
|
|
|
|
|
|
/****************************************
|
|
* *
|
|
* B D O S F U N C T I O N C A L L S *
|
|
* *
|
|
****************************************/
|
|
|
|
|
|
|
|
printchar:
|
|
procedure(char);
|
|
declare char byte;
|
|
call mon1(2,char);
|
|
end printchar;
|
|
|
|
conin:
|
|
procedure byte;
|
|
return mon2(6,0fdh);
|
|
end conin;
|
|
|
|
print: procedure(a);
|
|
declare a address;
|
|
/* print the string starting at address a until the
|
|
next dollar sign is encountered */
|
|
call mon1(9,a);
|
|
end print;
|
|
|
|
read$console$buf: procedure (buffer$address,max) byte;
|
|
declare buffer$address address;
|
|
declare new$max based buffer$address address;
|
|
declare max byte;
|
|
new$max = max;
|
|
call mon1(10,buffer$address);
|
|
buffer$address = buffer$address + 1;
|
|
return new$max; /* actually number of characters input */
|
|
end read$console$buf;
|
|
|
|
version: procedure address;
|
|
/* returns current cp/m version */
|
|
return mon3(12,0);
|
|
end version;
|
|
|
|
open: procedure(fcb) address;
|
|
declare fcb address;
|
|
return (mon3(15,fcb));
|
|
end open;
|
|
|
|
close: procedure(fcb);
|
|
declare fcb address;
|
|
dcnt = mon2(16,fcb);
|
|
end close;
|
|
|
|
delete: procedure(fcb);
|
|
declare fcb address;
|
|
call mon1(19,fcb);
|
|
end delete;
|
|
|
|
diskread: procedure(fcb) byte;
|
|
declare fcb address;
|
|
return mon2(20,fcb);
|
|
end diskread;
|
|
|
|
diskwrite: procedure(fcb) byte;
|
|
declare fcb address;
|
|
return mon2(21,fcb);
|
|
end diskwrite;
|
|
|
|
|
|
ranread: procedure(fcb) byte;
|
|
declare fcb address;
|
|
return mon2(33,fcb);
|
|
end ranread;
|
|
|
|
make: procedure(fcb);
|
|
declare fcb address;
|
|
dcnt = mon2(22,fcb);
|
|
end make;
|
|
|
|
setdma: procedure(dma);
|
|
declare dma address;
|
|
call mon1(26,dma);
|
|
end setdma;
|
|
|
|
errormode: procedure(mode);
|
|
declare mode byte;
|
|
call mon2a(45,mode);
|
|
end errormode;
|
|
|
|
getscbbyte: procedure (offset) byte;
|
|
declare offset byte;
|
|
scbpd.offset = offset;
|
|
scbpd.set = 0;
|
|
return mon2(49,.scbpd);
|
|
end getscbbyte;
|
|
|
|
setscbbyte:
|
|
procedure (offset,value);
|
|
declare offset byte;
|
|
declare value byte;
|
|
scbpd.offset = offset;
|
|
scbpd.set = 0ffh;
|
|
scbpd.value = double(value);
|
|
call mon1(49,.scbpd);
|
|
end setscbbyte;
|
|
|
|
rsx$call: procedure (rsxpb) address;
|
|
/* call Resident System Extension */
|
|
declare rsxpb address;
|
|
return mon3(60,rsxpb);
|
|
end rsx$call;
|
|
|
|
/*************************************************
|
|
* *
|
|
* M A I N S U B R O U T I N E S *
|
|
* *
|
|
*************************************************/
|
|
|
|
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;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
crlf: proc;
|
|
call printchar(cr);
|
|
call printchar(lf);
|
|
end crlf;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
bad$file: proc;
|
|
call print(.('Invalid file name $'));
|
|
call mon1(0,0);
|
|
end bad$file;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
/* fill string @ s for c bytes with f */
|
|
fill: procedure(s,f,c);
|
|
declare s address;
|
|
declare (f,c) byte;
|
|
declare a based s byte;
|
|
do while (c:=c-1) <> 255;
|
|
a=f;
|
|
s=s+1;
|
|
end;
|
|
end fill;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
error: procedure(a);
|
|
declare a address;
|
|
call crlf;
|
|
call print(.('Error On Line $'));
|
|
call print(.ln1);
|
|
call print(a);
|
|
call move(.dfcb(0),.sfcb(0),33);
|
|
call delete(.sfcb(0)); /* cleanup before exit */
|
|
call mon1(0,0);
|
|
/* return to ccp */
|
|
end error;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
ucase: procedure (char) byte;
|
|
declare char byte;
|
|
if char >= 'a' then
|
|
if char < '{' then
|
|
return (char-20h);
|
|
return char;
|
|
end ucase;
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
getucase: procedure byte;
|
|
declare c byte;
|
|
c = ucase(conin);
|
|
return c;
|
|
end getucase;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
getpasswd: procedure;
|
|
declare (i,c) byte;
|
|
call crlf;
|
|
call crlf;
|
|
call print(.('Enter Password: $'));
|
|
retry:
|
|
call fill(.fcb16,' ',8);
|
|
do i=0 to 7;
|
|
nxtchr:
|
|
if (c:=getucase) >= ' ' then
|
|
fcb16(i)=c;
|
|
if c = cr then
|
|
return;
|
|
if c = ctrlx then
|
|
go to retry;
|
|
if c = bksp then do;
|
|
if i < 1 then
|
|
goto retry;
|
|
else do;
|
|
fcb16(i := i - 1) = ' ';
|
|
goto nxtchr;
|
|
end;
|
|
end;
|
|
if c = 3 then
|
|
call mon1(0,0);
|
|
end;
|
|
end getpasswd;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
deblankparm: procedure;
|
|
/* clear to next non-blank substitute string */
|
|
do while (sstring(ssbp) = ' ' or sstring(ssbp) = ctrli);
|
|
ssbp = ssbp + 1;
|
|
end;
|
|
end deblankparm;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
try$open: procedure;
|
|
declare error$code address;
|
|
call fill(.fcb16,' ',8); /* blank storage for password */
|
|
if len0 <> 0 then
|
|
call move(pass0,.fcb16,len0);
|
|
call error$mode(0feh);
|
|
call setdma(.fcb16); /* set dma to password */
|
|
error$code = open(.sfcb);
|
|
if low(error$code) = 0ffh then
|
|
if high(error$code) = 7 then do;
|
|
call getpasswd;
|
|
call crlf;
|
|
call setdma(.fcb16);
|
|
call error$mode(0);
|
|
error$code=open(.sfcb);
|
|
end;
|
|
else do;
|
|
if high(error$code) = 0 then
|
|
call print(.('ERROR: No ''SUB'' File Found$'));
|
|
call mon1(0,0);
|
|
end;
|
|
call setdma(.buff(0));
|
|
call error$mode(0);
|
|
end try$open;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
setup: procedure;
|
|
declare no$chars byte;
|
|
declare pstatus address;
|
|
declare b byte;
|
|
/* move buffer to substitute string */
|
|
call move(.buff(1),.sstring(0),127);
|
|
sstring(buff(0))=0; /* mark end of string */
|
|
/* check to see if there are parameters */
|
|
ssbp = 0;
|
|
call deblankparm; /* skip over leading spaces */
|
|
if sstring(ssbp) = 0 then do; /* no sub file, prompt for it */
|
|
call print(.('CP/M 3 SUBMIT Version 3.0',cr,lf,'$'));
|
|
call print(.('Enter File to SUBMIT: $'));
|
|
no$chars = read$console$buf(.buff(0),40);
|
|
buff(no$chars+2)=0; /* mark end of input */
|
|
call crlf;
|
|
parse$fn.buff$adr = .buff(2);
|
|
parse$fn.fcb$adr = .sfcb(0);
|
|
pstatus = parse(.parse$fn);
|
|
if pstatus = 0FFFFh then
|
|
call bad$file;
|
|
call move(.buff(2),.sstring(0),127);
|
|
end;
|
|
call move(.('SUB'),.sfcb(9),3); /* set file type to SUB */
|
|
if sfcb(0) = 0 then
|
|
if (b:=getscbbyte(submit$file$drv)) > 0 then do;
|
|
sfcb(0)=b; /* set file drive to that saved by CCP */
|
|
call setscbbyte(submit$file$drv,0);
|
|
end;
|
|
call try$open;
|
|
do while (sstring(ssbp) <> ' ' and sstring(ssbp) <> 0
|
|
and sstring(ssbp) <> ctrli);
|
|
ssbp = ssbp + 1; /* skip over file name */
|
|
end;
|
|
call deblankparm; /* skip over any spaces */
|
|
b = sstring(ssbp);
|
|
/* File is open if this point reached */
|
|
sbp = 128; /* causes read below */
|
|
|
|
end setup;
|
|
|
|
getsource: procedure byte;
|
|
/* read the next source character */
|
|
declare b byte;
|
|
if sbp > 127 then
|
|
do; if diskread(.sfcb(0)) <> 0 then
|
|
return endfile;
|
|
sbp = 0;
|
|
end;
|
|
if (b := buff((sbp:=sbp+1)-1)) = cr then do;
|
|
/* increment line */
|
|
if (ln5:=ln5+1) > '9' then do;
|
|
ln5 = '0';
|
|
if (ln4:=ln4+1) > '9' then do;
|
|
ln4 = '0';
|
|
if (ln3:=ln3+1) > '9' then do;
|
|
ln3 = '0';
|
|
if (ln2:=ln2+1) > '9' then do;
|
|
ln2 = '0';
|
|
ln1 = ln1 + 1;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
return b;
|
|
end getsource;
|
|
|
|
writebuff: procedure;
|
|
/* write the contents of the buffer to disk */
|
|
if diskwrite(.dfcb) <> 0 then /* error */
|
|
call error(.('Disk Write Error$'));
|
|
end writebuff;
|
|
|
|
declare rbuff(2048) byte, /* jcl buffer */
|
|
rbp address, /* jcl buffer pointer */
|
|
rlen byte; /* length of current command */
|
|
|
|
fillrbuff: procedure;
|
|
declare s 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;
|
|
|
|
write$rbuff: procedure;
|
|
declare j byte;
|
|
declare i address;
|
|
rbp=0; i=0;
|
|
do while (i < 2048);
|
|
do j=0 to 127;
|
|
if rbuff(i+j)=sysin$endfile
|
|
then goto close$file;
|
|
end;
|
|
call setdma(.rbuff(i));
|
|
call writebuff;
|
|
i=i+128;
|
|
end;
|
|
call setdma(.buff(0));
|
|
return;
|
|
|
|
close$file:
|
|
call setdma(.rbuff(i));
|
|
call writebuff;
|
|
call setdma(.buff(0));
|
|
drrec, drr2 = 0; /* set to 1st record in file */
|
|
dcnt = ranread(.dfcb); /* read to position at start */
|
|
if dcnt <> 0 then
|
|
call error(.('Random Read $'));
|
|
goto exit$from$process;
|
|
end write$rbuff;
|
|
|
|
putrbuff: procedure(b);
|
|
declare b byte;
|
|
if (rbp > last(rbuff)) then do;
|
|
call print(.('.$'));
|
|
call write$rbuff;
|
|
end;
|
|
rbuff(rbp) = b;
|
|
if b = sysin$endfile then
|
|
call write$rbuff;
|
|
rbp = rbp + 1;
|
|
end putrbuff;
|
|
|
|
declare (reading,b,newline,progline) byte;
|
|
/* fill the jcl buffer */
|
|
rbp = 0;
|
|
reading = true;
|
|
do while reading;
|
|
rlen = 0; /* reset command length */
|
|
newline,progline = true;
|
|
do while (b:=getsource) <> endfile and b <> cr;
|
|
if b <> lf then
|
|
do; if b = sysin$endfile then
|
|
call error(.('Invalid ASCII Character$'));
|
|
if newline then do; /* program input begins with < */
|
|
newline = false;
|
|
if b <> '<' then
|
|
progline = false;
|
|
end;
|
|
if b = '$' then /* copy substitute string */
|
|
do; if (b:=getsource) = '$' then
|
|
/* $$ replaced by $ */
|
|
call putrbuff(b); else
|
|
if (b := b - '0') > 9 then
|
|
call error(.('Parameter Error$')); else
|
|
do; /* find string 'b' in sstring */
|
|
ssbp = 0; call deblankparm; /* ready to scan string */
|
|
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; else /* not a '$' */
|
|
if b = '^' then do; /* possible control character */
|
|
b=getsource;
|
|
if b = '^' then
|
|
call putrbuff('^'); /* '^^' ==> '^' */
|
|
else do;
|
|
if b < '@' then /* number symbols */
|
|
call putrbuff(b-' ');
|
|
else
|
|
if b < '`' then /* upper case */
|
|
call putrbuff(b-'@');
|
|
else
|
|
call putrbuff(b-'`'); /* lower case */
|
|
end;
|
|
end;
|
|
/* check for multiple commands <com>!<com>!<com> */
|
|
else if b = '!' and not progline then do;
|
|
call putrbuff(cr); /* mark eoln with cr, lf */
|
|
call putrbuff(lf);
|
|
end;
|
|
else /* not $ or ^ */
|
|
call putrbuff(b);
|
|
end;
|
|
end; /* of line or input file - compute length */
|
|
reading = b = cr;
|
|
call putrbuff(cr); /* mark eoln with cr, lf */
|
|
call putrbuff(lf);
|
|
end;
|
|
/* entire file has been read and processed */
|
|
rbp = rbp - 2; /* back up; too many cr,lf's on last line */
|
|
call putrbuff(sysin$endfile); /* mark end of file */
|
|
end fillrbuff;
|
|
|
|
makefile: procedure;
|
|
declare i byte;
|
|
declare rsxadr addr;
|
|
declare rsxbase based rsxadr addr;
|
|
|
|
rsxadr = rsx$call(.get$init$pb);
|
|
i = high(rsxbase); /* rsxbase = addr of kill flag */
|
|
i = shr(i,2);
|
|
dfcb(6) = i/10 + '0';
|
|
dfcb(7) = i mod 10 + '0';
|
|
call errormode(0ffh); /* set to return errors */
|
|
drec = 0; /* zero the next record to write */
|
|
call make(.dfcb);
|
|
if dcnt = 255 then do;
|
|
call delete(.dfcb); /* file might exist */
|
|
call errormode(0);
|
|
call make(.dfcb); /* try make again */
|
|
if dcnt = 255 then do;
|
|
call print(.('ERROR: Directory Full$'));
|
|
call mon1(0,0);
|
|
end;
|
|
end;
|
|
call errormode(0);
|
|
end makefile;
|
|
|
|
/*************************************************
|
|
* *
|
|
* M A I N P R O G R A M *
|
|
* *
|
|
*************************************************/
|
|
|
|
plm:
|
|
ver = version;
|
|
if (low(ver) < cpmversion) or (high(ver) = 1) then do;
|
|
call print(.('Requires CP/M 3.0 $'));
|
|
call mon1(0,0);
|
|
end;
|
|
dfcb(0)=getscbbyte(temp$file$drive$offset);
|
|
call setup;
|
|
call makefile;
|
|
call fillrbuff;
|
|
exit$from$process:
|
|
/* check if GET is above us and about to abort */
|
|
a = rsx$call(.get$fcb$pb);
|
|
if a <> 0ffh then do;
|
|
a = a - 2;
|
|
if prog$flag then
|
|
a = rsx$call(.get$kill$pb);
|
|
end;
|
|
call move(.dfcb(0),.sfcb(0),33); /* move to fcb @ 5ch */
|
|
call getf(.subpb); /* GETF also does submit processing */
|
|
end sub;
|