mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-27 02:14:19 +00:00
Upload
Digital Research
This commit is contained in:
511
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/sub.plm
Normal file
511
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_2/sub.plm
Normal file
@@ -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;
|
||||
|
||||
Reference in New Issue
Block a user