254 lines
8.5 KiB
Plaintext
254 lines
8.5 KiB
Plaintext
|
diocopy: procedure options(main);
|
|||
|
|
|
|||
|
|
/*****************************************************************************
|
|||
|
|
* *
|
|||
|
|
* I B M D O S D i r e c t F u n c t i o n C a l l s *
|
|||
|
|
* *
|
|||
|
|
******************************************************************************
|
|||
|
|
******************************************************************************
|
|||
|
|
* *
|
|||
|
|
* This program tests many of the IBM DOS direct function calls. The tests *
|
|||
|
|
* are not particularly complicated, but they do serve as examples for using *
|
|||
|
|
* direct DOS function calls from PL/I-86. *
|
|||
|
|
* *
|
|||
|
|
******************************************************************************
|
|||
|
|
* *
|
|||
|
|
* NOTE! YOU SHOULD STUDY THE IBM DOS DOCUMENTATION FOR MORE COMPLETE *
|
|||
|
|
* INFORMATION BEFORE USING ANY OF THESE FUNCTIONS IN YOUR PROGRAMS. *
|
|||
|
|
* *
|
|||
|
|
* *
|
|||
|
|
******************************************************************************
|
|||
|
|
* To use this program, enter the command: *
|
|||
|
|
* *
|
|||
|
|
* A>rndcopy filename.typ newname.typ *
|
|||
|
|
*****************************************************************************/
|
|||
|
|
|
|||
|
|
/* DIOMOD.DCL contains the declarations for the DOS functions */
|
|||
|
|
%include 'diomod.dcl';
|
|||
|
|
|
|||
|
|
%replace
|
|||
|
|
true by '1'b,
|
|||
|
|
false by '0'b,
|
|||
|
|
buffer_size by 64; /* word size of 128 byte buffer */
|
|||
|
|
|
|||
|
|
declare
|
|||
|
|
(tempsrc,tempdest) char(14) var,
|
|||
|
|
d_space(37) bit(8),
|
|||
|
|
eofile bit(1),
|
|||
|
|
ret_code fixed(7),
|
|||
|
|
(i,m,num_buffs) fixed(15),
|
|||
|
|
memory (0:0) bit(16) based(memptr());
|
|||
|
|
|
|||
|
|
declare /* source file FCB */
|
|||
|
|
srcfcb_ptr ptr,
|
|||
|
|
1 source_file based(srcfcb_ptr),
|
|||
|
|
2 drive fixed(7),
|
|||
|
|
2 name character(8),
|
|||
|
|
2 type character(3),
|
|||
|
|
2 current_block bit(16),
|
|||
|
|
2 record_size bit(16),
|
|||
|
|
2 file_size(2) bit(16),
|
|||
|
|
2 date bit(16),
|
|||
|
|
2 reserved(10) bit(8),
|
|||
|
|
2 current_rec bit(8),
|
|||
|
|
2 rand_rec_no(2) bit(16);
|
|||
|
|
|
|||
|
|
declare /* destination file FCB */
|
|||
|
|
destfcb_ptr pointer,
|
|||
|
|
1 dest_file based(destfcb_ptr),
|
|||
|
|
2 drive fixed(7),
|
|||
|
|
2 name character(8),
|
|||
|
|
2 type character(3),
|
|||
|
|
2 current_block bit(16),
|
|||
|
|
2 record_size bit(16),
|
|||
|
|
2 file_size(2) bit(16),
|
|||
|
|
2 date bit(16),
|
|||
|
|
2 reserved(10) bit(8),
|
|||
|
|
2 current_rec bit(8),
|
|||
|
|
2 rand_rec_no(2) bit(16);
|
|||
|
|
|
|||
|
|
/****************************************************************************/
|
|||
|
|
/* M a i n P r o g r a m */
|
|||
|
|
/****************************************************************************/
|
|||
|
|
|
|||
|
|
/* initialize source file FCB */
|
|||
|
|
srcfcb_ptr = dfcb0();
|
|||
|
|
destfcb_ptr = addr(d_space); /* set up destination FCB out in memory */
|
|||
|
|
|
|||
|
|
/* set drives to be default; may be changed by OPEN */
|
|||
|
|
source_file.drive = 0;
|
|||
|
|
dest_file.drive = 0;
|
|||
|
|
|
|||
|
|
/* get the file names */
|
|||
|
|
call get_names(tempsrc,tempdest);
|
|||
|
|
|
|||
|
|
/* split up name & type; make sure they're the right length, padded with
|
|||
|
|
trailing blanks if necessary */
|
|||
|
|
i = index(tempsrc,'.');
|
|||
|
|
source_file.name = substr(tempsrc,1,i-1) || ' ';
|
|||
|
|
source_file.name = substr(source_file.name,1,8);
|
|||
|
|
source_file.type = substr(tempsrc,i+1) || ' ';
|
|||
|
|
source_file.type = substr(source_file.type,1,3);
|
|||
|
|
/* do the same for the destination name */
|
|||
|
|
i = index(tempdest,'.');
|
|||
|
|
|
|||
|
|
/* the following PUT EDIT statements are needed to make the register
|
|||
|
|
allocator work right */
|
|||
|
|
|
|||
|
|
PUT SKIP EDIT('1.DEST_FILE.NAME=',DEST_FILE.NAME,'<--') (A,A,A);
|
|||
|
|
dest_file.name = substr(tempdest,1,i-1) || ' ';
|
|||
|
|
PUT SKIP EDIT('2.DEST_FILE.NAME=',DEST_FILE.NAME,'<--') (A,A,A);
|
|||
|
|
dest_file.name = substr(dest_file.name,1,8);
|
|||
|
|
PUT SKIP EDIT('3.DEST_FILE.NAME=',DEST_FILE.NAME,'<--') (A,A,A);
|
|||
|
|
dest_file.type = substr(tempdest,i+1,3) || ' ';
|
|||
|
|
PUT SKIP EDIT('1.DEST_FILE.TYPE=',DEST_FILE.TYPE,'<--') (A,A,A);
|
|||
|
|
dest_file.type = substr(dest_file.type,1,3);
|
|||
|
|
PUT SKIP EDIT('2.DEST_FILE.TYPE=',DEST_FILE.TYPE,'<--') (A,A,A);
|
|||
|
|
|
|||
|
|
/* open the source file, if possible */
|
|||
|
|
if open(addr(source_file)) = -1 then do;
|
|||
|
|
put skip list('No Source File');
|
|||
|
|
call reboot();
|
|||
|
|
end;
|
|||
|
|
|
|||
|
|
/* create the destination file */
|
|||
|
|
if make(destfcb_ptr) = -1 then do;
|
|||
|
|
put skip list('No Directory Space');
|
|||
|
|
call reboot();
|
|||
|
|
end;
|
|||
|
|
|
|||
|
|
/* figure out how many buffers to use */
|
|||
|
|
num_buffs = divide(memwds(),buffer_size,15);
|
|||
|
|
if num_buffs = 0 then do;
|
|||
|
|
put skip list('No Memory Available for Buffer Space');
|
|||
|
|
call reboot();
|
|||
|
|
end;
|
|||
|
|
|
|||
|
|
/* now do the read */
|
|||
|
|
eofile = false;
|
|||
|
|
do while (^eofile);
|
|||
|
|
m = 0;
|
|||
|
|
/* fill buffers */
|
|||
|
|
do i = 0 repeat (i+1) while(i < num_buffs);
|
|||
|
|
call setdma(addr(memory(m)));
|
|||
|
|
m = m + buffer_size;
|
|||
|
|
if rdran(addr(source_file)) ^= 0 then do;
|
|||
|
|
eofile = true;
|
|||
|
|
/* truncate buffer */
|
|||
|
|
num_buffs = i;
|
|||
|
|
end;
|
|||
|
|
/* increment the random record field */
|
|||
|
|
if source_file.rand_rec_no(1) = 'FFFF'b4 then do;
|
|||
|
|
source_file.rand_rec_no(2) =
|
|||
|
|
add(source_file.rand_rec_no(2),'0001'b4);
|
|||
|
|
source_file.rand_rec_no(1) = '0000'b4;
|
|||
|
|
end;
|
|||
|
|
source_file.rand_rec_no(1) =
|
|||
|
|
add(source_file.rand_rec_no(1),'0001'b4);
|
|||
|
|
end;
|
|||
|
|
m = 0;
|
|||
|
|
/* write buffers */
|
|||
|
|
do i = 0 to num_buffs - 1;
|
|||
|
|
call setdma(addr(memory(m)));
|
|||
|
|
m = m + buffer_size;
|
|||
|
|
if wrran(destfcb_ptr) ^= 0 then do;
|
|||
|
|
put skip list('Disk Full');
|
|||
|
|
call reboot();
|
|||
|
|
end;
|
|||
|
|
/* increment the random record field */
|
|||
|
|
if dest_file.rand_rec_no(1) = 'FFFF'b4 then do;
|
|||
|
|
dest_file.rand_rec_no(2) =
|
|||
|
|
add(dest_file.rand_rec_no(2),'0001'b4);
|
|||
|
|
dest_file.rand_rec_no(1) = '0000'b4;
|
|||
|
|
end;
|
|||
|
|
dest_file.rand_rec_no(1) =
|
|||
|
|
add(dest_file.rand_rec_no(1),'0001'b4);
|
|||
|
|
end;
|
|||
|
|
end;
|
|||
|
|
|
|||
|
|
/* close destination file */
|
|||
|
|
if close(destfcb_ptr) = -1 then do;
|
|||
|
|
put skip list('Disk is Read Only');
|
|||
|
|
call reboot();
|
|||
|
|
end;
|
|||
|
|
|
|||
|
|
/* all done! */
|
|||
|
|
put skip list('File Copied');
|
|||
|
|
call reboot();
|
|||
|
|
|
|||
|
|
/****************************************************************************/
|
|||
|
|
/* S u b r o u t i n e s */
|
|||
|
|
/****************************************************************************/
|
|||
|
|
get_names: procedure(src,dest);
|
|||
|
|
/* get the filenames from the command line */
|
|||
|
|
declare
|
|||
|
|
(src,dest) char(14) var, /* file names */
|
|||
|
|
buffptr pointer,
|
|||
|
|
cmdline char(127) var based(buffptr),
|
|||
|
|
indx fixed;
|
|||
|
|
buffptr = dbuff();
|
|||
|
|
/* delete any leading blanks */
|
|||
|
|
do while(substr(cmdline,1,1) = ' ');
|
|||
|
|
cmdline = substr(cmdline,2);
|
|||
|
|
end;
|
|||
|
|
/* find the break between the two filenames */
|
|||
|
|
indx = index(cmdline,' ');
|
|||
|
|
|
|||
|
|
/* the next statement is needed to make the register allocator work
|
|||
|
|
right */
|
|||
|
|
|
|||
|
|
PUT SKIP LIST('INDX=',INDX);
|
|||
|
|
/* get the source filename */
|
|||
|
|
src = substr(cmdline,1,indx-1);
|
|||
|
|
cmdline = substr(cmdline,indx+1);
|
|||
|
|
/* delete any intervening blanks */
|
|||
|
|
do while(substr(cmdline,1,1) = ' ');
|
|||
|
|
cmdline = substr(cmdline,2);
|
|||
|
|
end;
|
|||
|
|
/* put the rest of the command line in destination filename */
|
|||
|
|
dest = substr(cmdline,1,14);
|
|||
|
|
end get_names;
|
|||
|
|
|
|||
|
|
/****************************************************************************/
|
|||
|
|
/* U n s i g n e d A r i t h m e t i c F u n c t i o n s */
|
|||
|
|
/****************************************************************************/
|
|||
|
|
add: procedure((x),(y)) returns(bit(16));
|
|||
|
|
/* 16 bit unsigned add */
|
|||
|
|
declare
|
|||
|
|
(x,y,z) bit(16),
|
|||
|
|
(xp,yp,zp) ptr,
|
|||
|
|
su bit(16),
|
|||
|
|
sv bit(16),
|
|||
|
|
sw bit(16),
|
|||
|
|
u fixed bin(15) based(xp),
|
|||
|
|
v fixed bin(15) based(yp),
|
|||
|
|
w fixed bin(15) based(zp);
|
|||
|
|
xp = addr(x);
|
|||
|
|
yp = addr(y);
|
|||
|
|
zp = addr(z);
|
|||
|
|
/* get sign bits of u and v */
|
|||
|
|
su = x & '8000'b4;
|
|||
|
|
sv = y & '8000'b4;
|
|||
|
|
/* zero sign bits of x and y */
|
|||
|
|
x = x & '7FFF'b4;
|
|||
|
|
y = y & '7FFF'b4;
|
|||
|
|
w = u + v;
|
|||
|
|
sw = z & '8000'b4;
|
|||
|
|
/* get sign bit of z */
|
|||
|
|
z = z & '7FFF'b4;
|
|||
|
|
/* XOR of su, sv, sw */
|
|||
|
|
sw = xor(xor(su,sv),sw);
|
|||
|
|
/* put in sign bit of z */
|
|||
|
|
z = z | sw;
|
|||
|
|
return(z);
|
|||
|
|
end add;
|
|||
|
|
|
|||
|
|
xor: procedure(x,y) returns(bit(16));
|
|||
|
|
/* 16 bit logical exclusive or */
|
|||
|
|
declare
|
|||
|
|
(x,y) bit(16);
|
|||
|
|
return(bool(x,y,'0110'b));
|
|||
|
|
end xor;
|
|||
|
|
|
|||
|
|
end diocopy;
|
|||
|
|
|