mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-24 17:04:19 +00:00
Upload
Digital Research
This commit is contained in:
338
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/getdef.plm
Normal file
338
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/getdef.plm
Normal file
@@ -0,0 +1,338 @@
|
||||
$title('GENCPM Token File parser')
|
||||
get$sys$defaults:
|
||||
do;
|
||||
|
||||
/*
|
||||
Copyright (C) 1982
|
||||
Digital Research
|
||||
P.O. Box 579
|
||||
Pacific Grove, CA 93950
|
||||
*/
|
||||
|
||||
/*
|
||||
Revised:
|
||||
20 Sept 82 by Bruce Skidmore
|
||||
*/
|
||||
|
||||
declare true literally '0FFH';
|
||||
declare false literally '0';
|
||||
declare forever literally 'while true';
|
||||
declare boolean literally 'byte';
|
||||
declare cr literally '0dh';
|
||||
declare lf literally '0ah';
|
||||
declare tab literally '09h';
|
||||
|
||||
/*
|
||||
D a t a S t r u c t u r e s
|
||||
*/
|
||||
|
||||
declare data$fcb (36) byte external;
|
||||
|
||||
declare quest (156) boolean external;
|
||||
|
||||
declare display boolean external;
|
||||
|
||||
declare symbol (8) byte;
|
||||
|
||||
declare lnbfr (14) byte external;
|
||||
|
||||
declare buffer (128) byte at (.memory);
|
||||
|
||||
declare symtbl (20) structure(
|
||||
token(8) byte,
|
||||
len byte,
|
||||
flags byte,
|
||||
qptr byte,
|
||||
ptr address) external;
|
||||
|
||||
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;
|
||||
|
||||
/*
|
||||
B D O S P r o c e d u r e & F u n c t i o n C a l l s
|
||||
*/
|
||||
|
||||
system$reset:
|
||||
procedure external;
|
||||
end system$reset;
|
||||
|
||||
write$console:
|
||||
procedure (char) external;
|
||||
declare char byte;
|
||||
end write$console;
|
||||
|
||||
print$console$buffer:
|
||||
procedure (buffer$address) external;
|
||||
declare buffer$address address;
|
||||
end print$console$buffer;
|
||||
|
||||
open$file:
|
||||
procedure (fcb$address) byte external;
|
||||
declare fcb$address address;
|
||||
declare fcb based fcb$address (1) byte;
|
||||
end open$file;
|
||||
|
||||
close$file:
|
||||
procedure (fcb$address) external;
|
||||
declare fcb$address address;
|
||||
end close$file;
|
||||
|
||||
set$DMA$address:
|
||||
procedure (DMA$address) external;
|
||||
declare DMA$address address;
|
||||
end set$DMA$address;
|
||||
|
||||
crlf:
|
||||
procedure external;
|
||||
end crlf;
|
||||
|
||||
dsply$dec$adr:
|
||||
procedure (val) external;
|
||||
declare val address;
|
||||
end dsply$dec$adr;
|
||||
|
||||
/*
|
||||
M a i n G E T D E F P r o c e d u r e
|
||||
*/
|
||||
getdef:
|
||||
procedure public;
|
||||
|
||||
declare buffer$index byte;
|
||||
declare index byte;
|
||||
declare end$of$file byte;
|
||||
declare line$count address;
|
||||
|
||||
err:
|
||||
procedure(term$code,msg$adr);
|
||||
declare (term$code,save$display) byte;
|
||||
declare msg$adr address;
|
||||
|
||||
save$display = display;
|
||||
display = true;
|
||||
call print$console$buffer(.('ERROR: $'));
|
||||
call print$console$buffer(msg$adr);
|
||||
call print$console$buffer(.(' at line $'));
|
||||
call dsply$dec$adr(line$count);
|
||||
if term$code then
|
||||
call system$reset;
|
||||
call crlf;
|
||||
display = save$display;
|
||||
end err;
|
||||
|
||||
inc$ptr:
|
||||
procedure;
|
||||
|
||||
if buffer$index = 127 then
|
||||
do;
|
||||
buffer$index = 0;
|
||||
if mon2(20,.data$fcb) <> 0 then
|
||||
end$of$file = true;
|
||||
end;
|
||||
else
|
||||
buffer$index = buffer$index + 1;
|
||||
end inc$ptr;
|
||||
|
||||
get$char:
|
||||
procedure byte;
|
||||
declare char byte;
|
||||
|
||||
call inc$ptr;
|
||||
char = buffer(buffer$index);
|
||||
do while (char = ' ') or (char = tab) or (char = lf);
|
||||
if char = lf then
|
||||
line$count = line$count + 1;
|
||||
call inc$ptr;
|
||||
char = buffer(buffer$index);
|
||||
end;
|
||||
if (char >= 'a') and (char <= 'z') then
|
||||
char = char and 0101$1111b; /* force upper case */
|
||||
if char = 1ah then
|
||||
end$of$file = true;
|
||||
return char;
|
||||
end get$char;
|
||||
|
||||
get$sym:
|
||||
procedure;
|
||||
declare (i,sym$char) byte;
|
||||
declare got$sym boolean;
|
||||
|
||||
got$sym = false;
|
||||
do while (not got$sym) and (not end$of$file);
|
||||
do i = 0 to 7;
|
||||
symbol(i) = ' ';
|
||||
end;
|
||||
sym$char = get$char;
|
||||
i = 0;
|
||||
do while (i < 8) and (sym$char <> '=') and
|
||||
(sym$char <> cr) and (not end$of$file);
|
||||
symbol(i) = sym$char;
|
||||
sym$char = get$char;
|
||||
i = i + 1;
|
||||
end;
|
||||
do while (sym$char <> '=') and (sym$char <> cr) and (not end$of$file);
|
||||
sym$char = get$char;
|
||||
end;
|
||||
if not end$of$file then
|
||||
do;
|
||||
if (sym$char = '=') and (i > 0) then
|
||||
got$sym = true;
|
||||
else
|
||||
do;
|
||||
if (sym$char = '=') then
|
||||
call err(false,.('Missing parameter variable$'));
|
||||
else
|
||||
if i <> 0 then
|
||||
call err(false,.('Equals (=) delimiter missing$'));
|
||||
do while (sym$char <> cr) and (not end$of$file);
|
||||
sym$char = get$char;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end get$sym;
|
||||
|
||||
get$val:
|
||||
procedure;
|
||||
declare (flags,i,val$char) byte;
|
||||
declare val$adr address;
|
||||
declare val based val$adr byte;
|
||||
declare (base,inc,lnbfr$index) byte;
|
||||
|
||||
val$char = get$char;
|
||||
i = 0;
|
||||
do while (i < lnbfr(0)) and (val$char <> cr) and (not end$of$file);
|
||||
lnbfr(i+2) = val$char;
|
||||
i = i + 1;
|
||||
lnbfr(1) = i;
|
||||
val$char = get$char;
|
||||
end;
|
||||
do while (val$char <> cr) and (not end$of$file);
|
||||
val$char = get$char;
|
||||
end;
|
||||
inc = 0;
|
||||
lnbfr$index = 2;
|
||||
if i > 0 then
|
||||
do;
|
||||
val$adr = symtbl(index).ptr;
|
||||
flags = symtbl(index).flags;
|
||||
if (flags and 8) <> 0 then
|
||||
do;
|
||||
if (flags and 10h) <> 0 then
|
||||
inc = symbol(7) - 'A';
|
||||
else
|
||||
if (symbol(7) >= '0') and (symbol(7) <= '9') then
|
||||
inc = symbol(7) - '0';
|
||||
else
|
||||
inc = 10 + (symbol(7) - 'A');
|
||||
val$adr = val$adr + (inc * symtbl(index).len);
|
||||
end;
|
||||
if lnbfr(lnbfr$index) = '?' then
|
||||
do;
|
||||
quest(inc+symtbl(index).qptr) = true;
|
||||
display = true;
|
||||
lnbfr$index = lnbfr$index + 1;
|
||||
lnbfr(1) = lnbfr(1) - 1;
|
||||
end;
|
||||
if lnbfr(1) > 0 then
|
||||
do;
|
||||
if (flags and 1) <> 0 then
|
||||
do;
|
||||
if (lnbfr(lnbfr$index) >= 'A') and
|
||||
(lnbfr(lnbfr$index) <= 'P') then
|
||||
val = lnbfr(lnbfr$index) - 'A';
|
||||
else
|
||||
call err(false,.('Invalid drive ignored$'));
|
||||
end;
|
||||
else
|
||||
if (flags and 2) <> 0 then
|
||||
do;
|
||||
val = (lnbfr(lnbfr$index) = 'Y');
|
||||
end;
|
||||
else
|
||||
do;
|
||||
base = 16;
|
||||
val = 0;
|
||||
do i = 0 to lnbfr(1) - 1;
|
||||
val$char = lnbfr(i+lnbfr$index);
|
||||
if val$char = ',' then
|
||||
do;
|
||||
val$adr = val$adr + 1;
|
||||
val = 0;
|
||||
base = 16;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
if val$char = '#' then
|
||||
base = 10;
|
||||
else
|
||||
do;
|
||||
val$char = val$char - '0';
|
||||
if (base = 16) and (val$char > 9) then
|
||||
do;
|
||||
if val$char > 16 then
|
||||
val$char = val$char - 7;
|
||||
else
|
||||
val$char = 0ffh;
|
||||
end;
|
||||
if val$char < base then
|
||||
val = val * base + val$char;
|
||||
else
|
||||
call err(false,.('Invalid character$'));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end get$val;
|
||||
|
||||
compare$sym:
|
||||
procedure byte;
|
||||
declare (i,j) byte;
|
||||
declare found boolean;
|
||||
|
||||
found = false;
|
||||
i = 0;
|
||||
do while ((i < 22) and (not found));
|
||||
j = 0;
|
||||
do while ((j < 7) and (symtbl(i).token(j) = symbol(j)));
|
||||
j = j + 1;
|
||||
end;
|
||||
if j = 7 then
|
||||
found = true;
|
||||
else
|
||||
i = i + 1;
|
||||
end;
|
||||
if not found then
|
||||
return 0ffh;
|
||||
else
|
||||
return i;
|
||||
end compare$sym;
|
||||
|
||||
line$count = 1;
|
||||
call set$dma$address(.buffer);
|
||||
buffer$index = 127;
|
||||
end$of$file = false;
|
||||
do while (not end$of$file);
|
||||
call get$sym;
|
||||
if not end$of$file then
|
||||
do;
|
||||
index = compare$sym;
|
||||
if index <> 0ffh then
|
||||
call get$val;
|
||||
else
|
||||
call err(false,.('Invalid parameter variable$'));
|
||||
end;
|
||||
end;
|
||||
|
||||
end getdef;
|
||||
end get$sys$defaults;
|
||||
Reference in New Issue
Block a user