mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-27 10:24:19 +00:00
385 lines
9.4 KiB
Plaintext
385 lines
9.4 KiB
Plaintext
$title('File Concatenation')
|
||
concat:
|
||
do;
|
||
|
||
$include (copyrt.lit)
|
||
|
||
declare true literally '0FFFFH';
|
||
declare false literally '0';
|
||
declare forever literally 'while true';
|
||
declare boolean literally 'byte';
|
||
|
||
declare start label;
|
||
declare jmp$to$start structure (
|
||
jmp$instr byte,
|
||
jmp$location address ) data (
|
||
0C3H,
|
||
.start-3);
|
||
|
||
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;
|
||
|
||
declare fcb (1) byte external;
|
||
declare fcb16 (1) byte external;
|
||
declare tbuff (1) byte external;
|
||
|
||
/**************************************
|
||
* *
|
||
* B D O S Externals *
|
||
* *
|
||
**************************************/
|
||
|
||
system$reset:
|
||
procedure;
|
||
call mon1 (0,0);
|
||
end system$reset;
|
||
|
||
read$console:
|
||
procedure byte;
|
||
return mon2 (1,0);
|
||
end read$console;
|
||
|
||
write$console:
|
||
procedure (char);
|
||
declare char byte;
|
||
call mon1 (2,char);
|
||
end write$console;
|
||
|
||
print$console$buffer:
|
||
procedure (buffer$address);
|
||
declare buffer$address address;
|
||
call mon1 (9,buffer$address);
|
||
end print$console$buffer;
|
||
|
||
open$file:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (15,fcb$address);
|
||
end open$file;
|
||
|
||
close$file:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (16,fcb$address);
|
||
end close$file;
|
||
|
||
delete$file:
|
||
procedure (fcb$address);
|
||
declare fcb$address address;
|
||
call mon1 (19,fcb$address);
|
||
end delete$file;
|
||
|
||
read$record:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (20,fcb$address);
|
||
end read$record;
|
||
|
||
write$record:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (21,fcb$address);
|
||
end write$record;
|
||
|
||
create$file:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (22,fcb$address);
|
||
end create$file;
|
||
|
||
set$DMA$address:
|
||
procedure (DMA$address);
|
||
declare DMA$address address;
|
||
call mon1 (26,DMA$address);
|
||
end set$DMA$address;
|
||
|
||
crlf:
|
||
procedure;
|
||
call write$console (0dh);
|
||
call write$console (0ah);
|
||
end crlf;
|
||
|
||
|
||
parse:
|
||
procedure (pcb$adr) address;
|
||
declare pcb$adr address;
|
||
declare pcb based pcb$adr structure (
|
||
filename$adr address,
|
||
fcb$adr address );
|
||
declare pcb$filename$adr address;
|
||
declare pcb$fcb$adr address;
|
||
declare filename based pcb$filename$adr (1) byte;
|
||
declare fcb based pcb$fcb$adr (1) byte;
|
||
|
||
declare
|
||
/* return conditions */
|
||
endline literally '00000H',
|
||
badfile literally '0FFFFH',
|
||
/* useful literals */
|
||
disk literally 'fcb(0)',
|
||
fcbname literally '8', /* end of name */
|
||
fcbtype literally '11', /* end of type field */
|
||
fcbsize literally '16'; /* partial size of fcb */
|
||
|
||
declare char byte; /* global temp for current char */
|
||
declare fnp byte; /* index into file name buffer */
|
||
declare fnlen byte;
|
||
|
||
gnctran:
|
||
procedure(b) byte;
|
||
declare b byte;
|
||
|
||
if b < ' ' then return 0dh; /* all non-graphics */
|
||
/* translate alpha to upper case */
|
||
if b >= 'a' and b <= 'z' then
|
||
b = b and 101$1111b; /* upper case */
|
||
return b;
|
||
end gnctran;
|
||
|
||
gnc:
|
||
procedure;
|
||
|
||
char = gnctran(filename(fnp := fnp + 1));
|
||
end gnc;
|
||
|
||
delimiter:
|
||
procedure byte;
|
||
declare i byte;
|
||
declare del(*) byte data
|
||
(0dh,' =.:<>_[],');
|
||
|
||
do i = 0 to last(del);
|
||
if char = del(i) then return true;
|
||
end;
|
||
return false;
|
||
end delimiter;
|
||
|
||
putchar:
|
||
procedure;
|
||
|
||
fcb(fnlen:=fnlen+1) = char;
|
||
/* can check here for ambig ref's "char = '?'" */
|
||
end putchar;
|
||
|
||
fillq:
|
||
procedure(len);
|
||
/* fill current name or type with question marks */
|
||
|
||
declare len byte;
|
||
|
||
char = '?'; /* question mark */
|
||
do while fnlen < len;
|
||
call putchar;
|
||
end;
|
||
end fillq;
|
||
|
||
/* initialize local bases */
|
||
pcb$filename$adr = pcb.filename$adr;
|
||
pcb$fcb$adr = pcb.fcb$adr;
|
||
/* initialize file control block to empty */
|
||
char = ' ';
|
||
fnlen = 0;
|
||
fnp = -1;
|
||
do while fnlen < fcbsize-1;
|
||
if fnlen = fcbtype then char = 0;
|
||
call putchar;
|
||
end;
|
||
disk = 0;
|
||
/* scan next name */
|
||
do forever;
|
||
/* deblank command buffer */
|
||
call gnc;
|
||
do while char = ' ';
|
||
call gnc;
|
||
end;
|
||
if delimiter then return badfile;
|
||
fnlen = 0;
|
||
do while not delimiter;
|
||
if fnlen >= fcbname then /* error, file name too long */
|
||
return badfile;
|
||
if char = '*' then call fillq(fcbname); else call putchar;
|
||
call gnc;
|
||
end;
|
||
|
||
/* check for disk name */
|
||
if char = ':' then
|
||
do;
|
||
if not (disk = 0 and fnlen = 1) then
|
||
return badfile;
|
||
/* must be a disk name */
|
||
if (disk := fcb(1) - 'A' + 1) > 26
|
||
/* invalid disk name */
|
||
then return badfile;
|
||
/* valid disk name replace space in name */
|
||
else fcb(fnlen) = ' ';
|
||
end;
|
||
else
|
||
do;
|
||
/* char is not ':', so file name is set. scan remainder */
|
||
/* at least one char scanned */
|
||
fnlen = fcbname;
|
||
if char = '.' then /* scan file type */
|
||
do;
|
||
call gnc;
|
||
do while not delimiter;
|
||
if fnlen >= fcbtype then
|
||
/* error, type field too long */
|
||
return badfile;
|
||
if char = '*'
|
||
then call fillq(fcbtype);
|
||
else call putchar;
|
||
call gnc;
|
||
end;
|
||
end;
|
||
|
||
if char = 0dh
|
||
then return endline;
|
||
else return .filename(fnp);
|
||
end;
|
||
end; /* of forever */
|
||
end parse;
|
||
|
||
declare pcb structure (
|
||
filename$adr address,
|
||
fcb$adr address );
|
||
declare nxt$chr$adr address;
|
||
declare old$nxt$chr$adr address at (.pcb.filename$adr);
|
||
declare char byte;
|
||
declare ret byte at (.char);
|
||
declare delim based nxt$chr$adr byte;
|
||
declare fcbin (33) byte;
|
||
declare fcbout (33) byte initial (
|
||
0,' ',' ',0,0,0,0,0,0,0,0,
|
||
0,0,0,0,0,0,0,0,0,0,0,0,0);
|
||
declare default$fcb (33) byte data (
|
||
0,' ',' ',0,0,0,0,0,0,0,0,
|
||
0,0,0,0,0,0,0,0,0,0,0,0,0);
|
||
declare nmb$sect literally '32';
|
||
declare buffer (nmb$sect) structure (
|
||
record (128) byte);
|
||
|
||
|
||
setup$output$file:
|
||
procedure;
|
||
pcb.filename$adr = .tbuff(1);
|
||
pcb.fcb$adr = .fcbout;
|
||
nxt$chr$adr = parse (.pcb);
|
||
if delim <> '=' then
|
||
do;
|
||
if nxt$chr$adr = 0 then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'No input files specified','$'));
|
||
go to error;
|
||
end;
|
||
if nxt$chr$adr = 0ffffh then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'Bad output file name','$'));
|
||
go to error;
|
||
end;
|
||
call print$console$buffer (.(
|
||
'A ''='' delimeter expected after output file name','$'));
|
||
go to error;
|
||
end;
|
||
call set$DMA$address (.buffer);
|
||
if open$file (.fcbout) <> 255 then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'Destination file exists, delete (Y/N) ? ','$'));
|
||
char = read$console;
|
||
if (char <> 'y') and (char <> 'Y')
|
||
then call system$reset;
|
||
call crlf;
|
||
call delete$file (.fcbout);
|
||
end;
|
||
if create$file (.fcbout) = 255 then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'Directory full','$'));
|
||
call system$reset;
|
||
end;
|
||
end setup$output$file;
|
||
|
||
setup$input$file:
|
||
procedure;
|
||
pcb.filename$adr = nxt$chr$adr + 1;
|
||
pcb.fcb$adr = .fcbin;
|
||
call move (33,.default$fcb,.fcbin);
|
||
if (nxt$chr$adr := parse (.pcb)) = 0ffffh then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'Bad input file name','$'));
|
||
go to error;
|
||
end;
|
||
call set$DMA$address (.buffer);
|
||
if open$file (.fcbin) = 255 then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'No such input file','$'));
|
||
go to error;
|
||
end;
|
||
end setup$input$file;
|
||
|
||
copy$file:
|
||
procedure;
|
||
declare (i,cnt) byte;
|
||
declare (ok,more$input) boolean;
|
||
|
||
more$input = true;
|
||
do while more$input;
|
||
cnt = 0;
|
||
ok = true;
|
||
do while ok;
|
||
call set$DMA$address (.buffer((cnt := cnt+1)-1));
|
||
ok = (read$record (.fcbin) = 0) and
|
||
(cnt <> nmb$sect);
|
||
end;
|
||
if (more$input := (cnt = nmb$sect))
|
||
then cnt = cnt - 1;
|
||
else cnt = cnt - 2;
|
||
do i = 0 to cnt;
|
||
call set$DMA$address (.buffer(i));
|
||
if write$record (.fcbout) <> 0 then
|
||
do;
|
||
call print$console$buffer (.(
|
||
'Disk write error','$'));
|
||
call system$reset;
|
||
end;
|
||
end;
|
||
end;
|
||
end copy$file;
|
||
|
||
/*
|
||
F i l e C o n c a t e n a t i o n
|
||
*/
|
||
|
||
start:
|
||
call setup$output$file;
|
||
do forever;
|
||
call setup$input$file;
|
||
call copy$file;
|
||
if nxt$chr$adr = 0 then
|
||
do;
|
||
ret = close$file (.fcbout);
|
||
call system$reset;
|
||
end;
|
||
end;
|
||
|
||
error:
|
||
call crlf;
|
||
tbuff(tbuff(0)+1) = '$';
|
||
call print$console$buffer (old$nxt$chr$adr);
|
||
call system$reset;
|
||
|
||
end concat;
|
||
|