322 lines
11 KiB
Plaintext
322 lines
11 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>blokcopy 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;
|
||
|
||
declare
|
||
(tempsrc,tempdest) char(14) var,
|
||
(dest_space(37),src_space(37)) bit(8),
|
||
borrow bit(1),
|
||
ret_code fixed(7),
|
||
(actual,i,num_buffs) fixed(15),
|
||
(hi_word,lo_word,num_recs) bit(16),
|
||
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 & Destination FCBs */
|
||
/* The file I/O used later will require the full 4-byte random record field,
|
||
so we'll need the 37-byte FCB. The default FCBs will not be big enough,
|
||
hence the array of 37 bytes for space. */
|
||
srcfcb_ptr = addr(src_space);
|
||
destfcb_ptr = addr(dest_space);
|
||
|
||
/* set drives for both files to be default; OPEN will possibly change this */
|
||
source_file.drive = 0;
|
||
dest_file.drive = 0;
|
||
|
||
/* get the filenames from the command line */
|
||
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(addr(dest_file)) = -1 then do;
|
||
put skip list('No Directory Space');
|
||
call reboot();
|
||
end;
|
||
|
||
/************************************************************************
|
||
* Use Random Block Read & Write to read/write an exact number of bytes. *
|
||
* To simplify things, read in terms of a single byte record size. That *
|
||
* way, records read/written = bytes read/written. *
|
||
************************************************************************/
|
||
|
||
/* set the source file random record field */
|
||
call setrec(srcfcb_ptr);
|
||
|
||
/* set the source file record size to 1 byte */
|
||
source_file.record_size = '0001'b4;
|
||
|
||
/* get both words of source file size (in bytes) */
|
||
lo_word = source_file.file_size(1);
|
||
hi_word = source_file.file_size(2);
|
||
|
||
/* set the DMA address */
|
||
call setdma(addr(memory(0)));
|
||
|
||
/* READ-- if file size > 64k, read it in FE00h-byte chunks */
|
||
do while(hi_word ^= '0000'b4);
|
||
num_recs = 'FE00'b4; /* number of bytes to read */
|
||
call blockrd(addr(source_file),num_recs,addr(actual),addr(ret_code));
|
||
if ret_code ^= 0 then do;
|
||
put skip list('ERROR: Source file > 64k. BLOCKRD returned ',
|
||
ret_code);
|
||
call reboot();
|
||
end;
|
||
borrow = less_than(lo_word,num_recs);
|
||
lo_word = sub(lo_word,num_recs);
|
||
if borrow then hi_word = sub(hi_word,'0001'b4);
|
||
end;
|
||
/* read the less-than-64k chunk */
|
||
call blockrd(addr(source_file),lo_word,addr(actual),addr(ret_code));
|
||
if ret_code ^= 0 then do;
|
||
put skip list('ERROR: BLOCKRD returned ',ret_code);
|
||
call reboot();
|
||
end;
|
||
|
||
/* now reverse the above process to write to the destination file */
|
||
|
||
/* set the destination file random record field */
|
||
call setrec(addr(dest_file));
|
||
|
||
/* set the destination file record size to 1 byte */
|
||
dest_file.record_size = '0001'b4;
|
||
|
||
/* get source file size (in bytes) so we know how much to write */
|
||
lo_word = source_file.file_size(1);
|
||
hi_word = source_file.file_size(2);
|
||
|
||
/* WRITE-- if file size > 64k, write it in FE00h-byte chunks */
|
||
do while(hi_word ^= '0000'b4);
|
||
num_recs = 'FE00'b4; /* number of bytes to write */
|
||
call blockwr(addr(dest_file),num_recs,addr(actual),addr(ret_code));
|
||
if ret_code ^= 0 then do;
|
||
put skip list('ERROR: Source file > 64k. BLOCKWR returned ',
|
||
ret_code);
|
||
call reboot();
|
||
end;
|
||
borrow = less_than(lo_word,num_recs);
|
||
lo_word = sub(lo_word,num_recs);
|
||
if borrow then hi_word = sub(hi_word,'0001'b4);
|
||
end;
|
||
/* write the less-than-64k chunk */
|
||
call blockwr(addr(dest_file),lo_word,addr(actual),addr(ret_code));
|
||
if ret_code ^= 0 then do;
|
||
put skip list('ERROR: BLOCKRD returned ',ret_code);
|
||
call reboot();
|
||
end;
|
||
|
||
/* close destination file */
|
||
if close(addr(dest_file)) = -1 then do;
|
||
put skip list('Disk is Read Only');
|
||
call reboot();
|
||
end;
|
||
|
||
/* all done! */
|
||
put skip list('File Copied');
|
||
call reboot();
|
||
|
||
/****************************************************************************/
|
||
/* P r o c e d u r 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 following 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 P r o c e d u r e s */
|
||
/*****************************************************************************/
|
||
complement: procedure((x)) returns(bit(16));
|
||
/* two's complement */
|
||
declare
|
||
x bit(16);
|
||
x = xor(x,'FFFF'b4);
|
||
x = add(x,'0001'b4);
|
||
return(x);
|
||
end;
|
||
|
||
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;
|
||
|
||
sub: /* unsigned substract */
|
||
procedure((x),(y)) returns(bit(16));
|
||
declare
|
||
(x,y) bit(16);
|
||
return(add(x,complement(y)));
|
||
end sub;
|
||
|
||
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;
|
||
|
||
less_than: procedure((x),(y)) returns(bit(1));
|
||
/* returns '1'b if x < y, '0'b otherwise */
|
||
/* 3 possibilities:
|
||
1. hi order bit of x = 1; hi order bit of y = 0 ==> '0'b
|
||
2. hi order bit of x = 0; hi order bit of y = 1 ==> '1'b
|
||
3. hi order bit of x = hi order bit of y.
|
||
In this case, set the hi order bit to 0 and compare x
|
||
and y as fixed bin(15) numbers. */
|
||
declare
|
||
(x,y) bit(16),
|
||
(xptr,yptr) pointer,
|
||
xval fixed bin(15) based(xptr),
|
||
yval fixed bin(15) based(yptr);
|
||
xptr = addr(x);
|
||
yptr = addr(y);
|
||
/* case 1: */
|
||
if substr(x,1,1) & ^(substr(y,1,1)) then return('0'b);
|
||
/* case 2: */
|
||
if ^(substr(x,1,1)) & substr(y,1,1) then return('1'b);
|
||
/* case 3: */
|
||
substr(x,1,1) = '0'b;
|
||
substr(y,1,1) = '0'b;
|
||
if xval < yval then return('1'b);
|
||
else return('0'b);
|
||
end less_than;
|
||
|
||
end diocopy;
|
||
|