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;