mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 16:34:07 +00:00
339 lines
8.4 KiB
Plaintext
339 lines
8.4 KiB
Plaintext
$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;
|