seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 16:34:07 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/get.plm
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

940 lines
24 KiB
Plaintext
Raw Blame History

$ TITLE('CP/M 3.0 --- GET user interface')
get:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Written: 30 July 82 by John Knight
12 Sept 82 by Doug Huskey
*/
/********************************************
* *
* LITERALS AND GLOBAL VARIABLES *
* *
********************************************/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
con$type literally '0',
aux$type literally '1',
con$width$offset literally '1ah',
ccp$flag$offset literally '18h',
get$rsx$init literally '128',
get$rsx$kill literally '129',
get$rsx$fcb literally '130',
cpmversion literally '30h';
declare ccp$flag byte;
declare con$width byte;
declare i byte;
declare begin$buffer address;
declare buf$length byte;
declare no$chars byte;
declare get$init$pb byte initial(get$rsx$init);
declare get$kill$pb byte initial(get$rsx$kill);
declare get$fcb$pb byte initial(get$rsx$fcb);
declare input$type byte;
declare
sub$fcb (*) byte data (0,'SYSIN $$$'),
get$msg (*) byte data ('Getting console input from $');
/* scanner variables and data */
declare
options(*) byte data
('INPUT~FROM~FILE~STATUS~CONDITIONAL~',
'FALSE~TRUE~CONSOLE~CONIN:~AUXILIARY~',
'AUXIN:~END~CON:~AUX:~NOT~ECHO~FILTERED~SYSTEM~PROGRAM',0FFH),
options$offset(*) byte data
(0,6,11,16,23,35,41,46,54,61,71,78,82,87,92,96,101,110,117,124),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ./;',0,0ffh),
SPACE byte data(5),
buf$ptr address,
index byte,
endbuf byte,
j byte initial(0),
delimiter byte;
declare end$of$string byte initial ('~');
declare getpb structure
(input$type byte,
echo$flag byte,
filtered$flag byte,
program$flag byte)
initial(con$type,true,true,true);
declare scbpd structure
(offset byte,
set byte,
value address);
declare parse$fn structure
(buff$adr address,
fcb$adr address);
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
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;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
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 */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
conin:
procedure byte;
return mon2(6,0fdh);
end conin;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
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;
check$con$stat: procedure byte;
return mon2(11,0);
end check$con$stat;
open$file:
procedure (fcb$address) address;
declare fcb$address address;
return mon3(15,fcb$address);
end open$file;
set$dma: procedure(dma);
declare dma address;
call mon1(26,dma);
end set$dma;
/* 0ffh ==> return BDOS errors */
return$errors: procedure (mode);
declare mode byte;
call mon1(45,mode);
end return$errors;
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;
get$console$mode: procedure address;
/* returns console mode */
return mon3(6dh,0ffffh);
end get$console$mode;
set$console$mode: procedure (new$value);
declare new$value address;
call mon1(6dh,new$value);
end set$console$mode;
rsx$call: procedure (rsxpb) address;
/* call Resident System Extension */
declare rsxpb address;
return mon3(60,rsxpb);
end rsx$call;
parse: procedure (pfcb) address external;
declare pfcb address;
end parse;
getf: procedure (input$type) external;
declare input$type address;
end getf;
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * Option scanner * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for GET */
do while ((delimiter < 1) or (delimiter > 9));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
if delimiter = 9 then
return;
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* 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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* The error processor. This routine prints the command line
with a carot '^' under the offending delimiter, or sub-string.
The code passed to the routine determines the error message
to be printed beneath the command string. */
error: procedure (code);
declare (code,i,j,nlines,rem) byte;
declare (string$ptr,tstring$ptr) address;
declare chr1 based string$ptr byte;
declare chr2 based tstring$ptr byte;
declare carot$flag byte;
print$command: procedure (size);
declare size byte;
do j=1 to size; /* print command string */
call printchar(chr1);
string$ptr = string$ptr + 1;
end;
call crlf;
do j=1 to size; /* print carot if applicable */
if .chr2 = buf$ptr then do;
carot$flag = true;
call printchar('^');
end;
else
call printchar(' ');
tstring$ptr = tstring$ptr + 1;
end;
call crlf;
end print$command;
carot$flag = false;
string$ptr,tstring$ptr = begin$buffer;
con$width = getscbbyte(con$width$offset);
if con$width < 40 then con$width = 40;
nlines = buf$length / con$width; /* num lines to print */
rem = buf$length mod con$width; /* num extra chars to print */
if code <> 2 then do;
if ((code = 1) or (code = 4)) then /* adjust carot pointer */
buf$ptr = buf$ptr - 1; /* for delimiter errors */
else if code <> 5 then
buf$ptr = buf$ptr - endbuf - 1; /* all other errors */
end;
call crlf;
do i=1 to nlines;
tstring$ptr = string$ptr;
call print$command(con$width);
end;
call print$command(rem);
if carot$flag then
call print$buf(.('Error at the ''^'': $'));
else
call print$buf(.('Error at end of line: $'));
if con$width < 65 then
call crlf;
do case code;
call print$buf(.('Invalid option or modifier$'));
call print$buf(.('End of line expected$'));
call print$buf(.('Invalid file specification$'));
call print$buf(.('Invalid command$'));
call print$buf(.('Invalid delimiter$'));
call print$buf(.('File not found$'));
end;
call crlf;
call mon1(0,0);
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$buf(.('Enter Password: $'));
retry:
call fill(.fcb16,' ',8);
do i=0 to 7;
nxtchr:
if (c:=getucase) >= ' ' then
fcb16(i)=c;
if c = cr then
go to exit;
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;
exit:
c = check$con$stat; /* clear raw i/o mode */
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
print$fn: procedure (fcb$ad);
declare k byte;
declare fcb$ad address;
declare driv based fcb$ad byte;
declare fn based fcb$ad (12) byte;
call print$buf(.('file: $'));
if driv <> 0 then do;
call printchar('@'+driv);
call printchar(':');
end;
do k=1 to 11;
if k=9 then
call printchar('.');
if fn(k) <> ' ' then
call printchar(fn(k) and 07fh);
end;
end print$fn;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
try$open: procedure;
declare (error$code,a) address;
declare prog$flag based a byte;
declare code byte;
error$code = rsx$call(.get$fcb$pb);
if error$code <> 0ffh then do; /* 0ffh means no active get */
a = error$code - 2;
if prog$flag then /* program input only? */
error$code = rsx$call(.get$kill$pb); /* kill if so */
end;
call setdma(.fcb16); /* set dma to password */
call return$errors(0ffh);
error$code = open$file(.fcb);
call return$errors(0);
if low(error$code) = 0ffh then
if (code := high(error$code)) <> 0 then do;
if code = 7 then do;
call getpasswd;
call crlf;
call setdma(.fcb16);
end;
error$code=open$file(.fcb);
end;
else do;
buf$ptr = parse$fn.buff$adr; /* adjust pointer to file */
call error(5); /* file not found */
end;
call print$buf(.get$msg);
if getscbbyte(26) < 48 then
call crlf; /* console width */
call print$fn(.fcb);
call getf(.getpb);
end try$open;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
submit: procedure(adr) byte;
declare adr address;
declare fn based adr (12) byte;
declare (i,match) byte;
compare: procedure(j);
dcl j byte;
if (fn(j) and 07fh) = sub$fcb(j) then
return;
match = false;
end compare;
match = true;
do i = 1 to 3; /* sub = SYS $$$ */
call compare(i);
call compare(i+8);
end;
return match;
end submit;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
kill$rsx: procedure;
declare (fcb$adr,a) address;
if delimiter <> 9 then /* check for eoln */
call error(1);
/* remove SUBMIT & GET rsx modules */
do while (fcb$adr:=rsx$call(.get$fcb$pb)) <> 0ffh;
a = rsx$call(.get$kill$pb);
if submit(fcb$adr) then
call print$buf(.('SUBMIT of $'));
else
call print$buf(.('GET from $'));
call print$fn(fcb$adr);
call print$buf(.(' stopped$'));
call crlf;
end;
call print$buf(.get$msg);
call print$buf(.('console$'));
call mon1(0,0);
end kill$rsx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
end$rsx: procedure;
declare (a,fcb$adr) address;
if delimiter <> 9 then /* check for eoln */
call error(1);
if (fcb$adr := rsx$call(.get$fcb$pb)) <> 0ffh then
if not submit(fcb$adr) then do;
a = rsx$call(.get$kill$pb);
call print$buf(.('GET from $'));
call print$fn(fcb$adr);
call print$buf(.(' stopped$'));
call crlf;
end;
/* determine where console input comes from now */
call print$buf(.get$msg);
fcb$adr = rsx$call(.get$fcb$pb);
if fcb$adr = 0ffh then
call print$buf(.('console$'));
else do;
if getscbbyte(26) < 48 then
call crlf; /* console width */
call print$fn(fcb$adr);
end;
call mon1(0,0);
end end$rsx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
set$rsx$mode: procedure (bit$value);
declare bit$value byte;
declare temp address;
temp = get$console$mode;
temp = temp and 111111$00$11111111b; /* mask off bits to be set */
if bit$value <> 0 then
temp = temp or (255 + bit$value);
call set$console$mode(temp);
end set$rsx$mode;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
process$file: procedure(buf$adr);
declare negate byte;
declare status address;
declare buf$adr address;
declare char based status byte;
parse$fn.buff$adr = buf$adr;
parse$fn.fcb$adr = .fcb;
status = parse(.parse$fn);
if status = 0ffffh then
call error(2); /* bad file */
if status = 0 then /* eoln */
call try$open; /* try$open does not return */
else
buf$ptr = status + 1; /* position buf$ptr past '[' */
if char <> '[' then /* PROCESS OPTIONS */
call error(4);
do while ((delimiter<>2) and (delimiter<>9));
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 4 then do; /* STATUS */
if delimiter <> 3 then /* '=' */
call error(4);
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 5 then /* CONDITIONAL */
call set$rsx$mode(0);
else if index = 6 then /* FALSE */
call set$rsx$mode(1);
else if index = 7 then /* TRUE */
call set$rsx$mode(2);
else
call error(0); /* Not a valid option */
end;
else do; /* ECHO, FILTER, & SYSTEM options */
negate=false;
if index = 15 then do;
negate = true;
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 16 then do; /* ECHO */
if negate then
getpb.echo$flag = false;
else
getpb.echo$flag = true;
end;
else if index = 17 then do; /* FILTER */
if negate then
getpb.filtered$flag = false;
else
getpb.filtered$flag = true;
end;
else if index = 18 then do; /* SYSTEM */
if negate then
getpb.program$flag = true;
else
getpb.program$flag = false;
end;
else if index = 19 then do; /* PROGRAM */
if negate then
getpb.program$flag = false;
else
getpb.program$flag = true;
end;
else
call error(0);
end;
end;
call try$open; /* all set up, so do open */
end process$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*********************************
* *
* M A I N P R O G R A M *
* *
*********************************/
plm:
do;
if (low(version) < cpmversion) or (high(version)=1) then do;
call print$buf(.('Requires CP/M 3.0$'));
call mon1(0,0);
end;
if not input$found(.tbuff(1)) then do; /* just GET */
call print$buf(.('CP/M 3 GET Version 3.0',cr,lf,'$'));
call print$buf(.('Get console input from a file',cr,lf,'$'));
call print$buf(.('Enter file: $'));
no$chars = read$console$buf(.tbuff(0),128);
call crlf;
tbuff(1) = ' '; /* blank out nc field */
tbuff(no$chars+2) = 0; /* mark eoln */
if not input$found(.tbuff(1)) then /* quit, no file name */
call mon1(0,0);
do i=1 to no$chars; /* make input capitals */
tbuff(i+1) = ucase(tbuff(i+1));
end;
begin$buffer = .tbuff(2);
buf$length = no$chars;
buf$ptr = .tbuff(2);
call process$file(.tbuff(2));
end;
else do; /* Get with input */
i = 1; /* skip over leading spaces */
do while (tbuff(i) = ' ');
i = i + 1;
end;
begin$buffer = .tbuff(1); /* note beginning of input */
buf$length = tbuff(0); /* note length of input */
buf$ptr = .tbuff(i); /* set up for scanner */
index = 0;
delimiter = 1;
call opt$scanner(.options(0),.options$offset(0),.index);
if (index=10) or (index=11) or (index=14) then do; /* AUX */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 1 then /* INPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* FROM */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then do; /* FILE */
getpb.input$type=aux$type;
call process$file(buf$ptr);
end;
else do;
if (index=10) or (index=11) or (index=14) then /* AUX */
call kill$rsx;
else
call error(3);
end;
end;
else do; /* not AUX */
if index = 12 then /* END */
call end$rsx;
if (index=8) or (index=9) or (index=13) then do; /* CONSOLE */
if delimiter = 9 then
call kill$rsx;
else
call opt$scanner(.options(0),.options$offset(0),.index);
end;
if index = 1 then /* INPUT */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 2 then /* FROM */
call opt$scanner(.options(0),.options$offset(0),.index);
if index = 3 then /* FILE */
call process$file(buf$ptr);
if (index=8) or (index=9) or (index=13) then /* CONIN:, CONSOLE */
call kill$rsx;
else
call error(3);
end;
end;
end;
end get;
Reference in New Issue View Git Blame Copy Permalink