mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 09:24:19 +00:00
1334 lines
38 KiB
Plaintext
1334 lines
38 KiB
Plaintext
$ TITLE('CP/M 3.0 --- DEVICE')
|
||
device:
|
||
do;
|
||
|
||
/*
|
||
Copyright (C) 1982
|
||
Digital Research
|
||
P.O. Box 579
|
||
Pacific Grove, CA 93950
|
||
*/
|
||
|
||
/*
|
||
Written: 09 July 82 by John Knight
|
||
Revised 02 Dec 82 by Bruce Skidmore
|
||
*/
|
||
|
||
/********************************************
|
||
* *
|
||
* 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',
|
||
conin$disp literally '22h',
|
||
conout$disp literally '24h',
|
||
auxin$disp literally '26h',
|
||
auxout$disp literally '28h',
|
||
listout$disp literally '2ah',
|
||
mb$input literally '1',
|
||
mb$output literally '2',
|
||
mb$in$out literally '3',
|
||
mb$soft$baud literally '4',
|
||
mb$serial literally '8',
|
||
mb$xon$xoff literally '16',
|
||
dev$table$adr$func literally '20',
|
||
dev$init$func literally '21',
|
||
cpmversion literally '30h',
|
||
console$page$offset literally '1ch',
|
||
console$width$offset literally '1ah';
|
||
|
||
declare begin$buffer address;
|
||
declare buf$length byte;
|
||
declare con$width byte;
|
||
declare con$page byte;
|
||
declare phys$dev$table$adr address;
|
||
declare no$chars byte;
|
||
declare string$adr address;
|
||
declare i byte;
|
||
declare device$bit$table (16) byte;
|
||
declare memory (255) byte; /* assignment input buffer */
|
||
/* scanner variables and data */
|
||
declare
|
||
options(*) byte data
|
||
('NAMES~VALUES~HELP~CON:~CONIN:~CONOUT:~LST:~',
|
||
'AUX:~AUXIN:~AUXOUT:~CONSOLE~KEYBOARD~',
|
||
'PRINTER~AUXILIARY~AXI:~AXO:',0ffh),
|
||
|
||
options$offset(*) byte data
|
||
(0,6,13,18,23,30,38,43,48,55,63,71,80,88,98,103,107),
|
||
|
||
mods(*) byte data
|
||
('XON~NOXON~NULL~50 ~75 ~110~134~150~300~',
|
||
'600~1200~1800~2400~3600~4800~7200~',
|
||
'9600~19200',0ffh),
|
||
|
||
mods$offset(*) byte data
|
||
(0,4,10,15,21,27,31,35,39,43,47,52,57,62,
|
||
67,72,77,82,87),
|
||
|
||
page$options (*) byte data
|
||
('COLUMNS~LINES~PAGESIZE',0ffh),
|
||
|
||
page$offsets (*) byte data
|
||
(0,8,14,22),
|
||
|
||
end$list byte data (0ffh),
|
||
|
||
delimiters(*) byte data (0,'[]=, ',0,0ffh),
|
||
|
||
SPACE byte data(5),
|
||
j byte initial(0),
|
||
buf$ptr address,
|
||
index byte,
|
||
endbuf byte,
|
||
delimiter byte;
|
||
|
||
declare end$of$string byte initial ('~');
|
||
|
||
/* tables */
|
||
declare phys$table (15) structure
|
||
(name(6) byte,
|
||
characteristic byte,
|
||
baud byte);
|
||
|
||
declare biospb structure
|
||
(func byte,
|
||
areg byte,
|
||
bcreg address,
|
||
dereg address,
|
||
hlreg address);
|
||
|
||
declare scbpd structure
|
||
(offset byte,
|
||
set byte,
|
||
value address);
|
||
|
||
declare baud$rates (*) byte data
|
||
('NONE 50 75 110 134 150 300 600 ',
|
||
'1200 1800 2400 3600 4800 7200 9600 19200');
|
||
|
||
declare baud$table (16) structure
|
||
(graphic (5) byte) at (.baud$rates(0));
|
||
|
||
declare log$offsets (*) byte data
|
||
(0,conin$disp,conout$disp,listout$disp,1,auxin$disp,
|
||
auxout$disp,3,conin$disp,listout$disp,2,auxin$disp,auxout$disp);
|
||
|
||
declare characteristics$table (*) byte data
|
||
('INPUT $OUTPUT $SOFT-BAUD$SERIAL $XON-XOFF $');
|
||
|
||
declare char$table (5) structure
|
||
(graphic (10) byte) at (.characteristics$table(0));
|
||
|
||
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;
|
||
|
||
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 chars input */
|
||
end read$console$buf;
|
||
|
||
version: procedure address;
|
||
/* returns current cp/m version # */
|
||
return mon3(12,0);
|
||
end version;
|
||
|
||
getscbbyte: procedure (offset) byte;
|
||
declare offset byte;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0;
|
||
return mon2(49,.scbpd);
|
||
end getscbbyte;
|
||
|
||
getscbword:
|
||
procedure (offset) address;
|
||
declare offset byte;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0;
|
||
return mon3(49,.scbpd);
|
||
end getscbword;
|
||
|
||
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;
|
||
|
||
setscbword:
|
||
procedure (offset,value);
|
||
declare offset byte;
|
||
declare value address;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0FEh;
|
||
scbpd.value = value;
|
||
call mon1(49,.scbpd);
|
||
end setscbword;
|
||
|
||
direct$bios:
|
||
procedure (func) address;
|
||
declare func byte;
|
||
biospb.func = func;
|
||
return mon3(50,.biospb);
|
||
end direct$bios;
|
||
|
||
/**************************************
|
||
* *
|
||
* 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 DEVICE */
|
||
do while ((delimiter < 1) or (delimiter > 6));
|
||
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;
|
||
|
||
/* 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;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
ucase: procedure (char) byte;
|
||
declare char byte;
|
||
if char >= 'a' then
|
||
if char < '{' then
|
||
return (char-20h);
|
||
return char;
|
||
end ucase;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
crlf: proc;
|
||
call printchar(cr);
|
||
call printchar(lf);
|
||
end crlf;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* fill string @ s for c bytes with f */
|
||
fill: proc(s,f,c);
|
||
dcl s addr,
|
||
(f,c) byte,
|
||
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 determmines the error message
|
||
to be printed beneath the command string. */
|
||
|
||
errors: 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;
|
||
if con$width < 40 then con$width = 40; /* minimum size screen assumed */
|
||
nlines = buf$length / con$width; /* determine number lines to print */
|
||
rem = buf$length mod con$width; /* number of extra characters */
|
||
if (code = 2) or (code = 1) then /* adjust carot pointer */
|
||
buf$ptr = buf$ptr - 1; /* for delimiter errors */
|
||
else
|
||
buf$ptr = buf$ptr - endbuf - 1; /* for sub-string errors */
|
||
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 < 63 then
|
||
call crlf;
|
||
do case code; /* error messages */
|
||
call print$buf(.('Invalid number$'));
|
||
call print$buf(.('End of line expected$'));
|
||
call print$buf(.('Invalid delimiter$'));
|
||
call print$buf(.('Invalid option$'));
|
||
call print$buf(.('Baud rate can not be set for this device$'));
|
||
call print$buf(.('Invalid physical device$'));
|
||
call print$buf(.('Physical device does not have input capability$'));
|
||
call print$buf(.('Physical device does not have output capability$'));
|
||
call print$buf(.('Physical device does not have input/output capability$'));
|
||
call print$buf(.('A NULL device can not be assigned to CONIN$'));
|
||
call print$buf(.('Ambiguous assignments to a NULL device are not allowed$'));
|
||
end;
|
||
call crlf;
|
||
call mon1(0,0);
|
||
end errors;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* Help display. A simple print of the syntax accepted by this
|
||
utility. The display assumes a minimum 40 column screen and
|
||
does not give an explanation to the commands. For quick ref. only
|
||
|
||
help: procedure; COMMENTED OUT -- NEW HELP
|
||
PROGRAM WILL REPLACE THIS
|
||
DISPLAY
|
||
call print$buf(.(
|
||
'COMMAND SYNTAX:',cr,lf,cr,lf,
|
||
'DEVICE',cr,lf,
|
||
'DEVICE NAMES',cr,lf,
|
||
'DEVICE VALUES',cr,lf,
|
||
'DEVICE pd',cr,lf,
|
||
'DEVICE ld',cr,lf,
|
||
'DEVICE ld=pd[opt,opt],pd[opt],...',cr,lf,
|
||
'DEVICE pd[opt,opt]',cr,lf,
|
||
'DEVICE ld=NULL',cr,lf,
|
||
'DEVICE CONSOLE[COLUMNS=nnn,LINES=nnn]',cr,lf,
|
||
'DEVICE CONSOLE[PAGESIZE]',cr,lf,cr,lf,
|
||
'pd = a physical device',cr,lf,
|
||
'ld = a logical device',cr,lf,
|
||
' CON:,CONIN:,CONOUT:,LST:,AUX:,',cr,lf,
|
||
' AUXIN:,AXI:,AUXOUT:,AXO:,CONSOLE,',cr,lf,
|
||
' KEYBOARD,PRINTER, or AUXILIARY',cr,lf,
|
||
'opt = a valid option',cr,lf,
|
||
' XON,NOXON, or a baud rate: 50,',cr,lf,
|
||
' 75,110,134,150,300,600,1200,1800,',cr,lf,
|
||
' 2400,3600,4800,7200,9600,19200',cr,lf,
|
||
'nnn = a number; 0-255',cr,lf,'$'));
|
||
end help; */
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
set$bit:
|
||
procedure (val,bit) address;
|
||
/* sets a bit in 0-15 in val, returns val */
|
||
declare bit byte;
|
||
declare val address;
|
||
declare temp address;
|
||
temp = 1;
|
||
bit = 15 - bit;
|
||
if bit <> 0 then
|
||
temp = shl(temp,bit);
|
||
val = val or temp;
|
||
return val;
|
||
end set$bit;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine assigns to a word in the system control block a
|
||
bit pattern as specified in the device$bit$table. */
|
||
|
||
make$assignments: procedure (offset);
|
||
declare (i,offset) byte;
|
||
declare val address;
|
||
val = 0; /* clear address to be set */
|
||
do i=0 to 15;
|
||
if device$bit$table(i) = 1
|
||
then val= set$bit(val,i);
|
||
end;
|
||
call setscbword(offset,val);
|
||
end make$assignments;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine prints the physical device located in the
|
||
physical device table at the index passed to the routine */
|
||
|
||
print$phys$device: procedure (index);
|
||
declare (i,index) byte;
|
||
do i=0 to 5;
|
||
call printchar(phys$table(index).name(i));
|
||
end;
|
||
end print$phys$device;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine prints the baud rate corresponding to the baud
|
||
code found in the physical device table. The index to the
|
||
physical device table is passed to this routine. */
|
||
|
||
print$baud$rate: procedure (index);
|
||
declare (k,index,baud) byte;
|
||
baud = phys$table(index).baud;
|
||
if baud > 15 then baud = 0;
|
||
do k=0 to 4;
|
||
call printchar(baud$table(baud).graphic(k));
|
||
end;
|
||
end print$baud$rate;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine prints the physical characteristics codes for
|
||
a specific physical device found in the physical device table.
|
||
This procedure is called by names. */
|
||
|
||
print$phys$characteristics: procedure (index);
|
||
declare (char,index,ct) byte;
|
||
ct = 0;
|
||
char = phys$table(index).characteristic;
|
||
char = shr(char,1);
|
||
if carry = 0ffh then do; /* input bit */
|
||
call printchar('I');
|
||
ct = ct + 1;
|
||
end;
|
||
char = shr(char,1);
|
||
if carry = 0ffh then do; /* output bit */
|
||
call printchar('O');
|
||
ct = ct + 1;
|
||
end;
|
||
char = shr(char,2); /* skip soft-baud */
|
||
if carry = 0ffh then do; /* serial bit in carry */
|
||
call printchar('S');
|
||
ct = ct + 1;
|
||
end;
|
||
char = shr(char,1);
|
||
if carry = 0ffh then do; /* xon-xoff bit */
|
||
call printchar('X');
|
||
ct = ct + 1;
|
||
end;
|
||
do while ct <> 4;
|
||
call printchar(' ');
|
||
ct = ct + 1;
|
||
end;
|
||
end print$phys$characteristics;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine prints the names of the physical devices as well
|
||
as the baud rate and characteristics codes. */
|
||
|
||
names: procedure;
|
||
declare (i,j,cols,char,baud,k) byte;
|
||
call crlf;
|
||
call print$buf(.('Physical Devices: ',cr,lf,'$'));
|
||
call print$buf(.('I=Input,O=Output,S=Serial,X=Xon-Xoff',cr,lf,'$'));
|
||
i = con$width;
|
||
if i < 40 then i = 40;
|
||
cols = i / 20; /* determine columns per line */
|
||
j = 0; /* table index */
|
||
crloop: i=1; /* columns counter */
|
||
process: if phys$table(j).name(0) = 0 then do;
|
||
call crlf;
|
||
return;
|
||
end;
|
||
/* print device name, baud, and attributes */
|
||
call print$phys$device(j);
|
||
call printchar(' ');
|
||
call print$baud$rate(j);
|
||
call printchar(' ');
|
||
call print$phys$characteristics(j);
|
||
call print$buf(.(' $'));
|
||
j = j + 1;
|
||
if i >= cols then do;
|
||
call crlf;
|
||
goto crloop;
|
||
end;
|
||
i = i + 1;
|
||
goto process;
|
||
end names;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine prints the physical devices that are assigned
|
||
to the logical device. The bit pattern of the vector passed
|
||
to this routine determines the current assignments to the device */
|
||
|
||
show$physical$devices:
|
||
procedure (vector);
|
||
declare vector address;
|
||
declare device$present byte;
|
||
declare bit$table (16) byte;
|
||
declare (i,k,cols,max) byte;
|
||
i = con$width;
|
||
if i < 40 then i = 40;
|
||
cols = (i - 10) / 7; /* determine phys$devices per line */
|
||
do i = 0 to 15;
|
||
vector = shl(vector,1);
|
||
bit$table(i) = carry; /* ff = 1, 0 = 0 */
|
||
end;
|
||
i = 0;
|
||
do while phys$table(i).name(0) <> 0;
|
||
if i = 15 then goto set$max;
|
||
i = i + 1;
|
||
end;
|
||
set$max: max = i; /* number of entries in table */
|
||
device$present = false;
|
||
k = 1; /* cols printed count */
|
||
do i = 0 to 14;
|
||
if bit$table(i) = 0ffh then do;
|
||
/* obtain match from physical device table */
|
||
if i > max then do;
|
||
call print$buf(.(cr,lf,'Bad Logical Device Assignment; $'));
|
||
call print$buf(.('Physical Device Does Not Exist$'));
|
||
call crlf;
|
||
return;
|
||
end;
|
||
device$present = true;
|
||
call print$phys$device(i);
|
||
call printchar(' ');
|
||
k = k + 1;
|
||
if k > cols then do;
|
||
k = 1;
|
||
call crlf;
|
||
call print$buf(.(' $'));
|
||
end;
|
||
end;
|
||
end;
|
||
if bit$table(15) = 0ffh then do; /* File assignment */
|
||
device$present = true;
|
||
call print$buf(.('File$'));
|
||
end;
|
||
if (device$present = false) then
|
||
call print$buf(.('Null Device$'));
|
||
call crlf;
|
||
end show$physical$devices;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This procedure produces the values display. It shows all the
|
||
assignments of physical devices to the logical devices */
|
||
|
||
values: procedure;
|
||
declare val address;
|
||
call crlf;
|
||
call print$buf(.('Current Assignments: ',cr,lf,'$'));
|
||
val = getscbword(conin$disp);
|
||
call print$buf(.('CONIN: = $'));
|
||
call show$physical$devices(val);
|
||
val = getscbword(conout$disp);
|
||
call print$buf(.('CONOUT: = $'));
|
||
call show$physical$devices(val);
|
||
val = getscbword(auxin$disp);
|
||
call print$buf(.('AUXIN: = $'));
|
||
call show$physical$devices(val);
|
||
val = getscbword(auxout$disp);
|
||
call print$buf(.('AUXOUT: = $'));
|
||
call show$physical$devices(val);
|
||
val = getscbword(listout$disp);
|
||
call print$buf(.('LST: = $'));
|
||
call show$physical$devices(val);
|
||
call crlf;
|
||
end values;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This procedure searches for the string pointed to by
|
||
search$string$adr in the local physical device table.
|
||
The length of the input string is determined by endbuf. */
|
||
|
||
search$physical$table:
|
||
procedure (search$string$adr) byte;
|
||
declare (i,j) byte;
|
||
declare search$string$adr address;
|
||
declare string (6) byte;
|
||
declare loc based search$string$adr (6) byte;
|
||
if endbuf > 6 then return 0ffh;
|
||
call fill(.string(0),' ',6);
|
||
do i=0 to (endbuf-1);
|
||
string(i)=loc(i);
|
||
end;
|
||
i = 0;
|
||
do while phys$table(i).name(0) <> 0;
|
||
do j=0 to 5;
|
||
if string(j) <> phys$table(i).name(j)
|
||
then goto search$next;
|
||
end;
|
||
return i; /* found; return index */
|
||
search$next: i=i+1;
|
||
if i > 15 then return 0ffh; /* not found */
|
||
end;
|
||
return 0ffh; /* not found, table empty */
|
||
end search$physical$table;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine processes the physical device options: 'XON','NOXON'
|
||
and the baud rates. It calls the scanner and processes on the fly */
|
||
|
||
process$option: procedure (table$index);
|
||
declare table$index byte;
|
||
declare soft$baud byte;
|
||
declare (char,baud) byte;
|
||
declare val address;
|
||
char = phys$table(table$index).characteristic;
|
||
baud = phys$table(table$index).baud;
|
||
index = 0;
|
||
delimiter = 1;
|
||
do while((delimiter <> 2) and (delimiter <> 6));
|
||
call opt$scanner(.mods(0),.mods$offset(0),.index);
|
||
if index = 0 then call errors(3);
|
||
if index = 3 then call errors(3);
|
||
if index = 1 then /* Xon */
|
||
phys$table(table$index).characteristic = char or mb$xon$xoff;
|
||
if index = 2 then /* No Xon */
|
||
phys$table(table$index).characteristic = char and (not mb$xon$xoff);
|
||
if index > 2 then do; /* baud rates to be set */
|
||
index = index - 3;
|
||
/* set baud rate only if soft$baud set to 1 */
|
||
soft$baud = shr(char,3);
|
||
soft$baud = carry; /* 0ffh = 1, 0 = 0 */
|
||
if soft$baud = 0 then
|
||
call errors(4);
|
||
/* set baud in table and have bios initialize device */
|
||
phys$table(table$index).baud = index;
|
||
/* move local phys$device table to actual table in bios */
|
||
call move(120,.phys$table(0),phys$dev$table$adr);
|
||
biospb.bcreg = double(table$index);
|
||
val = direct$bios(dev$init$func);
|
||
end;
|
||
else
|
||
call move(120,.phys$table(0),phys$dev$table$adr);
|
||
end;
|
||
end process$option;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine converts an ascii number string into a byte number.
|
||
ie. 32h 35h 35h ==> FFh in one byte. Numbers allowed are 0-255 */
|
||
|
||
number: procedure (loc,length) byte;
|
||
declare (loc,val) address;
|
||
declare (length,i) byte;
|
||
declare chr based loc byte;
|
||
if length > 3 then
|
||
call errors(0);
|
||
val = 0;
|
||
do i=1 to length;
|
||
if (chr < 30h) or (chr > 39h) then
|
||
call errors(0);
|
||
val = val * 10 + (chr - 30h);
|
||
loc = loc + 1;
|
||
end;
|
||
if val > 255 then
|
||
call errors(0);
|
||
return low(val);
|
||
end number;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine converts a byte into an ascii string of numbers,
|
||
printing the number to the screen. ie. FFh ==> 255 */
|
||
|
||
print$byte: procedure (num);
|
||
declare (hundreds,tens,ones,num) byte;
|
||
hundreds = num / 100;
|
||
num = num - (100 * hundreds);
|
||
tens = num / 10;
|
||
ones = num - (10 * tens);
|
||
if hundreds > 0 then
|
||
call printchar(hundreds + 30h);
|
||
if (hundreds > 0) or (tens > 0) then
|
||
call printchar(tens + 30h);
|
||
call printchar(ones + 30h);
|
||
end print$byte;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This procedure processes the console page setting options.
|
||
It parses the command options and sets the scb page accordingly.
|
||
The result of the process is displayed showing the user the
|
||
number of lines and columns of the console. */
|
||
|
||
process$page$options: procedure;
|
||
declare num byte;
|
||
delimiter=1;
|
||
index=0;
|
||
do while ((delimiter <> 2) and (delimiter <> 6));
|
||
call opt$scanner(.page$options(0),.page$offsets(0),.index);
|
||
if index = 0 then /* bad option */
|
||
call errors(3);
|
||
if index = 1 then do; /* columns */
|
||
if delimiter <> 3 then /* '=' */
|
||
call errors(2);
|
||
else do;
|
||
call opt$scanner(.page$options(0),.page$offsets(0),.index);
|
||
num = number(buf$ptr-endbuf-1,endbuf)-1;
|
||
call setscbbyte(console$width$offset,num);
|
||
end;
|
||
end;
|
||
if index = 2 then do; /* lines */
|
||
if delimiter <> 3 then
|
||
call errors(2);
|
||
else do;
|
||
call opt$scanner(.page$options(0),.page$offsets(0),.index);
|
||
num = number(buf$ptr-endbuf-1,endbuf)-1;
|
||
call setscbbyte(console$page$offset,num);
|
||
end;
|
||
end;
|
||
end;
|
||
con$width = getscbbyte(console$width$offset);
|
||
con$page = getscbbyte(console$page$offset);
|
||
call crlf;
|
||
call print$buf(.('Console width set to $'));
|
||
call print$byte(con$width+1);
|
||
call print$buf(.(' columns',cr,lf,'Console page set to $'));
|
||
call print$byte(con$page+1);
|
||
call print$buf(.(' lines',cr,lf,'$'));
|
||
call crlf;
|
||
call mon1(0,0);
|
||
end process$page$options;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine produces the display of the assignments to an
|
||
individual logical device. The command that invokes this
|
||
procedure is 'DEVICE <logical device>'. */
|
||
|
||
show$assignments: procedure (index);
|
||
declare (index,offset) byte;
|
||
declare val address;
|
||
offset = log$offsets(index-4);
|
||
if (offset = 0) or (offset = 3) then do; /* CON: */
|
||
call print$buf(.('CONIN: = $'));
|
||
val = getscbword(conin$disp);
|
||
call show$physical$devices(val);
|
||
call print$buf(.('CONOUT: = $'));
|
||
val = getscbword(conout$disp);
|
||
call show$physical$devices(val);
|
||
end;
|
||
if (offset = 1) or (offset = 2) then do; /* AUX: */
|
||
call print$buf(.('AUXIN: = $'));
|
||
val = getscbword(auxin$disp);
|
||
call show$physical$devices(val);
|
||
call print$buf(.('AUXOUT: = $'));
|
||
val = getscbword(auxout$disp);
|
||
call show$physical$devices(val);
|
||
end;
|
||
if offset > 3 then do; /* all others */
|
||
do case (offset - 22h);
|
||
call print$buf(.('CONIN: = $'));
|
||
;
|
||
call print$buf(.('CONOUT: = $'));
|
||
;
|
||
call print$buf(.('AUXIN: = $'));
|
||
;
|
||
call print$buf(.('AUXOUT: = $'));
|
||
;
|
||
call print$buf(.('LST: = $'));
|
||
end;
|
||
val = getscbword(offset);
|
||
call show$physical$devices(val);
|
||
end;
|
||
call crlf;
|
||
call mon1(0,0);
|
||
end show$assignments;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine is called if the first sub-string in the command
|
||
line was determined to be a logical device. If an end-of-line
|
||
is the delimiter, the routine will display the assignments to
|
||
the specified logical device. If a '[' is found as the delimiter
|
||
and the logical device is console, then the option processor to
|
||
set the console page parameters is called. If the delimiter was
|
||
an '=' then an assignment of physical devices to the logical
|
||
device is done. */
|
||
|
||
found$logical$device: procedure;
|
||
declare (save$index,offset,eoln,i,val) byte;
|
||
declare next$delim based buf$ptr byte;
|
||
save$index = index; /* save index to logical device */
|
||
if (delimiter = 0) or (delimiter = 6)
|
||
then call show$assignments(index); /* DEVICE <log. dev> */
|
||
else do;
|
||
if delimiter = 1 then do; /* '[' */
|
||
if (index=4) or (index=5) or (index=6) or (index=11) then
|
||
call process$page$options; /* DEVICE CON:[col=45,lines=21] */
|
||
else
|
||
call errors(2);
|
||
end;
|
||
else if delimiter <> 3 then
|
||
call errors(2);
|
||
end;
|
||
delimiter = 1; /* do assignment: DEVICE CON:=CRT,CRT1[XON,1200],... */
|
||
index = 0;
|
||
call opt$scanner(.mods(0),.mods$offset(0),.index);
|
||
offset = log$offsets(save$index - 4);
|
||
if index = 3 then do; /* NULL */
|
||
if (offset < 4) then do; /* CON: and AUX:*/
|
||
call errors(10);
|
||
end;
|
||
else do;
|
||
if (offset=conin$disp) then do;
|
||
call errors(9);
|
||
end;
|
||
else do;
|
||
call setscbword(offset,0);
|
||
end;
|
||
end;
|
||
end;
|
||
else do; /* Process physical name */
|
||
eoln = false;
|
||
do i = 0 to 15; /* clear bit table */
|
||
device$bit$table(i) = 0;
|
||
end;
|
||
do while not eoln;
|
||
val = search$physical$table(buf$ptr-endbuf-1);
|
||
if val = 0ffh then /* not found */
|
||
call errors(5);
|
||
device$bit$table(val) = 1; /* mark bit to be set in log device vector */
|
||
if delimiter = 1 then
|
||
call process$option(val);
|
||
if (delimiter=0) or (delimiter=6) or ((delimiter=2) and (next$delim=0))
|
||
then eoln = true;
|
||
if ((delimiter = 2) and (next$delim = ',')) then
|
||
buf$ptr = buf$ptr + 1; /* case where 2 delimiters: '],' */
|
||
if not eoln then
|
||
call opt$scanner(.mods(0),.mods$offset(0),.index);
|
||
end;
|
||
if (offset = 0) or (offset = 3) then do; /* CON: */
|
||
if ((phys$table(val).characteristic and mb$in$out)=mb$in$out) then do;
|
||
call make$assignments(conin$disp);
|
||
call make$assignments(conout$disp);
|
||
end;
|
||
else call errors(8);
|
||
end;
|
||
else do;
|
||
if ((offset=1) or (offset=2)) then do; /* AUX: */
|
||
if ((phys$table(val).characteristic and mb$in$out)=mb$in$out) then do;
|
||
call make$assignments(auxin$disp);
|
||
call make$assignments(auxout$disp);
|
||
end;
|
||
else call errors(8);
|
||
end;
|
||
else do;
|
||
if ((offset=conin$disp) or (offset=auxin$disp)) then do;
|
||
if ((phys$table(val).characteristic and mb$input)<> mb$input)
|
||
then call errors(6);
|
||
else call make$assignments(offset); /* CONIN: OR AUXIN: */
|
||
end;
|
||
else do;
|
||
if ((phys$table(val).characteristic and mb$output)<> mb$output)
|
||
then call errors(7);
|
||
else call make$assignments(offset); /* CONOUT: OR AUXOUT: OR LSTOUT: */
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
end found$logical$device;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine produces the display invoked by the command
|
||
string: 'DEVICE <physical device>'. It prints the characteristics
|
||
of the device as found in the physical device table */
|
||
|
||
show$characteristics: procedure (index);
|
||
declare (index,char,baud,j,i) byte;
|
||
char = phys$table(index).characteristic;
|
||
baud = phys$table(index).baud;
|
||
call crlf;
|
||
call print$buf(.('Physical Device: $'));
|
||
call print$phys$device(index);
|
||
call crlf;
|
||
call print$buf(.('Baud Rate: $'));
|
||
call print$baud$rate(index);
|
||
call crlf;
|
||
call print$buf(.('Characteristics: $'));
|
||
do i=0 to 4;
|
||
char = shr(char,1);
|
||
if carry = 0ffh then do;
|
||
call print$buf(.char$table(i));
|
||
call crlf;
|
||
do j=0 to 17;
|
||
call printchar(' ');
|
||
end;
|
||
end;
|
||
else do;
|
||
if i = 3 then do;
|
||
call print$buf(.('PARALLEL$'));
|
||
call crlf;
|
||
do j=0 to 17;
|
||
call printchar(' ');
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
call mon1(0,0);
|
||
end show$characteristics;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine is called whenever a presummed physical device
|
||
is found as the first entry by the parser. It looks up the
|
||
string in the physical device table to validate it. If the
|
||
device has options, it calls process option to set the baud & protocol */
|
||
|
||
found$physical$device: procedure (string$adr);
|
||
declare (eoln,index) byte;
|
||
declare string$adr address;
|
||
if (delimiter=0) or (delimiter=6) then
|
||
eoln = true;
|
||
else
|
||
eoln = false;
|
||
index = search$physical$table(string$adr);
|
||
if index = 0ffh then
|
||
call errors(5);
|
||
if eoln then /* DEVICE <phys.dev> */
|
||
call show$characteristics(index);
|
||
if delimiter = 1 then
|
||
call process$option(index);
|
||
else
|
||
call errors(2);
|
||
end found$physical$device;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* This routine determines which of the sub-routines should
|
||
continue with the parsing and eventual execution of the
|
||
command string. In the event that the commands were 'NAMES',
|
||
'VALUES', no further parsing is needed and the routines
|
||
are called directly to produce the desired displays. */
|
||
|
||
parser: procedure;
|
||
declare (t,char,i) byte;
|
||
declare eoln byte;
|
||
declare phys$dev byte;
|
||
declare log$dev byte;
|
||
delimiter = 1;
|
||
index = 0;
|
||
if tbuff(0) = 0 then
|
||
begin$buffer,buf$ptr = .memory(2);
|
||
else do;
|
||
buf$ptr = .tbuff(2);
|
||
begin$buffer = .tbuff(1);
|
||
buf$length = tbuff(0);
|
||
end;
|
||
call opt$scanner(.options(0),.options$offset(0),.index);
|
||
if (delimiter=0) or (delimiter=2) or (delimiter=6) then
|
||
eoln = true;
|
||
else
|
||
eoln = false;
|
||
if (index = 0) or (index = 3) then do; /* HELP is now a valid phys device */
|
||
call found$physical$device(buf$ptr-endbuf-1);
|
||
call names; /* show results */
|
||
call values;
|
||
end;
|
||
else do;
|
||
if index = 1 then do; /* names */
|
||
if eoln then
|
||
call names;
|
||
else
|
||
call errors(1);
|
||
end;
|
||
else do;
|
||
if index = 2 then do; /* values */
|
||
if eoln then
|
||
call values;
|
||
else
|
||
call errors(1);
|
||
end;
|
||
else do;
|
||
call found$logical$device;
|
||
call names; /* show results */
|
||
call values;
|
||
end;
|
||
end;
|
||
end;
|
||
end parser;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
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;
|
||
phys$dev$table$adr = direct$bios(dev$table$adr$func);
|
||
if (tbuff(0) <> 0) and (phys$dev$table$adr = 0) then do;
|
||
buf$ptr = .tbuff(1);
|
||
call opt$scanner(.options(0),.options$offset(0),.index);
|
||
if ((index = 4) or (index = 11)) and (delimiter = 1) then do;
|
||
call parser;
|
||
call mon1(0,0);
|
||
end;
|
||
end;
|
||
if (phys$dev$table$adr = 0) then do;
|
||
call print$buf(.('Device Reassignment Not Supported$'));
|
||
call mon1(0,0);
|
||
end;
|
||
con$width = getscbbyte(console$width$offset);
|
||
con$page = getscbbyte(console$page$offset);
|
||
call move(120,phys$dev$table$adr,.phys$table(0));
|
||
if not input$found(.tbuff(1)) then do;
|
||
/* display names & values and prompt for the assignment */
|
||
call names;
|
||
call values;
|
||
call print$buf(.('Enter new assignment or hit RETURN $'));
|
||
/* can not use default dma; not always enough room for input */
|
||
call crlf;
|
||
no$chars = read$console$buf(.memory(0),255);
|
||
call crlf;
|
||
memory(1) = ' '; /* blank out nc field */
|
||
memory(no$chars+2) = 0; /* mark eoln */
|
||
if not input$found(.memory(1)) then /* no input, quit */
|
||
call mon1(0,0);
|
||
do i=1 to no$chars; /* convert input to caps */
|
||
memory(i+1) = ucase(memory(i+1));
|
||
end;
|
||
buf$length = no$chars;
|
||
end;
|
||
call parser;
|
||
call mon1(0,0);
|
||
end;
|
||
end device;
|
||
|