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;
|
|||
|
|
|