mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
Upload
Digital Research
This commit is contained in:
286
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/sopt.inc
Normal file
286
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/sopt.inc
Normal file
@@ -0,0 +1,286 @@
|
||||
$eject
|
||||
check$choice: procedure(index,mindex) byte;
|
||||
/* does this modifier go with this
|
||||
option? */
|
||||
declare
|
||||
index byte,
|
||||
mindex byte;
|
||||
|
||||
return(opt$mod(index).modifier(mindex));
|
||||
|
||||
end check$choice;
|
||||
|
||||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||||
|
||||
|
||||
* * * 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) byte;
|
||||
|
||||
/* list$ptr - pointer to list of known strings
|
||||
off$ptr - pointer to offsets into known string
|
||||
list
|
||||
buf$ptr - pointer to input string
|
||||
|
||||
Scans the known string list for an occurrance of the input
|
||||
string. If the input string is not found in the known list
|
||||
then return(0). Otherwise, return the index of the known string
|
||||
that matches the input.
|
||||
|
||||
1. Find the known string that matches the input string on the
|
||||
first letter.
|
||||
|
||||
do i = 1 to #known_strings
|
||||
if Known_string(i,1) = input(1) then do
|
||||
|
||||
if length(Known_string(i)) < end_of_input
|
||||
then return(0)
|
||||
|
||||
do j = 2 to end_of_input
|
||||
|
||||
if Known_string(i,j) ~= input(j) then
|
||||
go to again
|
||||
end
|
||||
|
||||
go to 2
|
||||
end
|
||||
again: end
|
||||
|
||||
return (0) !no matchs
|
||||
|
||||
2. Test to see if the input string does not match another Known
|
||||
string. This may happen if the input string is not a
|
||||
unique sub-string of the Known string, ie., DI is a
|
||||
sub-string of DIRECTORY and DISK.
|
||||
|
||||
index = i
|
||||
|
||||
do i = index+1 to #known_strings
|
||||
do j = 1 to end of input
|
||||
|
||||
if Known_string(i,j) ~= input(j) then
|
||||
go to next
|
||||
end
|
||||
|
||||
return(0) !not unique
|
||||
next: end;
|
||||
|
||||
return(index) !unique substring
|
||||
|
||||
P.Balma 10/82 */
|
||||
|
||||
declare
|
||||
buff based buf$ptr (1) byte,
|
||||
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 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);
|
||||
do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5)
|
||||
and (delimiter <> 25));
|
||||
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 */
|
||||
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(0);
|
||||
|
||||
/* 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 */
|
||||
call skip; /* skip input field to next delimiter*/
|
||||
return(0);
|
||||
|
||||
finished: /* unambiguous reference */
|
||||
buf$ptr = buf$ptr + endbuf;
|
||||
call eat$blanks;
|
||||
if delimiter <> 0 then buf$ptr = buf$ptr + 1;
|
||||
else delimiter = SPACE;
|
||||
|
||||
return(save$index);
|
||||
|
||||
end opt$scanner;
|
||||
|
||||
error$prt: procedure;
|
||||
declare i byte,
|
||||
t address,
|
||||
char based t byte;
|
||||
|
||||
t = buf$ptr - endbuf - 1;
|
||||
do i = 1 to endbuf;
|
||||
call printchar(char);
|
||||
t = t + 1;
|
||||
end;
|
||||
|
||||
end error$prt;
|
||||
|
||||
Reference in New Issue
Block a user