digital research pl/i-86 v1.0
This commit is contained in:
parent
349e15087f
commit
643f795c5a
6
Digital Research PLI-86 v1/A.PLI
Normal file
6
Digital Research PLI-86 v1/A.PLI
Normal file
@ -0,0 +1,6 @@
|
||||
a:
|
||||
procedure(x) returns (float); /* external procedure */
|
||||
declare x float;
|
||||
return (x/2);
|
||||
end a;
|
||||
|
34
Digital Research PLI-86 v1/ACK.PLI
Normal file
34
Digital Research PLI-86 v1/ACK.PLI
Normal file
@ -0,0 +1,34 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates the Ackermann function */
|
||||
/* A(m,n), and increases the size of the stack */
|
||||
/* because of the large number of recursive calls. */
|
||||
/******************************************************/
|
||||
ack:
|
||||
procedure options(main,stack(2000));
|
||||
declare
|
||||
(m,maxm,n,maxn) fixed;
|
||||
put skip list('Type max m,n: ');
|
||||
get list(maxm,maxn);
|
||||
put skip
|
||||
list(' ',(decimal(n,4) do n=0 to maxn));
|
||||
do m = 0 to maxm;
|
||||
put skip list(decimal(m,4),':');
|
||||
do n = 0 to maxn;
|
||||
put list(decimal(ackermann(m,n),4));
|
||||
end;
|
||||
end;
|
||||
stop;
|
||||
|
||||
ackermann:
|
||||
procedure(m,n) returns(fixed) recursive;
|
||||
declare (m,n) fixed;
|
||||
if m = 0 then
|
||||
return(n+1);
|
||||
if n = 0 then
|
||||
return(ackermann(m-1,1));
|
||||
return(ackermann(m-1,ackermann(m,n-1)));
|
||||
end ackermann;
|
||||
|
||||
end ack;
|
||||
|
||||
|
45
Digital Research PLI-86 v1/ACKTST.PLI
Normal file
45
Digital Research PLI-86 v1/ACKTST.PLI
Normal file
@ -0,0 +1,45 @@
|
||||
/************************************************/
|
||||
/* This program tests the STKSIZ function while */
|
||||
/* evaluating a RECURSIVE procedure. */
|
||||
/************************************************/
|
||||
ack:
|
||||
procedure options(main,stack(2000));
|
||||
declare
|
||||
(m,n) fixed,
|
||||
(maxm,maxn) fixed,
|
||||
ncalls decimal(6),
|
||||
(curstack, stacksize) fixed,
|
||||
stksiz entry returns(fixed);
|
||||
|
||||
put skip list('Type max m,n: ');
|
||||
get list(maxm,maxn);
|
||||
do m = 0 to maxm;
|
||||
do n = 0 to maxn;
|
||||
ncalls = 0;
|
||||
curstack = 0;
|
||||
stacksize = 0;
|
||||
put edit('Ack(',m,',',n,')=',ackermann(m,n),
|
||||
ncalls,' Calls,',stacksize,' Stack Bytes')
|
||||
(skip,a,2(f(2),a),f(6),f(7),a,f(4),a);
|
||||
end;
|
||||
end;
|
||||
stop;
|
||||
|
||||
ackermann:
|
||||
procedure(m,n) returns(fixed) recursive;
|
||||
|
||||
declare
|
||||
(m,n) fixed;
|
||||
ncalls = ncalls + 1;
|
||||
curstack = stksiz();
|
||||
if curstack > stacksize then
|
||||
stacksize = curstack;
|
||||
if m = 0 then
|
||||
return(n+1);
|
||||
if n = 0 then
|
||||
return(ackermann(m-1,1));
|
||||
return(ackermann(m-1,ackermann(m,n-1)));
|
||||
end ackermann;
|
||||
|
||||
end ack;
|
||||
|
35
Digital Research PLI-86 v1/ALLTST.PLI
Normal file
35
Digital Research PLI-86 v1/ALLTST.PLI
Normal file
@ -0,0 +1,35 @@
|
||||
/*****************************************************/
|
||||
/* This program tests the TOTWDS, MAXWDS, and ALLWDS */
|
||||
/* functions from the Run-time Subroutine Library. */
|
||||
/*****************************************************/
|
||||
alltst:
|
||||
procedure options(main);
|
||||
declare
|
||||
totwds returns(fixed(15)),
|
||||
maxwds returns(fixed(15)),
|
||||
allwds entry(fixed(15)) returns(pointer);
|
||||
|
||||
declare
|
||||
allreq fixed(15),
|
||||
memptr ptr,
|
||||
meminx fixed(15),
|
||||
memory (0:0) bit(16) based(memptr);
|
||||
|
||||
do while('1'b);
|
||||
put edit (totwds(),' Total Words Available',
|
||||
maxwds(),' Maximum Segment Size',
|
||||
'Allocation Size? ') (2(skip,f(6),a),skip,a);
|
||||
get list(allreq);
|
||||
memptr = allwds(allreq);
|
||||
put edit('Allocated',allreq,' Words at ',unspec(memptr))
|
||||
(skip,a,f(6),a,b4);
|
||||
|
||||
/* clear memory as example */
|
||||
do meminx = 0 to allreq-1;
|
||||
memory(meminx) = '0000'b4;
|
||||
end;
|
||||
end;
|
||||
|
||||
end alltst;
|
||||
|
||||
|
83
Digital Research PLI-86 v1/ANNUITY.PLI
Normal file
83
Digital Research PLI-86 v1/ANNUITY.PLI
Normal file
@ -0,0 +1,83 @@
|
||||
/******************************************************/
|
||||
/* This program computes either the present value(PV),*/
|
||||
/* the payment(PMT), or the number of periods in an */
|
||||
/* annuity. */
|
||||
/******************************************************/
|
||||
annuity:
|
||||
procedure options(main);
|
||||
%replace
|
||||
clear by '^z',
|
||||
true by '1'b;
|
||||
declare
|
||||
PMT fixed decimal(7,2),
|
||||
PV fixed decimal(9,2),
|
||||
IP fixed decimal(6,6),
|
||||
x float binary,
|
||||
yi float binary,
|
||||
i float binary,
|
||||
n fixed;
|
||||
|
||||
declare
|
||||
ftc entry(float binary(24))
|
||||
returns(character(17) varying);
|
||||
|
||||
put list (clear,'^i^iO R D I N A R Y A N N U I T Y');
|
||||
put skip(2) list
|
||||
('^iEnter Known Values, or 0, on Each Iteration');
|
||||
|
||||
on error
|
||||
begin;
|
||||
put skip list('^iInvalid Data, Re-enter');
|
||||
goto retry;
|
||||
end;
|
||||
|
||||
retry:
|
||||
do while (true);
|
||||
put skip(3) list('^iPresent Value ');
|
||||
get list(PV);
|
||||
put list('^iPayment ');
|
||||
get list(PMT);
|
||||
put list('^iInterest Rate ');
|
||||
get list(yi);
|
||||
i = yi / 1200;
|
||||
put list('^iPay Periods ');
|
||||
get list(n);
|
||||
|
||||
if PV = 0 | PMT = 0 then
|
||||
x = 1 - 1/(1+i)**n;
|
||||
|
||||
/******************************/
|
||||
/* compute the present value */
|
||||
/******************************/
|
||||
if PV = 0 then
|
||||
do;
|
||||
PV = PMT * dec(ftc(x/i),15,6);
|
||||
put edit('^iPresent Value is ',PV)
|
||||
(a,p'$$$,$$$,$$$V.99');
|
||||
end;
|
||||
|
||||
/******************************/
|
||||
/* compute the payment */
|
||||
/******************************/
|
||||
if PMT = 0 then
|
||||
do;
|
||||
PMT = PV * dec(ftc(i/x),15,8);
|
||||
put edit('^iPayment is ',PMT)
|
||||
(a,p'$$,$$$,$$$V.99');
|
||||
end;
|
||||
|
||||
/*****************************/
|
||||
/* compute number of periods */
|
||||
/*****************************/
|
||||
if n = 0 then
|
||||
do;
|
||||
IP = ftc(i);
|
||||
x = char(PV * IP / PMT);
|
||||
n = ceil ( - log(1-x)/log(1+i) );
|
||||
put edit('^i',n,' Pay Periods')
|
||||
(a,p'ZZZ9',a);
|
||||
end;
|
||||
end;
|
||||
|
||||
end annuity;
|
||||
|
322
Digital Research PLI-86 v1/BLOKCOPY.PLI
Normal file
322
Digital Research PLI-86 v1/BLOKCOPY.PLI
Normal file
@ -0,0 +1,322 @@
|
||||
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;
|
||||
|
35
Digital Research PLI-86 v1/CALL.PLI
Normal file
35
Digital Research PLI-86 v1/CALL.PLI
Normal file
@ -0,0 +1,35 @@
|
||||
call:
|
||||
procedure options(main);
|
||||
declare
|
||||
f(3) entry(float) returns(float) variable,
|
||||
a entry(float) returns(float); */ entry constant */
|
||||
declare
|
||||
i fixed, x float;
|
||||
|
||||
f(1) = a;
|
||||
f(2) = b;
|
||||
f(3) = c;
|
||||
|
||||
do i = 1 to 3;
|
||||
put skip list('Type x ');
|
||||
get list(x);
|
||||
put list('f(',i,')=',f(i)(x));
|
||||
end;
|
||||
stop;
|
||||
|
||||
b:
|
||||
procedure(x) returns(float); /* internal procedure */
|
||||
declare x float;
|
||||
return (2*x + 1);
|
||||
end b;
|
||||
|
||||
c:
|
||||
procedure(x) returns(float); /* internal procedure */
|
||||
declare x float;
|
||||
return(sin(x));
|
||||
end c;
|
||||
|
||||
|
||||
end call;
|
||||
|
||||
|
24
Digital Research PLI-86 v1/COPY.PLI
Normal file
24
Digital Research PLI-86 v1/COPY.PLI
Normal file
@ -0,0 +1,24 @@
|
||||
/*****************************************************/
|
||||
/* This program copies one file to another using */
|
||||
/* buffered I/O. */
|
||||
/*****************************************************/
|
||||
copy:
|
||||
procedure options(main);
|
||||
declare
|
||||
(input_file,output_file) file;
|
||||
|
||||
open file (input_file) stream
|
||||
environment(b(8192)) title('$1.$1');
|
||||
|
||||
open file (output_file) stream output
|
||||
environment(b(8192)) title('$2.$2');
|
||||
declare
|
||||
buff character(254) varying;
|
||||
|
||||
do while('1'b);
|
||||
read file (input_file) into (buff);
|
||||
write file (output_file) from (buff);
|
||||
end;
|
||||
end copy;
|
||||
|
||||
|
81
Digital Research PLI-86 v1/COPYLPT.PLI
Normal file
81
Digital Research PLI-86 v1/COPYLPT.PLI
Normal file
@ -0,0 +1,81 @@
|
||||
/******************************************************/
|
||||
/* This program copies a STREAM file on disk to a */
|
||||
/* PRINT file, and formats the output with a page */
|
||||
/* header, and line numbers. */
|
||||
/******************************************************/
|
||||
copy: procedure options(main);
|
||||
|
||||
declare
|
||||
(sysin, sourcefile, printfile) file,
|
||||
(pagesize, pagewidth, spaces, linenumber) fixed,
|
||||
(line character(14), buff character(254)) varying;
|
||||
|
||||
put list('^z File to Print Copy Program');
|
||||
|
||||
on endfile(sysin)
|
||||
go to typeover;
|
||||
|
||||
typeover:
|
||||
put skip(5) list('How Many Lines Per Page? ');
|
||||
get list(pagesize);
|
||||
|
||||
put skip list('How Many Column Positions? ');
|
||||
get skip list(pagewidth);
|
||||
|
||||
on error(1)
|
||||
begin;
|
||||
put list('Invalid Number, Type Integer');
|
||||
go to getnumber;
|
||||
end;
|
||||
getnumber:
|
||||
put skip list('Line Spacing (1=Single)? ');
|
||||
get skip list(spaces);
|
||||
revert error(1);
|
||||
|
||||
put skip list('Destination Device/File: ');
|
||||
get skip list(line);
|
||||
|
||||
open file(printfile) print pagesize(pagesize)
|
||||
linesize(pagewidth) title(line);
|
||||
|
||||
on undefinedfile(sourcefile)
|
||||
begin;
|
||||
put skip list('"',line,'" isn''t a Valid Name');
|
||||
go to retry;
|
||||
end;
|
||||
retry:
|
||||
put skip list('Source File to Print? ');
|
||||
get list(line);
|
||||
open file(sourcefile) stream environment(b(8000))
|
||||
title(line);
|
||||
on endfile(sourcefile)
|
||||
begin;
|
||||
put file(printfile) page;
|
||||
stop;
|
||||
end;
|
||||
|
||||
on endfile(printfile)
|
||||
begin;
|
||||
put skip list('^g^g^g^g Disk is Full');
|
||||
stop;
|
||||
end;
|
||||
|
||||
on endpage(printfile)
|
||||
begin;
|
||||
put file(printfile) page skip(2)
|
||||
list('PAGE',pageno(printfile));
|
||||
put file(printfile) skip(4);
|
||||
end;
|
||||
|
||||
signal endpage(printfile);
|
||||
do linenumber = 1 repeat(linenumber + 1);
|
||||
get file (sourcefile) edit(buff) (a);
|
||||
put file (printfile)
|
||||
edit(linenumber,'|',buff) (f(5),x(1),a(2),a);
|
||||
put file (printfile) skip(spaces);
|
||||
end;
|
||||
|
||||
end copy;
|
||||
|
||||
|
||||
|
49
Digital Research PLI-86 v1/CREATE.PLI
Normal file
49
Digital Research PLI-86 v1/CREATE.PLI
Normal file
@ -0,0 +1,49 @@
|
||||
/*****************************************************/
|
||||
/* This program creates a name and address file. The */
|
||||
/* data structure for each record is in the %INCLUDE */
|
||||
/* file RECORD.DCL. */
|
||||
/*****************************************************/
|
||||
create:
|
||||
procedure options(main);
|
||||
|
||||
%include 'record.dcl';
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b;
|
||||
|
||||
declare
|
||||
output file,
|
||||
filename character(14) varying,
|
||||
eofile bit(1) static initial(false);
|
||||
|
||||
put list ('Name and Address Creation Program, File Name: ');
|
||||
get list (filename);
|
||||
|
||||
open file(output) stream output title(filename);
|
||||
|
||||
do while (^eofile);
|
||||
put skip(3) list('Name: ');
|
||||
get list(name);
|
||||
eofile = (name = 'EOF');
|
||||
if ^eofile then
|
||||
do;
|
||||
/* write prompt strings to console */
|
||||
put list('Address: ');
|
||||
get list(addr);
|
||||
put list('City, State, Zip: ');
|
||||
get list(city, state, zip);
|
||||
put list('Phone: ');
|
||||
get list(phone);
|
||||
|
||||
/* data in memory, write to output file */
|
||||
put file(output)
|
||||
list(name,addr,city,state,zip,phone);
|
||||
put file(output) skip;
|
||||
end;
|
||||
end;
|
||||
put file(output) skip list('EOF');
|
||||
put file(output) skip;
|
||||
|
||||
end create;
|
||||
|
||||
|
33
Digital Research PLI-86 v1/DECPOLY.PLI
Normal file
33
Digital Research PLI-86 v1/DECPOLY.PLI
Normal file
@ -0,0 +1,33 @@
|
||||
/*****************************************************/
|
||||
/* This program evaluates a polynomial expression */
|
||||
/* using FIXED DECIMAL data. */
|
||||
/*****************************************************/
|
||||
decpoly:
|
||||
procedure options(main);
|
||||
|
||||
%replace
|
||||
true by '1'b;
|
||||
declare
|
||||
(x,y,z) fixed decimal(15,4);
|
||||
|
||||
do while(true);
|
||||
put skip(2) list('Type x,y,z: ');
|
||||
get list(x,y,z);
|
||||
|
||||
if x=0 & y=0 & z=0 then
|
||||
stop;
|
||||
|
||||
put skip list(' 2');
|
||||
put skip list(' x + 2y + z =',P(x,y,z));
|
||||
end;
|
||||
|
||||
P:
|
||||
procedure (x,y,z) returns (fixed decimal(15,4));
|
||||
declare
|
||||
(x,y,z) fixed decimal(15,4);
|
||||
return (x * x + 2 * y + z);
|
||||
end P;
|
||||
|
||||
end decpoly;
|
||||
|
||||
|
15
Digital Research PLI-86 v1/DEMO.PLI
Normal file
15
Digital Research PLI-86 v1/DEMO.PLI
Normal file
@ -0,0 +1,15 @@
|
||||
demo:
|
||||
procedure options(main);
|
||||
|
||||
declare
|
||||
name character(20) varying;
|
||||
|
||||
|
||||
put skip(2) list('PLEASE ENTER YOUR FIRST NAME: ');
|
||||
get list(name);
|
||||
put skip(2) list('HELLO '||name||', WELCOME TO PL/I');
|
||||
|
||||
end demo;
|
||||
|
||||
|
||||
|
BIN
Digital Research PLI-86 v1/DEPREC.IND
Normal file
BIN
Digital Research PLI-86 v1/DEPREC.IND
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/DEPREC.INT
Normal file
BIN
Digital Research PLI-86 v1/DEPREC.INT
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/DEPREC.OBJ
Normal file
BIN
Digital Research PLI-86 v1/DEPREC.OBJ
Normal file
Binary file not shown.
298
Digital Research PLI-86 v1/DEPREC.PLI
Normal file
298
Digital Research PLI-86 v1/DEPREC.PLI
Normal file
@ -0,0 +1,298 @@
|
||||
/*******************************************************/
|
||||
/* This program calculates three kinds of depreciation */
|
||||
/* schedules: straight_line, sum_of_the_years, and */
|
||||
/* double_declining. */
|
||||
/*******************************************************/
|
||||
depreciate:
|
||||
procedure options(main);
|
||||
%replace
|
||||
clear_screen by '^z',
|
||||
indent by 15,
|
||||
ITC_rate by .1,
|
||||
bonus_rate by .1,
|
||||
bonus_max by 2000;
|
||||
|
||||
declare
|
||||
selling_price decimal(8,2),
|
||||
adjusted_price decimal(8,2),
|
||||
residual_value decimal(8,2),
|
||||
year_value decimal(8,2),
|
||||
depreciation_value decimal(8,2),
|
||||
total_depreciation decimal(8,2),
|
||||
book_value decimal(8,2),
|
||||
tax_rate decimal(3,2),
|
||||
sales_tax decimal(8,2),
|
||||
tax_bracket decimal(2),
|
||||
FYD decimal(8,2),
|
||||
ITC decimal(8,2),
|
||||
bonus_dep decimal(8,2),
|
||||
months_remaining decimal(2),
|
||||
new character(4),
|
||||
factor decimal(2,1),
|
||||
years decimal(2),
|
||||
year_sum decimal(3),
|
||||
current_year decimal(2),
|
||||
select_sched character(1);
|
||||
|
||||
declare
|
||||
copy_to_list character(4),
|
||||
output file variable,
|
||||
(sysprint, list) file;
|
||||
|
||||
declare
|
||||
schedules character(3) static initial ('syd'),
|
||||
schedule (0:3) entry variable;
|
||||
|
||||
schedule (0) = error;
|
||||
schedule (1) = straight_line;
|
||||
schedule (2) = sum_of_years;
|
||||
schedule (3) = double_declining;
|
||||
|
||||
open file (sysprint) stream print pagesize(0)
|
||||
title ('$con');
|
||||
|
||||
do while('1'b);
|
||||
put list(clear_screen,'^i^i^iDepreciation Schedule');
|
||||
put skip(3) list('^i^iSelling Price? ');
|
||||
get list(selling_price);
|
||||
put list('^i^iResidual Value? ');
|
||||
get list(residual_value);
|
||||
put list('^i^iSales Tax (%)? ');
|
||||
get list(tax_rate);
|
||||
put list('^i^iTax Bracket(%)? ');
|
||||
get list(tax_bracket);
|
||||
put list('^i^iProRate Months? ');
|
||||
get list(months_remaining);
|
||||
put list('^i^iHow Many Years? ');
|
||||
get list(years);
|
||||
put list('^i^iNew? (yes/no) ');
|
||||
get list(new);
|
||||
put edit('^i^iSchedule:',
|
||||
'^i^iStraight (s)',
|
||||
'^i^iSum-of-Yrs (y)',
|
||||
'^i^iDouble Dec (d)? ') (a,skip);
|
||||
get list(select_sched);
|
||||
put list('^i^iList? (yes/no) ');
|
||||
get list(copy_to_list);
|
||||
if copy_to_list = 'yes' then
|
||||
open file(list) stream print title('$lst');
|
||||
factor = 1.5;
|
||||
if new = 'yes' then
|
||||
factor = 2.0;
|
||||
sales_tax = decimal(selling_price*tax_rate,12,2)/100+.005;
|
||||
if new = 'yes' | selling_price <= 100000.00 then
|
||||
ITC = selling_price * ITC_rate;
|
||||
else
|
||||
ITC = 100000 * ITC_rate;
|
||||
bonus_dep = selling_price * bonus_rate;
|
||||
if bonus_dep > bonus_max then
|
||||
bonus_dep = bonus_max;
|
||||
put list(clear_screen);
|
||||
call display(sysprint);
|
||||
if copy_to_list = 'yes' then
|
||||
call display(list);
|
||||
put skip list('^i^i^i Type RETURN to Continue');
|
||||
get skip(2);
|
||||
end;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure displays the various depreciation */
|
||||
/* schedules. It calls the appropriate schedule with */
|
||||
/* an index into an array of entry constants. */
|
||||
/******************************************************/
|
||||
display:
|
||||
procedure(f);
|
||||
declare
|
||||
f file;
|
||||
output = f;
|
||||
call schedule (index (schedules,select_sched));
|
||||
end display;
|
||||
|
||||
/********************************************/
|
||||
/* This is a global error recovery routine. */
|
||||
/********************************************/
|
||||
error:
|
||||
procedure;
|
||||
put file (output) edit('Invalid Schedule - Enter s, y, or d')
|
||||
(page,column(indent),x(8),a);
|
||||
call line();
|
||||
end error;
|
||||
|
||||
/*******************************************************/
|
||||
/* This procedure computes straight_line depreciation. */
|
||||
/*******************************************************/
|
||||
straight_line:
|
||||
procedure;
|
||||
adjusted_price = selling_price - bonus_dep;
|
||||
put file (output) edit('S T R A I G H T L I N E')
|
||||
(page,column(indent),x(14),a);
|
||||
call header();
|
||||
depreciation_value = adjusted_price - residual_value;
|
||||
book_value = adjusted_price;
|
||||
total_depreciation = 0;
|
||||
do current_year = 1 to years;
|
||||
year_value = decimal(depreciation_value/years,8,2) + .005;
|
||||
if current_year = 1 then
|
||||
do;
|
||||
year_value = year_value * months_remaining / 12;
|
||||
FYD = year_value;
|
||||
end;
|
||||
depreciation_value = depreciation_value - year_value;
|
||||
total_depreciation = total_depreciation + year_value;
|
||||
book_value = adjusted_price - total_depreciation;
|
||||
call print_line();
|
||||
end;
|
||||
call summary();
|
||||
end straight_line;
|
||||
|
||||
/*************************************************/
|
||||
/* This procedure computes depreciation based on */
|
||||
/* the sum_of_the_years. */
|
||||
/*************************************************/
|
||||
sum_of_years:
|
||||
procedure;
|
||||
adjusted_price = selling_price - bonus_dep;
|
||||
put file (output) edit('S U M O F T H E Y E A R S')
|
||||
(page,column(indent),x(11),a);
|
||||
call header();
|
||||
depreciation_value = adjusted_price - residual_value;
|
||||
book_value = adjusted_price;
|
||||
total_depreciation = 0;
|
||||
year_sum = 0;
|
||||
do current_year = 1 to years;
|
||||
year_sum = year_sum + current_year;
|
||||
end;
|
||||
|
||||
do current_year = 1 to years;
|
||||
year_value = decimal(depreciation_value *
|
||||
(years - current_year + 1),12,2)/ year_sum + .005;
|
||||
if current_year = 1 then
|
||||
do;
|
||||
year_value = year_value * months_remaining / 12;
|
||||
FYD = year_value;
|
||||
end;
|
||||
depreciation_value = depreciation_value - year_value;
|
||||
total_depreciation = total_depreciation + year_value;
|
||||
book_value = adjusted_price - total_depreciation;
|
||||
call print_line();
|
||||
end;
|
||||
call summary();
|
||||
end sum_of_years;
|
||||
|
||||
/********************************************/
|
||||
/* This procedure computes double_declining */
|
||||
/* depreciation. */
|
||||
/********************************************/
|
||||
double_declining:
|
||||
procedure;
|
||||
adjusted_price = selling_price - bonus_dep;
|
||||
put file (output) edit('D O U B L E D E C L I N I N G')
|
||||
(page,column(indent),x(10),a);
|
||||
call header();
|
||||
depreciation_value = adjusted_price - residual_value;
|
||||
book_value = adjusted_price;
|
||||
total_depreciation = 0;
|
||||
do current_year = 1 to years
|
||||
while (depreciation_value > 0);
|
||||
year_value = decimal(book_value/years,8,2) * factor+.005;
|
||||
if current_year = 1 then
|
||||
do;
|
||||
year_value = year_value * months_remaining / 12;
|
||||
FYD = year_value;
|
||||
end;
|
||||
if year_value > depreciation_value then
|
||||
year_value = depreciation_value;
|
||||
depreciation_value = depreciation_value - year_value;
|
||||
total_depreciation = total_depreciation + year_value;
|
||||
book_value = adjusted_price - total_depreciation;
|
||||
call print_line();
|
||||
end;
|
||||
call summary();
|
||||
end double_declining;
|
||||
|
||||
/**************************************************/
|
||||
/* This procedure prints an output header record. */
|
||||
/**************************************************/
|
||||
header:
|
||||
procedure;
|
||||
declare
|
||||
new_or_used character(5);
|
||||
|
||||
if new = 'yes' then
|
||||
new_or_used = ' New';
|
||||
else
|
||||
new_or_used = ' Used';
|
||||
put file (output) edit(
|
||||
'--------------------------------------------------',
|
||||
'|',selling_price+sales_tax,new_or_used,
|
||||
residual_value,' Residual Value|',
|
||||
'|',months_remaining,' Months Left ',
|
||||
tax_rate,'% Tax',tax_bracket,'% Tax Bracket|')
|
||||
(2(skip,column(indent),a),
|
||||
2(p'B$$,$$$,$$9.V99',a),
|
||||
skip,column(indent),a,x(5),f(2),a,2(x(2),p'B99',a));
|
||||
|
||||
put file (output) edit(
|
||||
'--------------------------------------------------',
|
||||
'| Y | Depreciation | Depreciation | Book Value |',
|
||||
'| r | For Year | Remaining | |',
|
||||
'--------------------------------------------------')
|
||||
(skip,column(indent),a);
|
||||
end header;
|
||||
|
||||
/*******************************************/
|
||||
/* This procedure prints the current line. */
|
||||
/*******************************************/
|
||||
print_line:
|
||||
procedure;
|
||||
put file (output) edit(
|
||||
'|',current_year,
|
||||
' |',year_value,
|
||||
' |',depreciation_value,
|
||||
' |',book_value,' |')
|
||||
(skip,column(indent),a,f(2),4(a,p'$z,zzz,zz9v.99'));
|
||||
end print_line;
|
||||
|
||||
/***************************************************/
|
||||
/* This procedure prints the summary of values for */
|
||||
/* each type of depreciation schedule. */
|
||||
/***************************************************/
|
||||
summary:
|
||||
procedure;
|
||||
declare
|
||||
adj_ITC decimal(8,2),
|
||||
total decimal(8,2),
|
||||
direct decimal(8,2);
|
||||
|
||||
call line();
|
||||
adj_ITC = ITC * 100 / tax_bracket;
|
||||
total = FYD + sales_tax + adj_ITC + bonus_dep;
|
||||
direct = total * tax_bracket / 100;
|
||||
put file (output) edit(
|
||||
'| First Year Reduction in Taxable Income |',
|
||||
'--------------------------------------------------',
|
||||
'| Depreciation ' ,FYD, '|',
|
||||
'| Sales Tax ' ,sales_tax, '|',
|
||||
'| ITC (Adjusted) ' ,adj_ITC, '|',
|
||||
'| Bonus Depreciation ' ,bonus_dep, '|',
|
||||
'| ------------- |',
|
||||
'| Total for First Year ' ,total, '|',
|
||||
'| Direct Reduction in Tax ' ,direct, '|')
|
||||
(2(skip,column(indent),a),2(4(skip,column(indent),a,
|
||||
p'$z,zzz,zz9v.99',x(3),a),skip,column(indent),a));
|
||||
call line();
|
||||
end summary;
|
||||
|
||||
/*******************************************/
|
||||
/* This procedure prints a line of dashes. */
|
||||
/*******************************************/
|
||||
line:
|
||||
procedure;
|
||||
put file (output) edit(
|
||||
'--------------------------------------------------')
|
||||
(skip,column(indent),a);
|
||||
end line;
|
||||
|
||||
|
||||
end depreciate;
|
||||
|
26
Digital Research PLI-86 v1/DFACT.PLI
Normal file
26
Digital Research PLI-86 v1/DFACT.PLI
Normal file
@ -0,0 +1,26 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates the Factorial function (n!) */
|
||||
/* using recursion and FIXED DECIMAL data. */
|
||||
/******************************************************/
|
||||
dfact:
|
||||
procedure options(main);
|
||||
declare
|
||||
i fixed;
|
||||
do i = 0 repeat(i+1);
|
||||
put skip list('Factorial(',i,')=',factorial(i));
|
||||
end;
|
||||
stop;
|
||||
|
||||
factorial:
|
||||
procedure(i) returns(fixed decimal(15,0))
|
||||
recursive;
|
||||
declare
|
||||
i fixed;
|
||||
|
||||
if i = 0 then return (1);
|
||||
return (decimal(i,15) * factorial(i-1));
|
||||
end factorial;
|
||||
|
||||
end dfact;
|
||||
|
||||
|
62
Digital Research PLI-86 v1/DIOMOD.DCL
Normal file
62
Digital Research PLI-86 v1/DIOMOD.DCL
Normal file
@ -0,0 +1,62 @@
|
||||
/******************************************************************************
|
||||
* *
|
||||
* D e c l a r a t i o n s f o r I B M D O S e n t r y p o i n t s *
|
||||
* *
|
||||
******************************************************************************/
|
||||
|
||||
declare
|
||||
/* F i x e d V a l u e s */
|
||||
dfcb0 entry returns(pointer),
|
||||
dfcb1 entry returns(pointer),
|
||||
dbuff entry returns(pointer),
|
||||
memptr entry returns(pointer),
|
||||
memsiz entry returns(fixed(15)),
|
||||
memwds entry returns(fixed(15)),
|
||||
|
||||
/******************************************************************************
|
||||
* I B M D O S F u n c t i o n D e c l a r a t i o n s *
|
||||
******************************************************************************/
|
||||
/* 0 */ reboot entry,
|
||||
/* 1 */ rdcon entry returns(char(1)),
|
||||
/* 2 */ wrcon entry (character(1)),
|
||||
/* 3 */ rdrdr entry returns(char(1)),
|
||||
/* 4 */ wrpun entry (char(1)),
|
||||
/* 5 */ wrlst entry (char(1)),
|
||||
/* 6a */ coninp entry returns(char(1)),
|
||||
/* 6b */ conout entry (char(1)),
|
||||
/* 7 */ din1 entry returns(char(1)),
|
||||
/* 8 */ din2 entry returns(char(1)),
|
||||
/* 9 */ wrstr entry (pointer),
|
||||
/* 10 */ rdbuf entry (pointer),
|
||||
/* 11 */ break entry returns(fixed(7)),
|
||||
/* 12a */ clrkb1 entry (fixed(7)) returns(char(1)),
|
||||
/* 12b */ clrkb2 entry (fixed(7),pointer),
|
||||
/* 13 */ reset entry,
|
||||
/* 14 */ select entry (fixed(7)) returns(fixed(7)),
|
||||
/* 15 */ open entry (pointer) returns(fixed(7)),
|
||||
/* 16 */ close entry (pointer) returns(fixed(7)),
|
||||
/* 17 */ sear entry (pointer) returns(fixed(7)),
|
||||
/* 18 */ searn entry (pointer) returns(fixed(7)),
|
||||
/* 19 */ delete entry (pointer) returns(fixed(7)),
|
||||
/* 20 */ rdseq entry (pointer) returns(fixed(7)),
|
||||
/* 21 */ wrseq entry (pointer) returns(fixed(7)),
|
||||
/* 22 */ make entry (pointer) returns(fixed(7)),
|
||||
/* 23 */ rename entry (pointer) returns(fixed(7)),
|
||||
/* 25 */ curdsk entry returns(fixed(7)),
|
||||
/* 26 */ setdma entry (pointer),
|
||||
/* 27 */ alltbl entry (pointer,pointer,pointer,pointer),
|
||||
/* 33 */ rdran entry (pointer) returns(fixed(7)),
|
||||
/* 34 */ wrran entry (pointer) returns(fixed(7)),
|
||||
/* 35 */ filsiz entry (pointer) returns(fixed(7)),
|
||||
/* 36 */ setrec entry (pointer),
|
||||
/* 38 */ newseg entry (pointer),
|
||||
/* 39 */ blockrd entry (pointer,bit(16),pointer,pointer),
|
||||
/* 40 */ blockwr entry (pointer,bit(16),pointer,pointer),
|
||||
/* 41 */ parsfn entry (pointer,pointer,fixed(7)) returns(fixed(7)),
|
||||
/* 42 */ getdate entry (pointer,pointer,pointer),
|
||||
/* 43 */ setdate entry (fixed(15),fixed(7),fixed(7)) returns(fixed(7)),
|
||||
/* 44 */ gettime entry (pointer,pointer,pointer,pointer),
|
||||
/* 45 */ settime entry (fixed(7),fixed(7),fixed(7),fixed(7))
|
||||
returns(fixed(7)),
|
||||
/* 46 */ setver entry (fixed(7));
|
||||
|
51
Digital Research PLI-86 v1/DIV2.A86
Normal file
51
Digital Research PLI-86 v1/DIV2.A86
Normal file
@ -0,0 +1,51 @@
|
||||
; Routine to divide single precision float value by 2
|
||||
|
||||
cseg
|
||||
public div2
|
||||
extrn ?signal:near
|
||||
|
||||
; entry:
|
||||
; p1 -> fixed(7) power of two
|
||||
; p2 -> floating point number
|
||||
; exit:
|
||||
; p1 -> (unchanged)
|
||||
; p2 -> p2 / (2**p1)
|
||||
|
||||
div2: ;BX = .low(.p1)
|
||||
mov si,[bx] ;SI = .p1
|
||||
mov bx,2[bx] ;BX = .p2
|
||||
lods al ;AL = p1 (power of 2)
|
||||
|
||||
; AL = power of 2, BX = .low byte of fp num
|
||||
|
||||
cmp byte ptr 3[bx],0 ;p2 already zero?
|
||||
jz done ;exit if so
|
||||
|
||||
dby2: ;divide by two
|
||||
test al,al ;counted power of 2 to zero?
|
||||
jz done ;return if so
|
||||
dec al ;count power of two down
|
||||
sub word ptr 2[bx],80h ;count exponent down
|
||||
test word ptr 2[bx],7f80h ;test for underflow
|
||||
jnz dby2 ;loop again if no underflow
|
||||
|
||||
; Underflow occurred, signal underflow condition
|
||||
|
||||
mov bx,offset siglst;signal parameter list
|
||||
call ?signal ;signal underflow
|
||||
done: ret ;normally, no return
|
||||
|
||||
dseg
|
||||
siglst dw offset sigcod ;address of signal code
|
||||
dw offset sigsub ;address of subcode
|
||||
dw offset sigfil ;address of file code
|
||||
dw offset sigaux ;address of aux message
|
||||
; end of parameter vector, start of params
|
||||
sigcod db 3 ;03 = underflow
|
||||
sigsub db 128 ;arbitrary subcode for id
|
||||
sigfil dw 0000 ;no associated file name
|
||||
sigaux dw offset undmsg ;0000 if no aux message
|
||||
undmsg db 32,'Underflow in Divide by Two',0
|
||||
|
||||
end
|
||||
|
BIN
Digital Research PLI-86 v1/DIV2.OBJ
Normal file
BIN
Digital Research PLI-86 v1/DIV2.OBJ
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/DIV2.SYM
Normal file
BIN
Digital Research PLI-86 v1/DIV2.SYM
Normal file
Binary file not shown.
20
Digital Research PLI-86 v1/DTEST.PLI
Normal file
20
Digital Research PLI-86 v1/DTEST.PLI
Normal file
@ -0,0 +1,20 @@
|
||||
/******************************************************/
|
||||
/* This program tests an assembly language routine to */
|
||||
/* do floating point division. */
|
||||
/******************************************************/
|
||||
dtest:
|
||||
procedure options(main);
|
||||
declare
|
||||
div2 entry(fixed(7),float),
|
||||
i fixed(7),
|
||||
f float;
|
||||
|
||||
do i = 0 by 1;
|
||||
f = 100;
|
||||
call div2(i,f);
|
||||
put skip list('100 / 2 **',i,'=',f);
|
||||
end;
|
||||
|
||||
end dtest;
|
||||
|
||||
|
BIN
Digital Research PLI-86 v1/E.EXE
Normal file
BIN
Digital Research PLI-86 v1/E.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/E.OBJ
Normal file
BIN
Digital Research PLI-86 v1/E.OBJ
Normal file
Binary file not shown.
253
Digital Research PLI-86 v1/E.SYM
Normal file
253
Digital Research PLI-86 v1/E.SYM
Normal file
@ -0,0 +1,253 @@
|
||||
|
||||
0000 VARIABLES 05B8 DATA
|
||||
0D90 ?FILAT 0D9A ?FPB 0DC8 ?FPBSTK 0DDC SYSIN 0E02 SYSPRINT
|
||||
0E2A ERRMSG 0E3C ?CONSP 0E5E ?ONCOD 0E62 ?CNCOL 0E64 ?FMTS
|
||||
0E6C ?EBUFF
|
||||
0000 LABELS 0040 CODE
|
||||
0005 E
|
||||
00D5 ?SIOPR
|
||||
026C ?OIOPR
|
||||
042A ?CIOPR
|
||||
0444 ?WNIPR
|
||||
04D7 ?KEYPR
|
||||
0571 ?GNCPR
|
||||
05D2 ?PAGOP
|
||||
05E2 ?RNIPR
|
||||
06AD ?PNCPR
|
||||
079B ?SKPPR
|
||||
0848 ?GNVPR
|
||||
09C2 COS
|
||||
0A81 EXP
|
||||
0B27 TAN
|
||||
0B70 LOG
|
||||
0B85 SIN
|
||||
0C55 SQRT
|
||||
0D4A ASIN
|
||||
0EAF ATAN
|
||||
0F7F COSH
|
||||
0FBE LOG2
|
||||
0FD9 SIND
|
||||
0FFD COSD
|
||||
1021 TANH
|
||||
1075 TAND
|
||||
10BE ACOS
|
||||
110F SINH
|
||||
114E ATAND
|
||||
1169 LOG10
|
||||
1184 ?LOG
|
||||
12F2 ?EXP
|
||||
1398 ?CHEBY
|
||||
1448 ?CNVER
|
||||
144E ?ZEROD
|
||||
1457 ?OVERF 145B ?UNDER
|
||||
146B ?SVBLK
|
||||
1566 ?OFCOP 14C7 ?RSBLK 150D ?RECOV
|
||||
1594 ?ALLOP 1644 ?FREOP
|
||||
175E ?OVLAY 172C ?OVLA0
|
||||
0000 VARIABLES 05B8 DATA
|
||||
08A9 CGROUP_END 08AF DGROUP_END 08C4 SIGMSG 08BF SIGSUB 08AB CGROUP_LEN
|
||||
08B1 DGROUP_LEN 08CE ERRMSG 08C2 SIGAUX 08B5 PRESET
|
||||
08B3 OVERLAY_ENTRY 08EE DRVERR 08B6 SIGLST 0900 NSTERR
|
||||
08F7 SIZERR 0855 DMABASE 0830 OVFCB 08A7 CGROUP_OFFSET
|
||||
08AD DGROUP_OFFSET 08BE SIGCOD 0857 OVTAB 08E5 NOFILE
|
||||
08C0 SIGFIL 0909 RDERR
|
||||
0000 LABELS 0040 CODE
|
||||
1918 SETDMAB 194E COPYF 188E ENTOK 181A DRIVE_ERR 18FF RESET
|
||||
1871 UPDATE 1931 READ_ERROR 17BB LOADOV 1959 PRF00 1934 ERROR
|
||||
18C9 CHECKRANGE 18DB UPPER 183E LOAD_GROUP 18E5 UPRET 1797 OVRET
|
||||
190E RANDBLKRD 1893 INSERT 1877 UP0 1743 OV1
|
||||
181D GET_GROUP_INFO 1962 PRF0 186E RDBLKERR 196A PRF1
|
||||
1899 INS0 18A5 INS1 179F SEAR0 18AF INS2 192C NEST_ERROR
|
||||
1922 DRIVE_ERROR 18C6 NESTERR 1927 SIZE_ERROR
|
||||
191D NOFILE_ERROR 18FC NOFILEERR 1977 COPYFRET 183D NO_OFLO
|
||||
185E RDBLK 177B OVLAY05 1853 RDSEC 1904 OPEN 175A XFER
|
||||
1909 CLOSE 1798 SEARCH 18E6 OPENF 18DA CHECKOK 1772 OVLAY0
|
||||
17B3 FOUND 1794 OVLAY1 1759 NOLOAD 1913 SETDMA
|
||||
0000 NUMBERS
|
||||
0001 TRUE 0008 CG_OFFSET_BYTE 000C DG_OFFSET_BYTE
|
||||
0010 ENTRY_LEN 000A CG_END_BYTE 000E DG_END_BYTE
|
||||
0005 MAXNST 0008 MSGSIZ 0080 DBUFF 0080 SECTOR_SIZE
|
||||
0000 FALSE 0000 HEADER_CGROUP_OFFSET 0009 HEADER_DGROUP_OFFSET
|
||||
0000 LABELS 0040 CODE
|
||||
1978 ?SIGOP 198B ?SIGNAL
|
||||
1C55 ?REVOP 1C18 ?ONPRO 1C7D ?ONCPC 1C19 ?ONCOP
|
||||
1CB1 ?WRCHR
|
||||
1CCE ?QIOOP 1CDF ?FPBIN 1D4A ?FPBOU
|
||||
0000 VARIABLES 05B8 DATA
|
||||
0A64 ?MEMRY 0A62 ?CMEMRY 0A5F ?RECLST 0A5D ?BEGIN 0A61 ?DFDRV
|
||||
0A57 ?STACK
|
||||
0000 LABELS 0040 CODE
|
||||
1E04 ?SUBIO 1D6C ?START 1EDA ?STOPX 1DEC ?ADDIO 1EFC ?BDOS
|
||||
1EF2 ?ERMSG
|
||||
1F12 ?DSUOP
|
||||
1F2B ?DNGOP
|
||||
1F3D ?DMUOP
|
||||
200E ?DADOP
|
||||
2030 ?DMODF 2034 ?DDVOP
|
||||
214B ?DLDOP
|
||||
2172 ?DSTOP
|
||||
21B4 ?DCOMP 21AC ?DCMOP
|
||||
21DE ?DSIOP
|
||||
21FE ?DOVER
|
||||
2204 ?DCRET
|
||||
2214 ?CS2AD 221A ?CS3AD 2213 ?VS2AD 2210 ?VS3AD
|
||||
2230 ?SCVMS
|
||||
2245 ?SCVVM
|
||||
224E ?SCSTS
|
||||
226A ?SCCVM
|
||||
2270 ?SCVCM
|
||||
2276 ?SCSVM 2279 ?SCSCM
|
||||
228D ?SCCMS
|
||||
229F ?SCCCM
|
||||
22CF ?SASVM
|
||||
22E3 ?SAVVM 22E4 ?SACVM
|
||||
22FB ?SJSVM 22FE ?SJSCM
|
||||
2310 ?SJSTS
|
||||
2329 ?SLCTS 2328 ?SLVTS
|
||||
233B ?SSCFS
|
||||
234D ?SSVFS
|
||||
236B ?SMCVM 2368 ?SMVVM
|
||||
2379 ?SMVCM 237C ?SMCCM
|
||||
23A2 ?VCRET
|
||||
23BB ?FD44
|
||||
2489 ?FD44M
|
||||
248E ?S44MM
|
||||
249B ?FD44S
|
||||
24A0 ?S44SS
|
||||
24B9 ?FD44L
|
||||
24BE ?S44SM
|
||||
24D1 ?FD44R
|
||||
24D6 ?S44MS
|
||||
24EB ?FP40
|
||||
2532 ?FU40
|
||||
2570 ?FM44
|
||||
25B9 ?FM44M
|
||||
25BE ?FM44S
|
||||
25C3 ?FM44L
|
||||
25C8 ?FM44R
|
||||
25CD ?FC44C
|
||||
25DF ?FC44M
|
||||
25EA ?FC44S
|
||||
2600 ?FC44L
|
||||
2611 ?FPRET
|
||||
2619 ?FC44R
|
||||
262A ?FS44M
|
||||
262F ?FS44S
|
||||
2634 ?FS44L
|
||||
2639 ?FS44R
|
||||
263E ?FS44 2642 ?FA44
|
||||
26E6 ?FA44L
|
||||
26EB ?FA44M
|
||||
26F0 ?FA44S
|
||||
26F5 ?FA44R
|
||||
26FA ?FL40M
|
||||
2701 ?FN40M
|
||||
270D ?FN40S
|
||||
2714 ?FX44S
|
||||
271C ?FE40S
|
||||
2726 ?FE40M
|
||||
273C ?IE12N
|
||||
2740 ?IE10N
|
||||
274A ?IE20N
|
||||
276F ?BC12N 2756 ?BC22N
|
||||
2797 ?BSL16 278E ?BSL08
|
||||
27B0 ?BST16 27A0 ?BST08
|
||||
2838 ?QB16C 2834 ?QB08C
|
||||
2857 ?QB16I 2853 ?QB08I
|
||||
2862 ?QCB16 285E ?QCB08
|
||||
2895 ?QCDOP
|
||||
2959 ?QCFOP
|
||||
2B21 ?QCIOP
|
||||
2B94 ?QDCOP
|
||||
2C16 ?QDDOP
|
||||
2C2D ?QDDSL
|
||||
2CD0 ?QDDSR
|
||||
2D4D ?QDI15 2D4D ?QDI07
|
||||
2E93 ?UML10 2E5A ?UDV10 2EC3 ?USLOP 2EA8 ?UADOP 2D60 ?QFCMS
|
||||
2EE5 ?QFCSS
|
||||
2F02 ?QFI07
|
||||
2F16 ?QFI15
|
||||
2F49 ?QI15B 2F46 ?QI07B
|
||||
2F61 ?QICOP
|
||||
2FA8 ?QI15D 2FA5 ?QI07D
|
||||
2FEB ?QI15F 2FE9 ?QI07F
|
||||
3002 ?NSTOP
|
||||
300B ?NC22N
|
||||
300E ?NCOMP
|
||||
3089 ALLWDS 3023 MAXWDS 301D TOTWDS 30A0 STKSIZ
|
||||
30B8 FTC
|
||||
3166 ?FMODF
|
||||
3198 ?FABSF
|
||||
31AA ?FMINF 319F ?FMAXF
|
||||
31CC ?FROUN
|
||||
322B ?FTRNC
|
||||
32A0 ?FCEIL 3259 ?FFLOR
|
||||
32C0 ?FPSHF
|
||||
32D5 ?FEX15 32D2 ?FEX07
|
||||
3314 ?FPEX2
|
||||
334C ?FFXOP
|
||||
338B ?IAB15 3384 ?IAB07
|
||||
3397 ?IMINF 3392 ?IMAXF
|
||||
339D ?IMDOP
|
||||
33C3 ?IROUN
|
||||
33E5 ?IEXOP
|
||||
340B ?DMINF 33F6 ?DMAXF
|
||||
3412 ?DABSF
|
||||
341E ?DROUN
|
||||
34A5 ?DCEIL 3478 ?DFLOR
|
||||
34BC ?DEXOP
|
||||
3508 ?CXVMS
|
||||
351F ?CXSVM 3522 ?CXSCM
|
||||
3536 ?CXCVM
|
||||
353E ?CXCMS
|
||||
3554 ?CXSTS
|
||||
3574 ?CXVCM
|
||||
357A ?CXVVM
|
||||
3581 ?CXCCM
|
||||
35A8 ?QCCOP
|
||||
35F6 ?XL2OP
|
||||
3655 ?XL3OP
|
||||
36D5 COLLATE
|
||||
36EF ?BIX16 36E5 ?BIX08
|
||||
3751 ?VEROP
|
||||
3787 ?BOOLF
|
||||
37B2 ?EDITF 37B7 ?GNFMT
|
||||
38AF ?EDTOV 3C5F ?GETND
|
||||
3C7F ?ENPOP
|
||||
400A ?EDTOB
|
||||
40AB ?OUTFM 4179 ?PNC
|
||||
41AC ?EDTIV
|
||||
447E ?INPFM
|
||||
44E8 ?BADFM
|
||||
44EE ?FPBIO
|
||||
45D5 LINENO 45A0 ONKEY 4552 ONCODE 45D0 PAGENO 4559 ONFILE
|
||||
45FC ?CIOOP
|
||||
4606 ?GNVOP
|
||||
4663 ?KEYOP 4677 ?KEYTO
|
||||
4695 ?OIOOP
|
||||
46FF ?PNVOP 46CB ?PNBOP 46D0 ?PNCOP
|
||||
47E3 ?SIOOP 47DB ?SYSIN 47DF ?SYSPR
|
||||
480F ?SKPOP
|
||||
4818 ?WNIOP
|
||||
4828 ?RNIOP
|
||||
4FD8 ?GETKY 4C83 ?OPNFIL 4DDA ?RDBYTE 4E56 ?WRBUFF 5012 ?SETKY
|
||||
4DF0 ?WRBYTE 4F69 ?PATH 4F91 ?CLOSE 4E2F ?RDBUFF
|
||||
5165 ?RFSIZ 520F ?RRFCB 5213 ?RWFCB
|
||||
52EA DATE 52E8 TIME
|
||||
0000 VARIABLES 05B8 DATA
|
||||
0CA6 ?JTABLE
|
||||
0000 LABELS 0040 CODE
|
||||
53CC ?PCDOS
|
||||
55A9 SELECT 5510 DFCB1 565E BLOCKRD 55A4 RESET 564E SETREC
|
||||
5544 CONINP 5656 NEWSEG 5526 WRCON 56CB SETDATE 5698 PARSFN
|
||||
563E WRRAN 5518 REBOOT 55F9 CURDSK 555A DIN1 555E DIN2
|
||||
5506 MEMWDS 56DE GETTIME 5646 FILSIZ 55E1 WRSEQ 567B BLOCKWR
|
||||
54FD MEMSIZ 54F8 MEMPTR 5552 CONOUT 5717 SETVER 56FF SETTIME
|
||||
553C WRLST 5538 WRPUN 55E9 MAKE 5577 CLRKB1 5596 CLRKB2
|
||||
5562 WRSTR 5572 BREAK 5514 DBUFF 55C1 SEAR 55B1 OPEN
|
||||
55D1 DELETE 556A RDBUF 55B9 CLOSE 5522 RDCON 5636 RDRAN
|
||||
55F1 RENAME 55C9 SEARN 5606 ALLTBL 56B1 GETDATE 55FE SETDMA
|
||||
552A RDRDR 55D9 RDSEQ 550C DFCB0
|
||||
5723 DIV2
|
||||
5748 FDIV2
|
||||
|
62
Digital Research PLI-86 v1/ENTER.PLI
Normal file
62
Digital Research PLI-86 v1/ENTER.PLI
Normal file
@ -0,0 +1,62 @@
|
||||
/******************************************************/
|
||||
/* This program constructs a data base of employee */
|
||||
/* records using a structure declaration. */
|
||||
/******************************************************/
|
||||
|
||||
enter:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b;
|
||||
|
||||
declare
|
||||
1 employee static,
|
||||
2 name character(30) varying,
|
||||
2 address,
|
||||
3 street character(30) varying,
|
||||
3 city character(10) varying,
|
||||
3 state character(12) varying,
|
||||
3 zip fixed decimal(5),
|
||||
2 age fixed decimal(3),
|
||||
2 wage fixed decimal(5,2),
|
||||
2 hours fixed decimal(5,1);
|
||||
|
||||
declare
|
||||
1 default static,
|
||||
2 street character(30) varying
|
||||
initial('(no street)'),
|
||||
2 city character(10) varying
|
||||
initial('(no city)'),
|
||||
2 state character(12) varying
|
||||
initial('(no state)'),
|
||||
2 zip fixed decimal(5)
|
||||
initial(00000);
|
||||
declare
|
||||
emp file;
|
||||
|
||||
open file(emp) keyed output environment(f(128),b(8000))
|
||||
title ('$1.EMP');
|
||||
|
||||
do while(true);
|
||||
put list('Employee: ');
|
||||
get list(name);
|
||||
if name = 'EOF' then
|
||||
do;
|
||||
call write_it();
|
||||
stop;
|
||||
end;
|
||||
address = default;
|
||||
put list (' Age, Wage: ');
|
||||
get list (age,wage);
|
||||
hours = 0;
|
||||
call write_it();
|
||||
end;
|
||||
|
||||
write_it:
|
||||
procedure;
|
||||
write file(emp) from(employee);
|
||||
end write_it;
|
||||
|
||||
end enter;
|
||||
|
||||
|
70
Digital Research PLI-86 v1/EXPR1.PLI
Normal file
70
Digital Research PLI-86 v1/EXPR1.PLI
Normal file
@ -0,0 +1,70 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates an arithmetic expression */
|
||||
/* using recursion. It contains two procedures. GNT */
|
||||
/* obtains the input expression consisting of separate*/
|
||||
/* tokens, and EXP which performs the recursive */
|
||||
/* evaluation of the tokens in the input line. */
|
||||
/******************************************************/
|
||||
expression:
|
||||
procedure options(main);
|
||||
declare
|
||||
sysin file,
|
||||
value float,
|
||||
token character(10) varying;
|
||||
|
||||
on endfile(sysin)
|
||||
stop;
|
||||
|
||||
on error(1) /* conversion or signal */
|
||||
begin;
|
||||
put skip list('Invalid Input at ',token);
|
||||
get skip;
|
||||
goto restart;
|
||||
end;
|
||||
|
||||
restart:
|
||||
|
||||
do while('1'b);
|
||||
put skip(3) list('Type expression: ');
|
||||
value = exp();
|
||||
put skip list('Value is:',value);
|
||||
end;
|
||||
|
||||
gnt:
|
||||
procedure;
|
||||
get list(token);
|
||||
end gnt;
|
||||
|
||||
exp:
|
||||
procedure returns(float binary) recursive;
|
||||
declare x float binary;
|
||||
call gnt();
|
||||
if token = '(' then
|
||||
do;
|
||||
x = exp();
|
||||
call gnt();
|
||||
if token = '+' then
|
||||
x = x + exp();
|
||||
else
|
||||
if token = '-' then
|
||||
x = x - exp();
|
||||
else
|
||||
if token = '*' then
|
||||
x = x * exp();
|
||||
else
|
||||
if token = '/' then
|
||||
x = x / exp();
|
||||
else
|
||||
signal error(1);
|
||||
call gnt();
|
||||
if token ^= ')' then
|
||||
signal error(1);
|
||||
end;
|
||||
else
|
||||
x = token;
|
||||
return(x);
|
||||
end exp;
|
||||
|
||||
end expression;
|
||||
|
||||
|
99
Digital Research PLI-86 v1/EXPR2.PLI
Normal file
99
Digital Research PLI-86 v1/EXPR2.PLI
Normal file
@ -0,0 +1,99 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates an arithmetic expression */
|
||||
/* using recursion. It contains an expanded version */
|
||||
/* of the GNT procedure that obtains an expression */
|
||||
/* containing separate tokens. EXP then recursively */
|
||||
/* evaluates the tokens in the input line. */
|
||||
/******************************************************/
|
||||
|
||||
expression:
|
||||
procedure options(main);
|
||||
|
||||
%replace
|
||||
true by '1'b;
|
||||
|
||||
declare
|
||||
sysin file,
|
||||
value float,
|
||||
(token character(10), line character(80)) varying
|
||||
static initial('');
|
||||
|
||||
on endfile(sysin)
|
||||
stop;
|
||||
|
||||
on error(1) /* conversion or signal */
|
||||
begin;
|
||||
put skip list('Invalid Input at ',token);
|
||||
token = ''; line = '';
|
||||
goto restart;
|
||||
end;
|
||||
|
||||
restart:
|
||||
|
||||
do while('1'b);
|
||||
put skip(3) list('Type expression: ');
|
||||
value = exp();
|
||||
put edit('Value is: ',value) (skip,a,f(10,4));
|
||||
end;
|
||||
|
||||
gnt:
|
||||
procedure;
|
||||
declare
|
||||
i fixed;
|
||||
|
||||
line = substr(line,length(token)+1);
|
||||
do while(true);
|
||||
if line = '' then
|
||||
get edit(line) (a);
|
||||
i = verify(line,' ');
|
||||
if i = 0 then
|
||||
line = '';
|
||||
else
|
||||
do;
|
||||
line = substr(line,i);
|
||||
i = verify(line,'0123456789.');
|
||||
if i = 0 then
|
||||
token = line;
|
||||
else
|
||||
if i = 1 then
|
||||
token = substr(line,1,1);
|
||||
else
|
||||
token = substr(line,1,i-1);
|
||||
return;
|
||||
end;
|
||||
end;
|
||||
end gnt;
|
||||
|
||||
exp:
|
||||
procedure returns(float binary) recursive;
|
||||
declare x float binary;
|
||||
call gnt();
|
||||
if token = '(' then
|
||||
do;
|
||||
x = exp();
|
||||
call gnt();
|
||||
if token = '+' then
|
||||
x = x + exp();
|
||||
else
|
||||
if token = '-' then
|
||||
x = x - exp();
|
||||
else
|
||||
if token = '*' then
|
||||
x = x * exp();
|
||||
else
|
||||
if token = '/' then
|
||||
x = x / exp();
|
||||
else
|
||||
signal error(1);
|
||||
call gnt();
|
||||
if token ^= ')' then
|
||||
signal error(1);
|
||||
end;
|
||||
else
|
||||
x = token;
|
||||
return(x);
|
||||
end exp;
|
||||
|
||||
end expression;
|
||||
|
||||
|
16
Digital Research PLI-86 v1/FCB.DCL
Normal file
16
Digital Research PLI-86 v1/FCB.DCL
Normal file
@ -0,0 +1,16 @@
|
||||
/******************************************************************************
|
||||
* I B M D O S F i l e C o n t r o l B l o c k D e c l a r a t i o n *
|
||||
******************************************************************************/
|
||||
/* Change FCB names as necessary; types should not be changed */
|
||||
1 fcb based(fcb_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);
|
||||
|
60
Digital Research PLI-86 v1/FDIV2.A86
Normal file
60
Digital Research PLI-86 v1/FDIV2.A86
Normal file
@ -0,0 +1,60 @@
|
||||
; Division by power of two (function)
|
||||
|
||||
cseg
|
||||
public fdiv2
|
||||
extrn ?signal:near
|
||||
|
||||
; entry:
|
||||
; p1 -> fixed(7) power of two
|
||||
; p2 -> floating point number
|
||||
; exit:
|
||||
; p1 -> (unchanged)
|
||||
; p2 -> (unchanged)
|
||||
; stack: p2 / (2 ** p1)
|
||||
|
||||
fdiv2: ;BX = .low(.p1)
|
||||
mov si,[bx] ;SI = .p1
|
||||
lods al ;AL = p1 (power of 2)
|
||||
mov bx,2[bx] ;BX = .p2
|
||||
|
||||
; AL = power of 2, BX = .low byte of fp num
|
||||
|
||||
mov dx,[bx] ;DX = low and middle mantissa
|
||||
mov cx,2[bx] ;CL = high mantissa, CH = exponent
|
||||
test cx,7f80h ;exponent zero?
|
||||
jz fdret ;to return from float div
|
||||
|
||||
dby2: ;divide by two
|
||||
test al,al ;counted power of 2 to zero?
|
||||
jz fdret ;return if so
|
||||
dec al ;count power of two down
|
||||
sub cx,80h ;count exponent down
|
||||
test cx,7f80h ;test for underflow
|
||||
jnz dby2 ;loop again if no underflow
|
||||
|
||||
; Underflow occurred, signal underflow condition
|
||||
|
||||
mov bx,offset siglst;signal parameter list
|
||||
call ?signal ;signal underflow
|
||||
sub cx,cx ;clear result to zero for default return
|
||||
mov dx,cx
|
||||
|
||||
fdret: pop bx ;recall return address
|
||||
push cx ;save high order fp num
|
||||
push dx ;save low order fp num
|
||||
jmp bx ;return to calling routine
|
||||
|
||||
dseg
|
||||
siglst dw offset sigcod ;address of signal code
|
||||
dw offset sigsub ;address of subcode
|
||||
dw offset sigfil ;address of file code
|
||||
dw offset sigaux ;address of aux message
|
||||
; end of parameter vector, start of params
|
||||
sigcod db 3 ;03 = underflow
|
||||
sigsub db 128 ;arbitrary subcode for id
|
||||
sigfil dw 0000 ;no associated file name
|
||||
sigaux dw offset undmsg ;0000 if no aux message
|
||||
undmsg db 32,'Underflow in Divide by Two',0
|
||||
|
||||
end
|
||||
|
BIN
Digital Research PLI-86 v1/FDIV2.OBJ
Normal file
BIN
Digital Research PLI-86 v1/FDIV2.OBJ
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/FDIV2.SYM
Normal file
BIN
Digital Research PLI-86 v1/FDIV2.SYM
Normal file
Binary file not shown.
18
Digital Research PLI-86 v1/FDTEST.PLI
Normal file
18
Digital Research PLI-86 v1/FDTEST.PLI
Normal file
@ -0,0 +1,18 @@
|
||||
/****************************************************/
|
||||
/* This program tests the assembly-language routine */
|
||||
/* called FDIV2 which returns a FLOAT BINARY value. */
|
||||
/****************************************************/
|
||||
fdtest:
|
||||
procedure options(main);
|
||||
declare
|
||||
fdiv2 entry(fixed(7),float) returns(float),
|
||||
i fixed(7),
|
||||
f float;
|
||||
|
||||
do i = 0 by 1;
|
||||
put skip list('100 / 2 **',i,'=',fdiv2(i,100));
|
||||
end;
|
||||
|
||||
end fdtest;
|
||||
|
||||
|
24
Digital Research PLI-86 v1/FFACT.PLI
Normal file
24
Digital Research PLI-86 v1/FFACT.PLI
Normal file
@ -0,0 +1,24 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates the Factorial function (n!) */
|
||||
/* using recursion and FLOAT BINARY data. */
|
||||
/******************************************************/
|
||||
ffact:
|
||||
procedure options(main);
|
||||
declare
|
||||
i fixed;
|
||||
do i = 0 repeat(i+1);
|
||||
put skip list('Factorial(',i,')=',factorial(i));
|
||||
end;
|
||||
stop;
|
||||
|
||||
factorial:
|
||||
procedure(i) returns(float) recursive;
|
||||
declare
|
||||
i fixed;
|
||||
if i = 0 then return (1);
|
||||
return (i * factorial(i-1));
|
||||
end factorial;
|
||||
|
||||
end ffact;
|
||||
|
||||
|
33
Digital Research PLI-86 v1/FLTPOLY.PLI
Normal file
33
Digital Research PLI-86 v1/FLTPOLY.PLI
Normal file
@ -0,0 +1,33 @@
|
||||
/*****************************************************/
|
||||
/* This program evaluates a polynomial expression */
|
||||
/* using FLOAT BINARY data. */
|
||||
/*****************************************************/
|
||||
fltpoly:
|
||||
procedure options(main);
|
||||
|
||||
%replace
|
||||
true by '1'b;
|
||||
declare
|
||||
(x,y,z) float binary(24);
|
||||
|
||||
do while(true);
|
||||
put skip(2) list('Type x,y,z: ');
|
||||
get list(x,y,z);
|
||||
|
||||
if x=0 & y=0 & z=0 then
|
||||
stop;
|
||||
|
||||
put skip list(' 2');
|
||||
put skip list(' x + 2y + z =',P(x,y,z));
|
||||
end;
|
||||
|
||||
P:
|
||||
procedure (x,y,z) returns (float binary(24));
|
||||
declare
|
||||
(x,y,z) float binary;
|
||||
return (x * x + 2 * y + z);
|
||||
end P;
|
||||
|
||||
end fltpoly;
|
||||
|
||||
|
39
Digital Research PLI-86 v1/FLTPOLY2.PLI
Normal file
39
Digital Research PLI-86 v1/FLTPOLY2.PLI
Normal file
@ -0,0 +1,39 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates a polynomial expression */
|
||||
/* using FLOAT BINARY data. It also traps the end-of */
|
||||
/* file condition for the file SYSIN. */
|
||||
/******************************************************/
|
||||
fltpoly2:
|
||||
procedure options(main);
|
||||
%replace
|
||||
false by '0'b,
|
||||
true by '1'b;
|
||||
declare
|
||||
(x,y,z) float binary(24),
|
||||
eofile bit(1) static initial(false),
|
||||
sysin file;
|
||||
|
||||
on endfile(sysin)
|
||||
eofile = true;
|
||||
|
||||
do while(true);
|
||||
put skip(2) list('Type x,y,z: ');
|
||||
get list(x,y,z);
|
||||
|
||||
if eofile then
|
||||
stop;
|
||||
|
||||
put skip list(' 2');
|
||||
put skip list(' x + 2y + z =',P(x,y,z));
|
||||
end;
|
||||
|
||||
P:
|
||||
procedure (x,y,z) returns (float binary(24));
|
||||
declare
|
||||
(x,y,z) float binary(24);
|
||||
return (x * x + 2 * y + z);
|
||||
end P;
|
||||
|
||||
end fltpoly2;
|
||||
|
||||
|
51
Digital Research PLI-86 v1/FSCAN.PLI
Normal file
51
Digital Research PLI-86 v1/FSCAN.PLI
Normal file
@ -0,0 +1,51 @@
|
||||
/******************************************************/
|
||||
/* This program tests the procedure called GNT, which */
|
||||
/* is a free-field scanner (parser) that reads a line */
|
||||
/* of input and breaks it into individual parts. */
|
||||
/******************************************************/
|
||||
fscan:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b;
|
||||
declare
|
||||
token character(80) varying
|
||||
static initial('');
|
||||
|
||||
gnt:
|
||||
procedure;
|
||||
declare
|
||||
i fixed,
|
||||
line character(80) varying
|
||||
static initial('');
|
||||
|
||||
line = substr(line,length(token)+1);
|
||||
do while(true);
|
||||
if line = '' then
|
||||
get edit(line) (a);
|
||||
i = verify(line,' ');
|
||||
if i = 0 then
|
||||
line = '';
|
||||
else
|
||||
do;
|
||||
line = substr(line,i);
|
||||
i = verify(line,'0123456789.');
|
||||
if i = 0 then
|
||||
token = line;
|
||||
else
|
||||
if i = 1 then
|
||||
token = substr(line,1,1);
|
||||
else
|
||||
token = substr(line,1,i-1);
|
||||
return;
|
||||
end;
|
||||
end;
|
||||
end gnt;
|
||||
|
||||
do while(true);
|
||||
call gnt;
|
||||
put edit(''''!!token!!'''') (x(1),a);
|
||||
end;
|
||||
|
||||
end fscan;
|
||||
|
||||
|
20
Digital Research PLI-86 v1/IFACT.PLI
Normal file
20
Digital Research PLI-86 v1/IFACT.PLI
Normal file
@ -0,0 +1,20 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates the Factorial function (n!) */
|
||||
/* using iteration. */
|
||||
/******************************************************/
|
||||
ifact:
|
||||
procedure options(main);
|
||||
declare
|
||||
(i, n, F) fixed;
|
||||
|
||||
do i = 0 by 1;
|
||||
F = 1;
|
||||
do n = i to 1 by -1;
|
||||
F = n * F;
|
||||
end;
|
||||
put edit('factorial(',i,')=',F)
|
||||
(skip, a,f(2), a, f(7));
|
||||
end;
|
||||
end ifact;
|
||||
|
||||
|
30
Digital Research PLI-86 v1/INVERT.PLI
Normal file
30
Digital Research PLI-86 v1/INVERT.PLI
Normal file
@ -0,0 +1,30 @@
|
||||
/******************************************************/
|
||||
/* This is an external procedure called by MAININVT. */
|
||||
/******************************************************/
|
||||
invert:
|
||||
procedure (a,r,c);
|
||||
%include 'matsize.lib';
|
||||
declare
|
||||
(d, a(maxrow,maxcol)) float binary(24),
|
||||
(i,j,k,l,r,c) fixed binary(6);
|
||||
do i = 1 to r;
|
||||
d = a(i,1);
|
||||
do j = 1 to c - 1;
|
||||
a(i,j) = a(i,j+1)/d;
|
||||
end;
|
||||
a(i,c) = 1/d;
|
||||
do k = 1 to r;
|
||||
if k ^= i then
|
||||
do;
|
||||
d = a(k,1);
|
||||
do l = 1 to c - 1;
|
||||
a(k,l) = a(k,l+1) - a(i,l) * d;
|
||||
end;
|
||||
a(k,c) = - a(i,c) * d;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end invert;
|
||||
|
||||
|
33
Digital Research PLI-86 v1/KEYFILE.PLI
Normal file
33
Digital Research PLI-86 v1/KEYFILE.PLI
Normal file
@ -0,0 +1,33 @@
|
||||
/******************************************************/
|
||||
/* This program reads an employee record file and */
|
||||
/* creates another file of keys to access the records.*/
|
||||
/******************************************************/
|
||||
|
||||
keyfile:
|
||||
procedure options(main);
|
||||
declare
|
||||
1 employee static,
|
||||
2 name character(30) varying;
|
||||
|
||||
declare
|
||||
(input, keys) file,
|
||||
k fixed;
|
||||
|
||||
open file(input) keyed environment(f(128),b(10000))
|
||||
title('$1.emp');
|
||||
|
||||
open file(keys) stream output
|
||||
linesize (60) title('$1.key');
|
||||
|
||||
do while('1');
|
||||
read file(input) into(employee) keyto(k);
|
||||
put skip list(k,name);
|
||||
put file(keys) list(name,k);
|
||||
if name = 'EOF' then
|
||||
stop;
|
||||
end;
|
||||
|
||||
end keyfile;
|
||||
|
||||
|
||||
|
45
Digital Research PLI-86 v1/LABELS.PLI
Normal file
45
Digital Research PLI-86 v1/LABELS.PLI
Normal file
@ -0,0 +1,45 @@
|
||||
/******************************************************/
|
||||
/* This is a non-functional program. Its purpose is */
|
||||
/* to illustrate the concept of label constants and */
|
||||
/* variables. */
|
||||
/******************************************************/
|
||||
Labels:
|
||||
procedure options(main);
|
||||
declare
|
||||
i fixed,
|
||||
(x, y, z(3)) label;
|
||||
x = lab1;
|
||||
y = x;
|
||||
|
||||
goto lab1;
|
||||
goto x;
|
||||
goto y;
|
||||
|
||||
call P(lab2);
|
||||
|
||||
do i = 1 to 3;
|
||||
z(i) = c(i);
|
||||
end;
|
||||
|
||||
i = 2;
|
||||
goto z(i);
|
||||
goto c(i);
|
||||
|
||||
c(1):;
|
||||
c(2):;
|
||||
c(3):;
|
||||
|
||||
lab1:;
|
||||
lab2:;
|
||||
|
||||
P:
|
||||
procedure (g);
|
||||
declare
|
||||
g label;
|
||||
goto g;
|
||||
end P;
|
||||
|
||||
end Labels;
|
||||
|
||||
|
||||
|
BIN
Digital Research PLI-86 v1/LIB86.EXE
Normal file
BIN
Digital Research PLI-86 v1/LIB86.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/LINK.EXE
Normal file
BIN
Digital Research PLI-86 v1/LINK.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/LINK86.EXE
Normal file
BIN
Digital Research PLI-86 v1/LINK86.EXE
Normal file
Binary file not shown.
42
Digital Research PLI-86 v1/LOAN1.PLI
Normal file
42
Digital Research PLI-86 v1/LOAN1.PLI
Normal file
@ -0,0 +1,42 @@
|
||||
/******************************************************/
|
||||
/* This program produces a schedule of loan payments */
|
||||
/* using the following algorithm: if P = loan payment,*/
|
||||
/* i = interest, and PMT is the monthly payment then */
|
||||
/* P = (P + (i*P) - PMT. */
|
||||
/******************************************************/
|
||||
loan1:
|
||||
procedure options(main);
|
||||
declare
|
||||
m fixed binary,
|
||||
y fixed binary,
|
||||
P fixed decimal(11,2),
|
||||
PMT fixed decimal(6,2),
|
||||
i fixed decimal(4,2);
|
||||
|
||||
do while('1'b);
|
||||
put skip list('Principal ');
|
||||
get list(P);
|
||||
put list('Interest ');
|
||||
get list(i);
|
||||
put list('Payment ');
|
||||
get list(PMT);
|
||||
m = 0;
|
||||
y = 0;
|
||||
do while (P > 0);
|
||||
if mod(m,12) = 0 then
|
||||
do;
|
||||
y = y + 1;
|
||||
put skip list('Year',y);
|
||||
end;
|
||||
m = m + 1;
|
||||
put skip list(m,P);
|
||||
P = P + round( i * P / 1200, 2);
|
||||
if P < PMT
|
||||
then PMT = P;
|
||||
put list(PMT);
|
||||
P = P - PMT;
|
||||
end;
|
||||
end;
|
||||
|
||||
end loan1;
|
||||
|
221
Digital Research PLI-86 v1/LOAN2.PLI
Normal file
221
Digital Research PLI-86 v1/LOAN2.PLI
Normal file
@ -0,0 +1,221 @@
|
||||
/*****************************************************/
|
||||
/* This program computes a schedule of loan payments */
|
||||
/* using an elaborate analysis and display format. */
|
||||
/* It contains five internal procedures: DISPLAY, */
|
||||
/* SUMMARY, CURRENT_YEAR, HEADER, and LINE. */
|
||||
/*****************************************************/
|
||||
loan2:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b,
|
||||
clear by '^z';
|
||||
|
||||
declare
|
||||
end bit(1),
|
||||
m fixed binary,
|
||||
sm fixed binary,
|
||||
y fixed binary,
|
||||
sy fixed binary,
|
||||
fm fixed binary,
|
||||
dl fixed binary,
|
||||
P fixed decimal(10,2),
|
||||
PV fixed decimal(10,2),
|
||||
PP fixed decimal(10,2),
|
||||
PL fixed decimal(10,2),
|
||||
PMT fixed decimal(10,2),
|
||||
PMV fixed decimal(10,2),
|
||||
INT fixed decimal(10,2),
|
||||
YIN fixed decimal(10,2),
|
||||
IP fixed decimal(10,2),
|
||||
yi fixed decimal(4,2),
|
||||
i fixed decimal(4,2),
|
||||
INF fixed decimal(4,3),
|
||||
ci fixed decimal(15,14),
|
||||
fi fixed decimal(7,5),
|
||||
ir fixed decimal(4,2);
|
||||
|
||||
declare
|
||||
name character(14) varying static initial('$con'),
|
||||
output file;
|
||||
|
||||
put list(clear,'^i^iS U M M A R Y O F P A Y M E N T S');
|
||||
|
||||
on undefinedfile(output)
|
||||
begin;
|
||||
put skip list('^i^icannot write to',name);
|
||||
goto open_output;
|
||||
end;
|
||||
|
||||
open_output:
|
||||
put skip(2) list('^i^iOutput File Name ');
|
||||
get list(name);
|
||||
if name = '$con' then
|
||||
open file(output) title('$con') print pagesize(0);
|
||||
else
|
||||
open file(output) title(name) print;
|
||||
|
||||
on error
|
||||
begin;
|
||||
put skip list('^i^iBad Input Data, Retry');
|
||||
goto retry;
|
||||
end;
|
||||
|
||||
retry:
|
||||
do while(true);
|
||||
put skip(2) list('^i^iPrincipal ');
|
||||
get list(PV);
|
||||
P = PV;
|
||||
put list('^i^iInterest ');
|
||||
get list(yi);
|
||||
i = yi;
|
||||
put list('^i^iPayment ');
|
||||
get list(PMV);
|
||||
PMT = PMV;
|
||||
put list('^i^i%Inflation ');
|
||||
get list(ir);
|
||||
fi = 1 + ir/1200;
|
||||
ci = 1.00;
|
||||
put list('^i^iStarting Month ');
|
||||
get list(sm);
|
||||
put list('^i^iStarting Year ');
|
||||
get list(sy);
|
||||
put list('^i^iFiscal Month ');
|
||||
get list(fm);
|
||||
put edit('^i^iDisplay Level ',
|
||||
'^i^iYr Results : 0 ',
|
||||
'^i^iYr Interest: 1 ',
|
||||
'^i^iAll Values : 2 ')
|
||||
(skip,a);
|
||||
get list(dl);
|
||||
if dl < 0 | dl > 2 then
|
||||
signal error;
|
||||
m = sm;
|
||||
y = sy;
|
||||
IP = 0;
|
||||
PP = 0;
|
||||
YIN = 0;
|
||||
if name ^= '' then
|
||||
put file(output) page;
|
||||
call header();
|
||||
do while (P > 0);
|
||||
end = false;
|
||||
INT = round ( i * P / 1200, 2 );
|
||||
IP = IP + INT;
|
||||
PL = P;
|
||||
P = P + INT;
|
||||
if P < PMT then
|
||||
PMT = P;
|
||||
P = P - PMT;
|
||||
PP = PP + (PL - P);
|
||||
INF = ci;
|
||||
ci = ci / fi;
|
||||
if P = 0 | dl > 1 | m = fm then
|
||||
do;
|
||||
put file(output) skip
|
||||
edit('|',100*m+y) (a,p'99/99');
|
||||
call display(PL * INF, INT * INF,
|
||||
PMT * INF, PP * INF, IP * INF);
|
||||
end;
|
||||
if m = fm & dl > 0 then
|
||||
call summary();
|
||||
m = m + 1;
|
||||
if m > 12 then
|
||||
do;
|
||||
m = 1;
|
||||
y = y + 1;
|
||||
if y > 99 then
|
||||
y = 0;
|
||||
end;
|
||||
end;
|
||||
if dl = 0 then
|
||||
call line();
|
||||
else
|
||||
if ^end then
|
||||
call summary();
|
||||
end retry;
|
||||
/****************************************************/
|
||||
/* This procedure performs the output of the actual */
|
||||
/* parameters passed to it by the main part of the */
|
||||
/* program. */
|
||||
/****************************************************/
|
||||
display:
|
||||
procedure(a,b,c,d,e);
|
||||
declare
|
||||
(a,b,c,d,e) fixed decimal(10,2);
|
||||
|
||||
put file (output) edit
|
||||
('|',a,'|',b,'|',c,'|',d,'|',e,'|')
|
||||
(a,2(2(p'$zz,zzz,zz9v.99',a),
|
||||
p'$zzz,zz9.v99',a));
|
||||
end display;
|
||||
|
||||
/*************************************************/
|
||||
/* This procedure computes the summary of yearly */
|
||||
/* interest. */
|
||||
/*************************************************/
|
||||
summary:
|
||||
procedure;
|
||||
end = true;
|
||||
call current_year(IP-YIN);
|
||||
YIN = IP;
|
||||
end summary;
|
||||
|
||||
/****************************************************/
|
||||
/* This procedure computes the interest paid during */
|
||||
/* current year. */
|
||||
/****************************************************/
|
||||
current_year:
|
||||
procedure(I);
|
||||
declare
|
||||
yp fixed binary,
|
||||
I fixed decimal(10,2);
|
||||
yp = y;
|
||||
if fm < 12 then
|
||||
yp = yp - 1;
|
||||
call line();
|
||||
put skip file(output) edit
|
||||
('|','Interest Paid During ''',yp,'-''',y,' is ',I,'|')
|
||||
(a,x(15),2(a,p'99'),a,p'$$$,$$$,$$9V.99',x(16),a);
|
||||
call line();
|
||||
end current_year;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure defines and prints out an elaborate */
|
||||
/* header format. */
|
||||
/******************************************************/
|
||||
header:
|
||||
procedure;
|
||||
put file(output) list(clear);
|
||||
call line();
|
||||
put file(output) skip edit
|
||||
('|','L O A N P A Y M E N T S U M M A R Y','|')
|
||||
(a,x(19));
|
||||
call line();
|
||||
put file(output) skip edit
|
||||
('|','Interest Rate',yi,'%','Inflation Rate',ir,'%','|')
|
||||
(a,x(15),2(a,p'b99v.99',a,x(6)),x(9),a);
|
||||
call line();
|
||||
put file(output) skip edit
|
||||
('|Date |',' Principal |','Plus Interest|',' Payment |',
|
||||
'Principal Paid|','Interest Paid |') (a);
|
||||
call line();
|
||||
end header;
|
||||
|
||||
/*******************************************************/
|
||||
/* This procedure prints out a series of dashed lines. */
|
||||
/*******************************************************/
|
||||
line:
|
||||
procedure;
|
||||
declare
|
||||
i fixed bin;
|
||||
put file(output) skip edit
|
||||
('-------','------------',
|
||||
('---------------' do i = 1 to 4)) (a);
|
||||
end line;
|
||||
|
||||
|
||||
end loan2;
|
||||
|
||||
|
||||
|
65
Digital Research PLI-86 v1/MAININVT.PLI
Normal file
65
Digital Research PLI-86 v1/MAININVT.PLI
Normal file
@ -0,0 +1,65 @@
|
||||
/******************************************************/
|
||||
/* This program is the main module in a program that */
|
||||
/* performs matrix inversion. It calls the entry */
|
||||
/* constant INVERT which does the actual inversion. */
|
||||
/******************************************************/
|
||||
maininvt:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b;
|
||||
%include 'matsize.lib';
|
||||
|
||||
declare
|
||||
mat(maxrow,maxcol) float binary(24),
|
||||
(i,j,n,m) fixed(6),
|
||||
var character (26) static initial
|
||||
('abcdefghijklmnopqrstuvwxyz'),
|
||||
invert entry
|
||||
((maxrow,maxcol) float(24), fixed(6), fixed(6));
|
||||
|
||||
put list('Solution of Simultaneous Equations');
|
||||
do while(true);
|
||||
put skip(2) list('Type rows, columns: ');
|
||||
get list(n);
|
||||
if n = 0 then
|
||||
stop;
|
||||
|
||||
get list(m);
|
||||
if n > maxrow ! m > maxcol then
|
||||
put skip list('Matrix is Too Large');
|
||||
else
|
||||
do;
|
||||
put skip list('Type Matrix of Coefficients');
|
||||
put skip;
|
||||
do i = 1 to n;
|
||||
put list('Row',i,':');
|
||||
get list((mat(i,j) do j = 1 to n));
|
||||
end;
|
||||
|
||||
put skip list('Type Solution Vectors');
|
||||
put skip;
|
||||
do j = n + 1 to m;
|
||||
put list('Variable',substr(var,j-n,1),':');
|
||||
get list((mat(i,j) do i = 1 to n));
|
||||
end;
|
||||
|
||||
call invert(mat,n,m);
|
||||
put skip(2) list('Solutions:');
|
||||
do i = 1 to n;
|
||||
put skip list(substr(var,i,1),'=');
|
||||
put edit((mat(i,j) do j = 1 to m-n))
|
||||
(f(8,2));
|
||||
end;
|
||||
|
||||
put skip(2) list('Inverse Matrix is');
|
||||
do i = 1 to n;
|
||||
put skip edit((mat(i,j) do j = m-n+1 to m))
|
||||
(x(3),6f(8,2),skip);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end maininvt;
|
||||
|
||||
|
4
Digital Research PLI-86 v1/MATSIZE.LIB
Normal file
4
Digital Research PLI-86 v1/MATSIZE.LIB
Normal file
@ -0,0 +1,4 @@
|
||||
%replace
|
||||
maxrow by 26,
|
||||
maxcol by 40;
|
||||
|
267
Digital Research PLI-86 v1/NETWORK.PLI
Normal file
267
Digital Research PLI-86 v1/NETWORK.PLI
Normal file
@ -0,0 +1,267 @@
|
||||
/******************************************************/
|
||||
/* This program finds the shortest path between nodes */
|
||||
/* in a network. It has 8 internal procedures: */
|
||||
/* SETUP, CONNECT, FIND, PRINT_ALL, PRINT_PATHS, */
|
||||
/* SHORTEST_DISTANCE, PRINT_ROUTE, and FREE_ALL. */
|
||||
/******************************************************/
|
||||
network:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b,
|
||||
citysize by 20,
|
||||
infinite by 32767;
|
||||
declare
|
||||
sysin file;
|
||||
declare
|
||||
1 city_node based,
|
||||
2 city_name character(citysize) varying,
|
||||
2 total_distance fixed,
|
||||
2 investigate bit,
|
||||
2 city_list pointer,
|
||||
2 route_head pointer;
|
||||
declare
|
||||
1 route_node based,
|
||||
2 next_city pointer,
|
||||
2 route_distance fixed,
|
||||
2 route_list pointer;
|
||||
declare
|
||||
city_head pointer;
|
||||
|
||||
do while(true);
|
||||
call setup();
|
||||
if city_head = null then
|
||||
stop;
|
||||
call print_all();
|
||||
call print_paths();
|
||||
call free_all();
|
||||
end;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure reads two cities and then calls the */
|
||||
/* procedure CONNECT to establish the connection (in */
|
||||
/* both directions) between the cities. */
|
||||
/******************************************************/
|
||||
setup:
|
||||
procedure;
|
||||
declare
|
||||
distance fixed,
|
||||
(city1, city2) character(citysize) varying;
|
||||
on endfile(sysin) goto eof;
|
||||
city_head = null;
|
||||
put skip list('Type "City1, Dist, City2"');
|
||||
put skip;
|
||||
do while(true);
|
||||
get list(city1, distance, city2);
|
||||
call connect(city1, distance, city2);
|
||||
call connect(city2, distance, city1);
|
||||
end;
|
||||
eof:
|
||||
end setup;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure establishes a single route_node to */
|
||||
/* connect the first city to the second city by */
|
||||
/* calling the FIND procedure twice; once for the */
|
||||
/* first city and once for the second city. */
|
||||
/******************************************************/
|
||||
connect:
|
||||
procedure(source_city, distance, destination_city);
|
||||
declare
|
||||
source_city character(citysize) varying,
|
||||
destination_city character(citysize) varying,
|
||||
distance fixed,
|
||||
(r, s, d) pointer;
|
||||
|
||||
s = find(source_city);
|
||||
d = find(destination_city);
|
||||
allocate route_node set (r);
|
||||
r->route_distance = distance;
|
||||
r->next_city = d;
|
||||
r->route_list = s->route_head;
|
||||
s->route_head = r;
|
||||
end connect;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure searches the list of cities and */
|
||||
/* returns a pointer to the requested city_node. */
|
||||
/******************************************************/
|
||||
find:
|
||||
procedure(city) returns(pointer);
|
||||
declare
|
||||
city character(citysize) varying,
|
||||
(p, q) pointer;
|
||||
|
||||
do p = city_head
|
||||
repeat(p->city_list) while(p^=null);
|
||||
if city = p->city_name then
|
||||
return(p);
|
||||
end;
|
||||
allocate city_node set(p);
|
||||
p->city_name = city;
|
||||
p->city_list = city_head;
|
||||
city_head = p;
|
||||
p->total_distance = infinite;
|
||||
p->route_head = null;
|
||||
return(p);
|
||||
end find;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure starts at the city_head and displays*/
|
||||
/* all the cities in the city_list. */
|
||||
/******************************************************/
|
||||
print_all:
|
||||
procedure;
|
||||
declare
|
||||
(p, q) pointer;
|
||||
|
||||
do p = city_head
|
||||
repeat(p->city_list) while(p^=null);
|
||||
put skip list(p->city_name,':');
|
||||
do q = p->route_head
|
||||
repeat(q->route_list) while(q^=null);
|
||||
put skip list(q->route_distance,'miles to',
|
||||
q->next_city->city_name);
|
||||
end;
|
||||
end;
|
||||
end print_all;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure reads a destination city, calls the */
|
||||
/* SHORTEST_DISTANCE procedure, and sets the */
|
||||
/* total_distance field in each city_node to the */
|
||||
/* total distance from the destination city. */
|
||||
/******************************************************/
|
||||
print_paths:
|
||||
procedure;
|
||||
declare
|
||||
city character(citysize) varying;
|
||||
|
||||
on endfile(sysin) goto eof;
|
||||
do while(true);
|
||||
put skip list('Type Destination ');
|
||||
get list(city);
|
||||
call shortest_distance(city);
|
||||
on endfile(sysin) goto eol;
|
||||
do while(true);
|
||||
put skip list('Type Start ');
|
||||
get list(city);
|
||||
call print_route(city);
|
||||
end;
|
||||
eol: revert endfile(sysin);
|
||||
end;
|
||||
eof:
|
||||
end print_paths;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure is the heart of the program. It */
|
||||
/* takes an input city (the destination), and computes*/
|
||||
/* the minimum total distance from every city in the */
|
||||
/* network to the destination. It then records this */
|
||||
/* minimum value in the total_distance field of every */
|
||||
/* city_node. */
|
||||
/******************************************************/
|
||||
shortest_distance:
|
||||
procedure(city);
|
||||
declare
|
||||
city character(citysize) varying;
|
||||
declare
|
||||
bestp pointer,
|
||||
(d, bestd) fixed,
|
||||
(p, q, r) pointer;
|
||||
do p = city_head
|
||||
repeat(p->city_list) while(p^=null);
|
||||
p->total_distance = infinite;
|
||||
p->investigate = false;
|
||||
end;
|
||||
p = find(city);
|
||||
p->total_distance = 0;
|
||||
p->investigate = true;
|
||||
do while(true);
|
||||
bestp = null;
|
||||
bestd = infinite;
|
||||
do p = city_head
|
||||
repeat(p->city_list) while(p^=null);
|
||||
if p->investigate then
|
||||
do;
|
||||
if p->total_distance < bestd then
|
||||
do;
|
||||
bestd = p->total_distance;
|
||||
bestp = p;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if bestp = null then
|
||||
return;
|
||||
bestp->investigate = false;
|
||||
do q = bestp->route_head
|
||||
repeat(q->route_list) while(q^=null);
|
||||
r = q->next_city;
|
||||
d = bestd + q->route_distance;
|
||||
if d < r->total_distance then
|
||||
do;
|
||||
r->total_distance = d;
|
||||
r->investigate = true;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end shortest_distance;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure displays the best route from the */
|
||||
/* input city to the destination. */
|
||||
/******************************************************/
|
||||
print_route:
|
||||
procedure(city);
|
||||
declare
|
||||
city character(citysize) varying;
|
||||
declare
|
||||
(p,q) pointer,
|
||||
(t,d) fixed;
|
||||
p = find(city);
|
||||
do while(true);
|
||||
t = p->total_distance;
|
||||
if t = infinite then
|
||||
do;
|
||||
put skip list('(No Connection)');
|
||||
return;
|
||||
end;
|
||||
if t = 0 then
|
||||
return;
|
||||
put skip list(t,'miles remain,');
|
||||
q = p->route_head;
|
||||
do while(q^=null);
|
||||
p = q->next_city;
|
||||
d = q->route_distance;
|
||||
if t = d + p->total_distance then
|
||||
do;
|
||||
put list(d,'miles to',p->city_name);
|
||||
q = null;
|
||||
end;
|
||||
else
|
||||
q = q->route_list;
|
||||
end;
|
||||
end;
|
||||
end print_route;
|
||||
|
||||
/******************************************************/
|
||||
/* This procedure frees all the storage allocated */
|
||||
/* by the program while processing the network. */
|
||||
/******************************************************/
|
||||
free_all:
|
||||
procedure;
|
||||
declare
|
||||
(p, q) pointer;
|
||||
do p = city_head
|
||||
repeat(p->city_list) while(p^=null);
|
||||
do q = p->route_head
|
||||
repeat(q->route_list) while(q^=null);
|
||||
free q->route_node;
|
||||
end;
|
||||
free p->city_node;
|
||||
end;
|
||||
end free_all;
|
||||
|
||||
end network;
|
||||
|
||||
|
49
Digital Research PLI-86 v1/OPTIMIST.PLI
Normal file
49
Digital Research PLI-86 v1/OPTIMIST.PLI
Normal file
@ -0,0 +1,49 @@
|
||||
/******************************************************/
|
||||
/* This program demonstrates PL/I character string */
|
||||
/* processing by turning a negative sentence into a */
|
||||
/* positive one. */
|
||||
/******************************************************/
|
||||
optimist:
|
||||
procedure options(main);
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b,
|
||||
nwords by 5;
|
||||
declare
|
||||
negative (1:nwords) character(8) varying static initial
|
||||
(' never',' none',' nothing',' not',' no'),
|
||||
positive (1:nwords) character(10) varying static initial
|
||||
(' always',' all',' something','',' some'),
|
||||
upper character(28) static initial
|
||||
('ABCDEFGHIJKLMNOPQRSTUVWXYZ. '),
|
||||
lower character(28) static initial
|
||||
('abcdefghijklmnopqrstuvwxyz. '),
|
||||
sent character(254) varying,
|
||||
word character(32) varying,
|
||||
(i,j) fixed;
|
||||
|
||||
do while(true);
|
||||
put skip list('What''s up? ');
|
||||
sent = ' ';
|
||||
do while
|
||||
(substr(sent,length(sent)) ^= '.');
|
||||
get list (word);
|
||||
sent = sent !! ' ' !! word;
|
||||
end;
|
||||
sent = translate(sent,lower,upper);
|
||||
if verify(sent,lower) ^= 0 then
|
||||
sent = ' that''s an interesting idea.';
|
||||
do i = 1 to nwords;
|
||||
j = index(sent,negative(i));
|
||||
if j ^= 0 then
|
||||
sent = substr(sent,1,j-1) !!
|
||||
positive(i) !!
|
||||
substr(sent,j+length(negative(i)));
|
||||
end;
|
||||
put list('Actually,'!!sent);
|
||||
put skip;
|
||||
end;
|
||||
|
||||
end optimist;
|
||||
|
||||
|
616
Digital Research PLI-86 v1/PCCALLS.PLI
Normal file
616
Digital Research PLI-86 v1/PCCALLS.PLI
Normal file
@ -0,0 +1,616 @@
|
||||
diotest: 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 functions. The tests are not *
|
||||
* particularly complicated, and may be considered as examples for using *
|
||||
* direct DOS function calls with PL/I-86. *
|
||||
* *
|
||||
*****************************************************************************/
|
||||
/* *
|
||||
* IT IS STRONGLY RECOMMENDED THAT YOU STUDY THE IBM DOS MANUAL FOR COMPLETE *
|
||||
* INFORMATION REGARDING THESE FUNCTIONS. *
|
||||
* *
|
||||
*****************************************************************************/
|
||||
|
||||
/* DIOMOD.DCL contains the declarations for the DOS functions */
|
||||
%include 'diomod.dcl';
|
||||
|
||||
%replace true by '1'b, false by '0'b;
|
||||
|
||||
declare /* various miscellaneous variables */
|
||||
(action,ret_code) fixed(7),
|
||||
(i,j) fixed,
|
||||
fname_ptr pointer,
|
||||
flag bit,
|
||||
ptr_val bit(16),
|
||||
(c,inp) char(1),
|
||||
(newname,oldname) char(14) var,
|
||||
fname char(14) based(fname_ptr),
|
||||
(space1(37),space2(37)) bit(8),
|
||||
v char(127) var;
|
||||
|
||||
declare /* command line buffer */
|
||||
1 inbuff static,
|
||||
2 maxsize bit(8) initial('80'b4),
|
||||
2 inchars character(127) varying;
|
||||
|
||||
declare /* fixed location values */
|
||||
memptrv pointer,
|
||||
memsizv fixed,
|
||||
(fcb1_ptr, dbuff_ptr) pointer,
|
||||
command character(127) varying based (dbuff_ptr);
|
||||
|
||||
declare /* Standard File Control Block (FCB) */
|
||||
fcb_ptr pointer,
|
||||
1 std_fcb based(fcb_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 /* FCB used with #17, #18 SEAR & SEARN */
|
||||
srch_fcb_ptr pointer,
|
||||
1 srch_fcb based(srch_fcb_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 /* FCB used in RENAME (#23) */
|
||||
modfcb_ptr pointer,
|
||||
1 modified_fcb based(modfcb_ptr), /* offset:*/
|
||||
2 drive fixed(7), /* 0 */
|
||||
2 name character(8), /* 1-8 */
|
||||
2 type character(3), /* 9-11 */
|
||||
2 space(5) bit(8), /* 12-16 */
|
||||
2 new_name char(8), /* 17-24 */
|
||||
2 new_type char(3), /* 25-27 */
|
||||
2 more_space(9) bit(8); /* 28-36 */
|
||||
|
||||
/*****************************************************************************
|
||||
* M a i n P r o g r a m *
|
||||
*****************************************************************************/
|
||||
|
||||
put skip list('************************************************************
|
||||
******************');
|
||||
put skip list('*
|
||||
*');
|
||||
put skip list('* 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 *');
|
||||
put skip list('*
|
||||
*');
|
||||
put skip list('*************************************************************
|
||||
*****************');
|
||||
put skip(2);
|
||||
|
||||
/*****************************************************************************/
|
||||
/*** Fixed Location Tests: MEMPTR, MEMSIZ, MEMWDS, DFCB0, DFCB1, DBUFF ***/
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Fixed Location Values') then do;
|
||||
memptrv = memptr();
|
||||
memsizv = memsiz();
|
||||
fcb_ptr = dfcb0();
|
||||
fcb1_ptr = dfcb1();
|
||||
dbuff_ptr = dbuff();
|
||||
|
||||
put edit ('Command Tail: ',command) (a);
|
||||
put edit ('First Default File:',std_fcb.name,'.',std_fcb.type)
|
||||
(skip,4a);
|
||||
put edit ('First Default FCB: ',unspec(fcb_ptr),
|
||||
'Second Default FCB: ',unspec(fcb1_ptr),
|
||||
'Default Buffer: ',unspec(dbuff_ptr),
|
||||
'Base of Free Memory: ',unspec(memptrv),
|
||||
'Memory Size in bytes: ',unspec(memsizv),
|
||||
'Memory Size in words: ',memwds())
|
||||
(5(skip,a,b4),skip,a,f(6));
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/*** #0 REBOOT ***/
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Reboot (#0)') then call reboot();
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #1 RDCON, #2 WRCON */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Read & Write Console (#1,#2)') then do;
|
||||
put list('Type Input, End with "$" ');
|
||||
v = '';
|
||||
flag = true;
|
||||
do while(flag);
|
||||
c = rdcon();
|
||||
if c ^= '$' then v = v || c;
|
||||
else flag = false;
|
||||
end;
|
||||
put skip list('You Typed:');
|
||||
do i = 1 to length(v);
|
||||
call wrcon(substr(v,i,1));
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #3, #4 RDRDR, WRPUN */
|
||||
/*****************************************************************************/
|
||||
/* THESE FUNCTIONS HAVE NOT BEEN TESTED. */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #5 WRLST */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Write List Device (#5)') then do;
|
||||
v = 'This is a test of IBM DOS function 5: Printer Output';
|
||||
put list('Turn on Printer....');
|
||||
do i = 1 to length(v);
|
||||
call wrlst(substr(v,i,1));
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #6 Direct I/O, CONOUT, CONINP */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Direct I/O (#6)') then do;
|
||||
put skip list('This test will get and print characters one at a time');
|
||||
put skip list('using direct input and output.');
|
||||
put list ('Type Line, End with "$"');
|
||||
flag = true;
|
||||
do while (flag);
|
||||
loop: c = coninp();
|
||||
if rank(c) = 0 then goto loop;
|
||||
if c ^= '$' then call conout(c);
|
||||
else flag = false;
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #7 DIN1, #8 DIN2 Direct Input */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Direct Input Without Echo (#7,#8)') then do;
|
||||
v = '';
|
||||
/* function 7: */
|
||||
put skip list(
|
||||
'NOTE: Input will NOT print on screen for these 2 functions.');
|
||||
put skip list(
|
||||
'Function #9 Print String will be used to display the input.');
|
||||
put skip list('Function #7: Type a string, end with "$":');
|
||||
put skip;
|
||||
flag = true;
|
||||
do while(flag);
|
||||
c = din1();
|
||||
v = v || c;
|
||||
if c = '$' then flag = false;
|
||||
end;
|
||||
put skip list('You Typed: ');
|
||||
call wrstr(inc_ptr(addr(v)));
|
||||
v = '';
|
||||
/* function 8: */
|
||||
put skip list('Function #8: Type a string, end with "$":');
|
||||
flag = true;
|
||||
do while(flag);
|
||||
c = din1();
|
||||
v = v || c;
|
||||
if c = '$' then flag = false;
|
||||
end;
|
||||
put skip list('You Typed: ');
|
||||
call wrstr(inc_ptr(addr(v)));
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #9 Print String WRSTR */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Print String (#9)') then do;
|
||||
v = 'This is a test of IBM DOS function 9: Print String.$';
|
||||
call wrstr(inc_ptr(addr(v)));
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #10 Buffered Read RDBUF */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Buffered Keyboard Input (#10)') then do;
|
||||
put skip list('Type Line, End With <CR>');
|
||||
put skip;
|
||||
call rdbuf(addr(inbuff));
|
||||
put skip list('You Typed: ',inchars);
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #11 Console BREAK */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Keyboard Status Check (#11)') then do;
|
||||
put skip list('Press any key to continue');
|
||||
ret_code = 0;
|
||||
do while(ret_code = 0);
|
||||
ret_code = break();
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #12a CLRKB1 Clear Keyboard & Invoke Input Funtion */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Clear Keyboard & Invoke Input Function (#12a)') then do;
|
||||
put skip list('This function clears the keyboard buffer and');
|
||||
put list(' invokes a keyboard input routine,');
|
||||
put skip list('in this case, function 1.');
|
||||
put skip list('Enter Text, end with <CR>');
|
||||
c = ' ';
|
||||
v = '';
|
||||
flag = true;
|
||||
do while(flag);
|
||||
c = clrkb1(1);
|
||||
if (rank(c) = 13 | rank(c) = 10) then flag = false;
|
||||
else v = v || c;
|
||||
end;
|
||||
put skip list('You Typed: ',v);
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #12b CLRKB2 Clear Keyboard & Invoke Input Function #2 */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Clear Keyboard & Invoke Input Function (#12b)') then do;
|
||||
put skip list('This version of function #12 clears the keyboard');
|
||||
put list('buffer and invokes keyboard input routine function 10.');
|
||||
put skip list('Enter Text, end with <CR>');
|
||||
call clrkb2(10,addr(inbuff));
|
||||
put skip list('You Typed: ',inchars);
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #13 Disk System RESET */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Disk System Reset (#13)') then do;
|
||||
call reset();
|
||||
put skip list('Disk System has been reset.');
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #14 Disk SELECT */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Select Disk Function (#14)') then do;
|
||||
put skip list('Select Disk Number (0 or 1): ');
|
||||
get list(i);
|
||||
j = select(i);
|
||||
put skip list('Number of drives:',j);
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #15, #16 OPEN, CLOSE */
|
||||
/*****************************************************************************/
|
||||
/* These functions are tested in PCSEQ.PLI, PCRND.PLI, PCRNDBL.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #17, #18 SEAR, SEARN */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Search First/Search Next (#17,#18)') then do;
|
||||
do i = 1 to 37;
|
||||
space1(i) = '00'b4;
|
||||
space2(i) = '00'b4;
|
||||
end;
|
||||
fcb_ptr = dbuff(); /* set up default FCB */
|
||||
srch_fcb_ptr = addr(space1); /* set up search FCB out in memory */
|
||||
srch_fcb.drive = 0; /* default drive */
|
||||
srch_fcb.name = '????????'; /* wildcard name */
|
||||
srch_fcb.type = '???'; /* wildcard type */
|
||||
/* find the first entry in the directory */
|
||||
ret_code = sear(srch_fcb_ptr);
|
||||
if ret_code = -1 then do;
|
||||
put skip list('No Files Found');
|
||||
call reboot();
|
||||
end;
|
||||
/* search through directory, printing names */
|
||||
do while(ret_code >= 0);
|
||||
put skip edit(std_fcb.name,'.',std_fcb.type) (a,a,a);
|
||||
ret_code = searn(srch_fcb_ptr);
|
||||
end;
|
||||
put skip list('End of Directory');
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/*** #19 DELETE (& #41 PARSFN) ***/
|
||||
/*****************************************************************************/
|
||||
/* This test also uses PARSFN, function #41. */
|
||||
do i = 1 to 37;
|
||||
space1(i) = '00'b4;
|
||||
space2(i) = '00'b4;
|
||||
end;
|
||||
fcb_ptr = addr(space1);
|
||||
if do_test('Test Delete File') then do;
|
||||
put skip list('Enter Name of File to DELETE: ');
|
||||
get edit(fname) (a);
|
||||
/* use PARSFN to put the filename in the FCB */
|
||||
ret_code = parsfn(addr(fname_ptr),addr(fcb_ptr),action);
|
||||
if ret_code ^= 0 then do;
|
||||
put skip list('Error- PARSFN returned ',ret_code);
|
||||
call reboot();
|
||||
end;
|
||||
/* FCB is now ready for DELETE */
|
||||
ret_code = delete(addr(std_fcb));
|
||||
if ret_code ^= 0 then do;
|
||||
put skip list('Error- DELETE returned ',ret_code);
|
||||
call reboot();
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #20, #21, #22 RDSEQ, WRSEQ, MAKE */
|
||||
/*****************************************************************************/
|
||||
/* These functions are tested in PCSEQ.PLI, PCRND.PLI, PCRNDBL.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #23 RENAME */
|
||||
/*****************************************************************************/
|
||||
do i = 1 to 37;
|
||||
space1(i) = '00'b4;
|
||||
space2(i) = '00'b4;
|
||||
end;
|
||||
modfcb_ptr = addr(space2);
|
||||
if do_test('Test Rename File') then do;
|
||||
put skip list('Enter OLD File Name: ');
|
||||
get edit(oldname) (a);
|
||||
put skip list('Enter NEW File Name: ');
|
||||
get edit(newname) (a);
|
||||
/* split up name & type; make sure they're the right length, padded
|
||||
with trailing blanks if necessary */
|
||||
i = index(oldname,'.');
|
||||
modified_fcb.name = substr(oldname,1,i-1) || ' ';
|
||||
modified_fcb.name = substr(modified_fcb.name,1,8);
|
||||
modified_fcb.type = substr(oldname,i+1) || ' ';
|
||||
modified_fcb.type = substr(modified_fcb.type,1,3);
|
||||
/* do the same for the new name */
|
||||
i = index(newname,'.');
|
||||
modified_fcb.new_name = substr(newname,1,i-1) || ' ';
|
||||
modified_fcb.new_name = substr(modified_fcb.new_name,1,8);
|
||||
modified_fcb.new_type = substr(newname,i+1,3) || ' ';
|
||||
modified_fcb.new_type = substr(modified_fcb.new_type,1,3);
|
||||
/* FCB is set up; do the call */
|
||||
ret_code = rename(addr(modified_fcb));
|
||||
if ret_code ^= 0 then do;
|
||||
put skip list('Error- RENAME returned ',ret_code);
|
||||
call reboot();
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #24 NOT USED in IBM DOS */
|
||||
/*****************************************************************************/
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #25 CURDSK */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Current Disk Function (#25)') then do;
|
||||
put skip list ('Current Disk: ',curdsk());
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #26 SETDMA */
|
||||
/*****************************************************************************/
|
||||
/* This functions is tested in PCSEQ.PLI, PCRND.PLI, PCRNDBL.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #27 File Allocation Table ALLTBL */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Allocation Table Address (#27)') then do;
|
||||
declare fat(512) bit(1),
|
||||
(num_units,num_recs,sec_size) fixed;
|
||||
call alltbl(addr(fat),addr(num_units),addr(num_recs),addr(sec_size));
|
||||
put skip list('File Allocation Table Information:');
|
||||
put skip edit('Table Location: ',unspec(fat)) (a,b4(4));
|
||||
put skip edit('Number of Allocation Units: ',num_units) (a,f(6));
|
||||
put skip edit('Number of Records per Allocation Unit: ',num_recs)
|
||||
(a,f(6));
|
||||
put skip edit('Physical Sector Size: ',sec_size) (a,f(6));
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #28-#32 NOT USED in IBM DOS */
|
||||
/*****************************************************************************/
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #33, #34 RDRAN, WRRAN */
|
||||
/*****************************************************************************/
|
||||
/* These functions are tested in PCRND.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #35 FILSIZ */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test File Size Function (#35)') then do;
|
||||
do i = 1 to 37;
|
||||
space1(i) = '00'b4;
|
||||
space2(i) = '00'b4;
|
||||
end;
|
||||
fcb_ptr = addr(space1);
|
||||
put skip list('Enter Name of File: ');
|
||||
get edit(fname) (a);
|
||||
/* use PARSFN to put the filename in the FCB */
|
||||
action = 1;
|
||||
ret_code = parsfn(addr(fname_ptr),addr(fcb_ptr),action);
|
||||
if ret_code ^= 0 then do;
|
||||
put skip list('Error- PARSFN returned ',ret_code);
|
||||
call reboot();
|
||||
end;
|
||||
ret_code = filsiz(addr(std_fcb));
|
||||
if ret_code ^= 0 then do;
|
||||
put skip list('SIZE error');
|
||||
call reboot();
|
||||
end;
|
||||
/* file size in records is in random record field */
|
||||
put skip list('File Size = ');
|
||||
put edit(std_fcb.rand_rec_no(2),' ',std_fcb.rand_rec_no(1))
|
||||
(b4(4),a,b4(4));
|
||||
put edit(' hex records.') (a);
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #36 SETREC */
|
||||
/*****************************************************************************/
|
||||
/* This function is used in PCRNDBL.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #37 Set Interrupt Vector */
|
||||
/*****************************************************************************/
|
||||
/* THIS FUNCTION IS NOT IMPLEMENTED */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #38 NEWSEG */
|
||||
/*****************************************************************************/
|
||||
/* THIS FUNCTION HAS NOT BEEN TESTED. It is not usable with PL/I-86 */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #39, #40 BLOCKRD, BLOCKWR */
|
||||
/*****************************************************************************/
|
||||
/* These functions are used in PCRNDBL.PLI */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #41 PARSFN */
|
||||
/*****************************************************************************/
|
||||
/* See #19 DELETE and #35 FILSIZ, above */
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #42 Get Date GETDATE, #43 Set Date SETDATE */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Set/Get Date Functions (#42,#43)') then do;
|
||||
declare year fixed(15),
|
||||
(month,day) fixed(7);
|
||||
put skip list('Enter MONTH (1-12): ');
|
||||
get list(month);
|
||||
put skip list('Enter DAY (1-31): ');
|
||||
get list(day);
|
||||
put skip list('Enter YEAR (1980-2099): ');
|
||||
get list(year);
|
||||
ret_code = setdate(year,month,day);
|
||||
if ret_code ^= 0 then put skip list('ERROR- Date NOT set');
|
||||
else do;
|
||||
put skip list('Date is now set to ');
|
||||
call getdate(addr(year),addr(month),addr(day));
|
||||
put edit(month,'/',day,' ',year) (f(2),a,f(2),a,f(4));
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #44 Get Time GETTIME, #45 Set Time SETTIME */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Set/Get Time Function (#44,#45)') then do;
|
||||
declare (hour,minute,second,fraction) fixed(7);
|
||||
put skip list('Enter HOUR: ');
|
||||
get list(hour);
|
||||
put skip list('Enter MINUTE: ');
|
||||
get list(minute);
|
||||
second = 0;
|
||||
fraction = 0;
|
||||
put skip list('Press <ENTER> to set time ==>');
|
||||
get edit(inp) (a);
|
||||
ret_code = settime(hour,minute,second,fraction);
|
||||
if ret_code ^= 0 then put skip list('ERROR- time NOT set');
|
||||
else do;
|
||||
call gettime(addr(hour),addr(minute),addr(second),addr(fraction));
|
||||
put skip list('The time is now ');
|
||||
put edit(hour,':',minute,':',second,'.',fraction)
|
||||
(f(2),a,f(2),a,f(2),a,f(2));
|
||||
end;
|
||||
end;
|
||||
|
||||
/*****************************************************************************/
|
||||
/* #46 Set/Reset Verify Switch SETVER */
|
||||
/*****************************************************************************/
|
||||
if do_test('Test Set/Reset Verify Switch Function (#46)') then do;
|
||||
/* turn on verify */
|
||||
call setver(1);
|
||||
put skip list('Verify is now on');
|
||||
/* turn it back off */
|
||||
call setver(2);
|
||||
put skip list('Verify is now off');
|
||||
end;
|
||||
|
||||
put skip list('End of Direct DOS Calls Test');
|
||||
call reboot();
|
||||
|
||||
/*****************************************************************************
|
||||
* P r o c e d u r e s *
|
||||
*****************************************************************************/
|
||||
|
||||
/*****************************************************************************/
|
||||
/* Input function- used to decide whether or not to do a test */
|
||||
/*****************************************************************************/
|
||||
do_test: procedure(msg) returns(bit(1));
|
||||
declare
|
||||
msg char(254) var,
|
||||
inval char(1);
|
||||
put skip;
|
||||
put skip edit(msg,' (Y/N)? ') (a,a);
|
||||
get list(inval);
|
||||
if translate(inval,'Y','y') = 'Y' then return(true);
|
||||
else return(false);
|
||||
end;
|
||||
|
||||
inc_ptr: procedure(old_ptr) returns(pointer);
|
||||
/* This procedure is used to increment a pointer by 1. This has the effect
|
||||
of skipping over 1 byte in memory. Varying length strings are preceded
|
||||
by a length byte, so when using direct DOS functions to print strings,
|
||||
this byte must be skipped. */
|
||||
declare
|
||||
(new_ptr,old_ptr) pointer,
|
||||
ptr_val bit(16);
|
||||
ptr_val = unspec(old_ptr); /* get a 16-bit value for pointer */
|
||||
ptr_val = add(ptr_val,'0001'b4); /* add 1 to value */
|
||||
unspec(new_ptr) = ptr_val; /* turn it back into a pointer */
|
||||
return(new_ptr);
|
||||
end inc_ptr;
|
||||
|
||||
/*****************************************************************************
|
||||
* 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 *
|
||||
*****************************************************************************/
|
||||
|
||||
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 diotest;
|
||||
|
651
Digital Research PLI-86 v1/PCDIO.A86
Normal file
651
Digital Research PLI-86 v1/PCDIO.A86
Normal file
@ -0,0 +1,651 @@
|
||||
;******************************************************************************
|
||||
;* *
|
||||
;* P C D I O *
|
||||
;* *
|
||||
;* D i r e c t I B M D O S C a l l s F r o m P L / I - 8 6 *
|
||||
;* *
|
||||
;******************************************************************************
|
||||
|
||||
DSEG
|
||||
extrn ?begin:word ;beginning of free list
|
||||
|
||||
CSEG
|
||||
public dfcb0 ;return address of default fcb 0
|
||||
public dfcb1 ;return address of default fcb 1
|
||||
public dbuff ;return address of default buffer
|
||||
|
||||
public memptr ;return pointer to base of free memory
|
||||
public memsiz ;return size of memory in bytes
|
||||
public memwds ;return size of memory in words
|
||||
|
||||
public reboot ;program terminate (reboot) (#0)
|
||||
public rdcon ;keyboard input (#1)
|
||||
public wrcon ;display output (#2)
|
||||
public rdrdr ;auxiliary input (#3)
|
||||
public wrpun ;auxiliary output (#4)
|
||||
public wrlst ;printer output (#5)
|
||||
public coninp ;direct console input (#6a)
|
||||
public conout ;direct console output (#6b)
|
||||
public din1 ;direct console input w/o echo (#7)
|
||||
public din2 ;console input w/o echo (#8)
|
||||
public wrstr ;print string (#9)
|
||||
public rdbuf ;buffered keyboard input (#10)
|
||||
public break ;check keyboard status (#11)
|
||||
public clrkb1 ;clear keyboard buffer & invoke fcn 1,6,7, or 8 (#12a)
|
||||
public clrkb2 ;clear keyboard buffer & invoke fcn 10 (#12b)
|
||||
public reset ;disk reset (#13)
|
||||
public select ;select disk (#14)
|
||||
public open ;open file (#15)
|
||||
public close ;close file (#16)
|
||||
public sear ;search for first entry (#17)
|
||||
public searn ;search for next entry (#18)
|
||||
public delete ;delete file (#19)
|
||||
public rdseq ;sequential read (#20)
|
||||
public wrseq ;sequential write (#21)
|
||||
public make ;create file (#22)
|
||||
public rename ;rename file (#23)
|
||||
;not used (#24)
|
||||
public curdsk ;current disk (#25)
|
||||
public setdma ;set disk transfer address (#26)
|
||||
public alltbl ;allocation table address (#27)
|
||||
;not used (#28-32)
|
||||
public rdran ;random read (#33)
|
||||
public wrran ;random write (#34)
|
||||
public filsiz ;file size (#35)
|
||||
public setrec ;set random record field (#36)
|
||||
;public setint ;set interrupt vector (#37) NOT IMPLEMENTED
|
||||
public newseg ;create new program segment (#38)
|
||||
public blockrd ;random block read (#39)
|
||||
public blockwr ;random block write (#40)
|
||||
public parsfn ;parse filename (#41)
|
||||
public getdate ;get date (#42)
|
||||
public setdate ;set date (#43)
|
||||
public gettime ;get time (#44)
|
||||
public settime ;set time (#45)
|
||||
public setver ;set/reset verify switch (#46)
|
||||
|
||||
;******************************************************************************
|
||||
;* F u n c t i o n N u m b e r s & O t h e r E q u a t e s *
|
||||
;******************************************************************************
|
||||
rdkeyf equ 1 ;keyboard input (#1)
|
||||
writc equ 2 ;display output (#2)
|
||||
rdauxf equ 3 ;auxiliary input (#3)
|
||||
wrauxf equ 4 ;auxiliary output (#4)
|
||||
prtf equ 5 ;printer output (#5)
|
||||
diof equ 6 ;direct console I/O (#6)
|
||||
din1f equ 7 ;direct console input w/o echo (#7)
|
||||
din2f equ 8 ;console input w/o echo (#8)
|
||||
printf equ 9 ;print string (#9)
|
||||
rdbufr equ 10 ;buffered keyboard input (#10)
|
||||
statf equ 11 ;check keyboard status (#11)
|
||||
clrbuff equ 12 ;clear keyboard buffer (#12)
|
||||
resetf equ 13 ;disk reset (#13)
|
||||
seldf equ 14 ;select disk (#14)
|
||||
openf equ 15 ;open file (#15)
|
||||
closef equ 16 ;close file (#16)
|
||||
serchf equ 17 ;search for first entry (#17)
|
||||
serchn equ 18 ;search for next entry (#18)
|
||||
deletf equ 19 ;delete file (#19)
|
||||
readf equ 20 ;sequential read (#20)
|
||||
writf equ 21 ;sequential write (#21)
|
||||
makef equ 22 ;create file (#22)
|
||||
renamf equ 23 ;rename file (#23)
|
||||
cdiskf equ 25 ;current disk (#25)
|
||||
setdtf equ 26 ;set disk transfer address (#26)
|
||||
getalf equ 27 ;allocation table address (#27)
|
||||
rdranf equ 33 ;random read (#33)
|
||||
wrranf equ 34 ;random write (#34)
|
||||
filszf equ 35 ;file size (#35)
|
||||
setrcf equ 36 ;set random record field (#36)
|
||||
setintf equ 37 ;set interrupt vector (#37)
|
||||
newsgf equ 38 ;create new program segment (#38)
|
||||
blkrdf equ 39 ;random block read (#39)
|
||||
blkwrf equ 40 ;random block write (#40)
|
||||
parsf equ 41 ;parse filename (#41)
|
||||
gdatef equ 42 ;get date (#42)
|
||||
sdatef equ 43 ;set date (#43)
|
||||
gtimef equ 44 ;get time (#44)
|
||||
stimef equ 45 ;set time (#45)
|
||||
setverf equ 46 ;set/reset verify switch (#46)
|
||||
|
||||
;******************************************************************************
|
||||
;* *
|
||||
;* G e n e r a l P u r p o s e R o u t i n e s *
|
||||
;* *
|
||||
;******************************************************************************
|
||||
|
||||
?pcdos: ;the call to IBM DOS
|
||||
int 21h ;DOS interrupt number
|
||||
ret
|
||||
|
||||
getp1: ;get single byte parameter to register DL
|
||||
mov bx,[bx] ;BX = pointer to char
|
||||
mov dl,[bx] ;to register DL
|
||||
ret
|
||||
|
||||
getp2: ;get single word value to DX
|
||||
getp2i: ;(equivalent to getp2)
|
||||
mov bx,[bx]
|
||||
mov dx,[bx]
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* *
|
||||
;* T h e I B M D O S R o u t i n e s *
|
||||
;* *
|
||||
;******************************************************************************
|
||||
|
||||
;******************************************************************************
|
||||
;* M E M P T R *
|
||||
;******************************************************************************
|
||||
memptr: ;return pointer to base of free storage
|
||||
mov bx,?begin
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* M E M S I Z *
|
||||
;******************************************************************************
|
||||
memsiz: ;return size of free memory in bytes
|
||||
mov bx,word ptr .6 ;top of available memory
|
||||
sub bx,?begin ;subtract beginning of free storage
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* M E M W D S *
|
||||
;******************************************************************************
|
||||
memwds: ;return size of free memory in words
|
||||
call memsiz ;BX = size in bytes
|
||||
shr bx,1 ;BX = size in words
|
||||
ret ;with words in BX
|
||||
|
||||
;******************************************************************************
|
||||
;* D F C B 0 *
|
||||
;******************************************************************************
|
||||
dfcb0: ;return address of default fcb 0
|
||||
mov bx,5ch
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* D F C B 1 *
|
||||
;******************************************************************************
|
||||
dfcb1: ;return address of default fcb 1
|
||||
mov bx,6ch
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* D B U F F *
|
||||
;******************************************************************************
|
||||
dbuff: ;return address of default buffer
|
||||
mov bx,80h
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* REBOOT #0 *
|
||||
;******************************************************************************
|
||||
reboot: ;system reboot (#0)
|
||||
;Location 40h in the base page has the INT 20h needed to
|
||||
;reboot. This routine sets up an offset of 0 with that
|
||||
;segment and jumps to it, executing the INT 20.
|
||||
mov word ptr .3eh,0 ;set up an offset of zero...
|
||||
jmpf dword ptr .3eh ;jump to it
|
||||
|
||||
;******************************************************************************
|
||||
;* R D C O N #1 *
|
||||
;******************************************************************************
|
||||
rdcon: ;read console character (#1)
|
||||
;return character value to stack
|
||||
mov ah,rdkeyf ;function number
|
||||
jmps chrin ;common code to read char
|
||||
|
||||
;******************************************************************************
|
||||
;* W R C O N #2 *
|
||||
;******************************************************************************
|
||||
wrcon: ;write console character(#2)
|
||||
mov ah,writc ;console write function
|
||||
jmps chrout ;to write the character
|
||||
|
||||
;******************************************************************************
|
||||
;* R D R D R #3 *
|
||||
;******************************************************************************
|
||||
rdrdr: ;read reader character (#3)
|
||||
mov ah,rdauxf ;reader function
|
||||
chrin:
|
||||
;common code for character input
|
||||
call ?pcdos ;value returned to AL
|
||||
chrin2: pop bx ;return address
|
||||
mov ah,al ;char to AH
|
||||
push ax ;character to stack
|
||||
inc sp ;delete garbage byte
|
||||
mov al,1 ;character length is 1
|
||||
jmp bx ;back to calling routine
|
||||
|
||||
;******************************************************************************
|
||||
;* W R P U N #4 *
|
||||
;******************************************************************************
|
||||
wrpun: ;write punch character (#4)
|
||||
mov ah,wrauxf ;punch output function
|
||||
jmps chrout ;common code to write chr
|
||||
|
||||
;******************************************************************************
|
||||
;* W R L S T #5 *
|
||||
;******************************************************************************
|
||||
wrlst: ;write list character (#5)
|
||||
mov ah,prtf ;list output function
|
||||
chrout:
|
||||
;common code to write character
|
||||
call getp1 ;output char to register DL
|
||||
jmp ?pcdos ;to write and return
|
||||
|
||||
;******************************************************************************
|
||||
;* C O N I N P #6A *
|
||||
;******************************************************************************
|
||||
coninp: ;perform console input, char returned in stack (#6a)
|
||||
;returns a zero if no char is ready.
|
||||
mov ah,diof
|
||||
mov dl,0ffh
|
||||
call ?pcdos ;value returned to AL
|
||||
jnz chrin2 ;if a char ready,send it back
|
||||
mov al,0 ;otherwise, return a 0
|
||||
jmp chrin2 ;use common input-return code
|
||||
|
||||
;******************************************************************************
|
||||
;* C O N O U T #6B *
|
||||
;******************************************************************************
|
||||
conout: ;direct console output (#6b)
|
||||
call getp1 ;get parameter to DL
|
||||
mov ah,diof ;direct console I/O
|
||||
jmp ?pcdos
|
||||
|
||||
;******************************************************************************
|
||||
;* D I N 1 #7 *
|
||||
;******************************************************************************
|
||||
din1: ;direct console input without echo (#7)
|
||||
mov ah,din1f
|
||||
jmps chrin ;value returned to AL
|
||||
|
||||
;******************************************************************************
|
||||
;* D I N 2 #8 *
|
||||
;******************************************************************************
|
||||
din2: ;console input without echo (#8)
|
||||
mov ah,din2f
|
||||
jmps chrin ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* W R S T R #9 *
|
||||
;******************************************************************************
|
||||
wrstr: ;write string (#9)
|
||||
call getp2 ;get parameter value to DX
|
||||
mov ah,printf ;print string function
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* R D B U F #10 *
|
||||
;******************************************************************************
|
||||
rdbuf: ;read console buffer (#10)
|
||||
call getp2i ;DX = pointer to buff
|
||||
mov ah,rdbufr ;read console function
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* B R E A K #11 *
|
||||
;******************************************************************************
|
||||
break: ;check keyboard status (#11)
|
||||
;returns FFh if char ready at keyboard, 0 otherwise
|
||||
mov ah,statf
|
||||
jmp ?pcdos ;return thru DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* C L R K B 1 #12A *
|
||||
;******************************************************************************
|
||||
clrkb1: ;clear keyboard buffer & invoke input fcn 1,6,7,8 (#12a)
|
||||
;NOTE: this function does NOT check to make sure only functions
|
||||
;1,6,7,8 are used, as PCDOS will when the call is made.
|
||||
call getp1 ;get function number...
|
||||
mov al,dl ;...to AL
|
||||
mov ah,clrbuff ;function number
|
||||
;fcns 1,7,8 can be done by same code; 6 is different
|
||||
cmp al,1 ;fcn 1?
|
||||
jz chrin ;yes, go do it
|
||||
cmp al,7 ;fcn 7?
|
||||
jz chrin ;do it
|
||||
cmp al,8 ;fcn 8?
|
||||
jz chrin ;do it
|
||||
;must be function 6
|
||||
mov dl,0ffh
|
||||
call ?pcdos ;value returned to AL
|
||||
jnz chrin2 ;if a char ready,send it back
|
||||
mov al,0 ;otherwise, return a 0
|
||||
jmp chrin2 ;use common input-return code
|
||||
|
||||
;******************************************************************************
|
||||
;* C L R K B 2 #12B *
|
||||
;******************************************************************************
|
||||
clrkb2: ;clear keyboard buffer & invoke input fcn 10 (#12b)
|
||||
;this routine is different from the above in that function 10
|
||||
;requires a pointer to an input buffer.
|
||||
mov si,[bx] ;get ptr to 1st parm (fcn#)
|
||||
mov ax,[si] ;fcn# to AL
|
||||
mov si,2[bx] ;ptr to 2nd parm (input buffer pointer)
|
||||
mov dx,[si] ;pointer to input buffer to DX
|
||||
mov ah,clrbuff ;function number
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* R E S E T #13 *
|
||||
;******************************************************************************
|
||||
reset: ;reset disk system (#13)
|
||||
mov ah,resetf
|
||||
jmp ?pcdos
|
||||
|
||||
;******************************************************************************
|
||||
;* S E L E C T #14 *
|
||||
;******************************************************************************
|
||||
select: ;select disk (#14)
|
||||
call getp1 ;disk number to DL
|
||||
mov ah,seldf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* O P E N #15 *
|
||||
;******************************************************************************
|
||||
open: ;open file (#15)
|
||||
call getp2i ;fcb address to DX
|
||||
mov ah,openf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* C L O S E #16 *
|
||||
;******************************************************************************
|
||||
close: ;close file (#16)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,closef
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* S E A R #17 *
|
||||
;******************************************************************************
|
||||
sear: ;search for file (#17)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,serchf
|
||||
jmp ?pcdos
|
||||
|
||||
;******************************************************************************
|
||||
;* S E A R N #18 *
|
||||
;******************************************************************************
|
||||
searn: ;search for next (#18)
|
||||
call getp2 ;get pointer to FCB
|
||||
mov ah,serchn ;search next function
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* D E L E T E #19 *
|
||||
;******************************************************************************
|
||||
delete: ;delete file (#19)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,deletf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* R D S E Q #20 *
|
||||
;******************************************************************************
|
||||
rdseq: ;sequential read (#20)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,readf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* W R S E Q #21 *
|
||||
;******************************************************************************
|
||||
wrseq: ;sequential write (#21)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,writf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* M A K E #22 *
|
||||
;******************************************************************************
|
||||
make: ;create file (#22)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,makef
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* R E N A M E #23 *
|
||||
;******************************************************************************
|
||||
rename: ;rename file (#23)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,renamf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* C U R D S K #25 *
|
||||
;******************************************************************************
|
||||
curdsk: ;return current disk number (#25)
|
||||
mov ah,cdiskf
|
||||
jmp ?pcdos ;return value in AL
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T D M A #26 *
|
||||
;******************************************************************************
|
||||
setdma: ;set DMA address (#26)
|
||||
call getp2 ;dma address to DX
|
||||
mov ah,setdtf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* A L L T B L #27 *
|
||||
;******************************************************************************
|
||||
alltbl: ;return address of allocation table (#27)
|
||||
;first get pointer to FAT to set up destination
|
||||
mov si,[bx] ;get pointer to 1st parm
|
||||
mov di,[si] ;get offset into DI...
|
||||
push ds ;get segment into ES...
|
||||
pop es ;now destination is set
|
||||
;now do the call to PCDOS
|
||||
push bx ;save current BX (will be overwritten)
|
||||
push ds ;save current DS (will be overwritten)
|
||||
mov ah,getalf ;function number
|
||||
call ?pcdos ;do it
|
||||
;set up the source
|
||||
mov bp,ds ;move DS value to BP
|
||||
mov si,bx ;SI gets offset, DS already contains segment
|
||||
;move the FAT
|
||||
push cx ;save CX for later
|
||||
mov cx,512 ;number of bytes to move (size of FAT)
|
||||
rep movsb ;move it
|
||||
;table is moved, now send back other info
|
||||
pop cx ;get back former CX
|
||||
pop ds ;get back former DS
|
||||
pop bx ;and the old BX
|
||||
mov si,2[bx] ;get pointer to 2nd parm
|
||||
mov si,[si] ;get parm
|
||||
mov [si],dx ;put no. of alloc units in 2nd parm
|
||||
mov si,4[bx] ;get pointer to 3rd parm
|
||||
mov si,[si] ;get parm
|
||||
mov [si],al ;put #recs/alloc unit in 3rd parm
|
||||
mov si,6[bx] ;get pointer to 4th parm
|
||||
mov si,[si] ;get parm
|
||||
mov [si],cx ;put size of phys. sect. in 4th parm
|
||||
ret ;done!
|
||||
|
||||
;******************************************************************************
|
||||
;* R D R A N #33 *
|
||||
;******************************************************************************
|
||||
rdran: ;random read (#33)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,rdranf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* W R R A N #34 *
|
||||
;******************************************************************************
|
||||
wrran: ;random write (#34)
|
||||
call getp2i ;FCB pointer to DX
|
||||
mov ah,wrranf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* F I L S I Z #35 *
|
||||
;******************************************************************************
|
||||
filsiz: ;compute file size (#35)
|
||||
call getp2 ;FCB pointer to DX
|
||||
mov ah,filszf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T R E C #36 *
|
||||
;******************************************************************************
|
||||
setrec: ;set random record position (#36)
|
||||
call getp2 ;FCB pointer to DX
|
||||
mov ah,setrcf
|
||||
jmp ?pcdos ;return through DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T I N T #37 *
|
||||
;******************************************************************************
|
||||
;setint: ;set interrupt vector (#37)
|
||||
;NOT IMPLEMENTED
|
||||
|
||||
;******************************************************************************
|
||||
;* N E W S E G #38 *
|
||||
;******************************************************************************
|
||||
newseg: ;create new program segment (#38)
|
||||
; WARNING: This procedure has NOT been tested. Use it at your own risk!
|
||||
call getp2 ;get segment where new prog will start
|
||||
mov ah,newsgf ;function number
|
||||
jmp ?pcdos ;return thru DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* B L O C K R D #39 *
|
||||
;******************************************************************************
|
||||
blockrd: ; Random Block Read (#39)
|
||||
;call blockrd(fcbptr,count,actualptr,retptr)
|
||||
mov si,[bx] ;get pointer to 1st parm (FCB ptr)
|
||||
mov dx,[si] ;put pointer to FCB in DX
|
||||
mov si,2[bx] ;get pointer to 2nd parm (count)
|
||||
mov cx,[si] ;move count to CX
|
||||
mov AH,blkrdf ;random block read function number
|
||||
call ?pcdos ;do it
|
||||
mov si,4[bx] ;get pointer to 3rd parm (actual count)
|
||||
mov si,[si] ;
|
||||
mov [si],cx ;put actual count in 3rd parm
|
||||
mov si,6[bx] ;get pointer to 4th parm (return code)
|
||||
mov si,[si] ;
|
||||
mov [si],al ;put return code in 4th parm
|
||||
ret ;done!
|
||||
|
||||
;******************************************************************************
|
||||
;* B L O C K W R #40 *
|
||||
;******************************************************************************
|
||||
blockwr: ;random block write (#40)
|
||||
;call blockwr(fcbptr,count,actualptr,retptr)
|
||||
mov si,[bx] ;get pointer to 1st parm (FCB ptr)
|
||||
mov dx,[si] ;put pointer to FCB in DX
|
||||
mov si,2[bx] ;get pointer to 2nd parm (count)
|
||||
mov cx,[si] ;move count to CX
|
||||
mov AH,blkwrf ;block write function number
|
||||
call ?pcdos ;do it
|
||||
mov si,4[bx] ;get pointer to 3rd parm (actual count)
|
||||
mov si,[si] ;
|
||||
mov [si],cx ;put actual count in 3rd parm
|
||||
mov si,6[bx] ;get pointer to 4th parm (return code)
|
||||
mov si,[si] ;
|
||||
mov [si],al ;put return code in 4th parm
|
||||
ret ;done!
|
||||
|
||||
;******************************************************************************
|
||||
;* P A R S F N #41 *
|
||||
;******************************************************************************
|
||||
parsfn: ;parse file name (#41)
|
||||
;this function will update the two pointers passed in and return a code
|
||||
;ret_code = PARSFN(addr(comptr),addr(fcbptr),action)
|
||||
mov si,[bx] ;
|
||||
mov si,[si] ;get ptr to ptr to command line...
|
||||
mov si,[si] ;now get ptr to command line in SI
|
||||
mov di,4[bx] ;get 3rd parm
|
||||
mov al,[di] ;move it to AL
|
||||
mov di,2[bx] ;get 2nd parameter...
|
||||
mov di,[di] ;...pointer to pointer to new FCB...
|
||||
mov di,[di] ;...and pointer to new FCB in DI
|
||||
push ds ;copy current DS...
|
||||
pop es ;...to ES
|
||||
mov ah,parsf ;function number
|
||||
jmp ?pcdos ;do it, return through PCDOS
|
||||
|
||||
;******************************************************************************
|
||||
;* G E T D A T E #42 *
|
||||
;******************************************************************************
|
||||
getdate: ;get date (#42)
|
||||
mov ah,gdatef ;function number
|
||||
call ?pcdos ;do it
|
||||
mov si,[bx] ;get pointer to 1st parm (yr)
|
||||
mov si,[si] ;
|
||||
mov [si],cx ;store year
|
||||
mov si,2[bx] ;get pointer to 2nd parm (mo)
|
||||
mov si,[si] ;
|
||||
mov [si],dh ;store month
|
||||
mov si,4[bx] ;get pointer to 3rd parm (day)
|
||||
mov si,[si] ;
|
||||
mov [si],dl ;store day
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T D A T E #43 *
|
||||
;******************************************************************************
|
||||
setdate: ;set date (#43)
|
||||
mov si,[bx] ;get pointer to 1st parm (yr)
|
||||
mov cx,[si] ;put year in CX
|
||||
mov si,2[bx] ;get pointer to 2nd parm (mo)
|
||||
mov dh,[si] ;put month in DH
|
||||
mov si,4[bx] ;get pointer to 3rd parm (day)
|
||||
mov dl,[si] ;put day in DL
|
||||
mov ah,sdatef ;function number
|
||||
jmp ?pcdos ;return thru DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* G E T T I M E #44 *
|
||||
;******************************************************************************
|
||||
gettime: ;get time (#44)
|
||||
mov ah,gtimef ;function number
|
||||
call ?pcdos ;do it
|
||||
mov si,[bx] ;get pointer to 1st parm (hrs)
|
||||
mov si,[si] ;
|
||||
mov [si],ch ;store hours
|
||||
mov si,2[bx] ;get pointer to 2nd parm (min)
|
||||
mov si,[si] ;
|
||||
mov [si],cl ;store minutes
|
||||
mov si,4[bx] ;get pointer to 3rd parm (sec)
|
||||
mov si,[si] ;
|
||||
mov [si],dh ;store seconds
|
||||
mov si,6[bx] ;get pointer to 4th parm (1/100 sec)
|
||||
mov si,[si] ;
|
||||
mov [si],dl ;store 1/100 sec.
|
||||
ret
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T T I M E #45 *
|
||||
;******************************************************************************
|
||||
settime: ;set time (#45)
|
||||
mov si,[bx] ;get pointer to 1st parm (hrs)
|
||||
mov ch,[si] ;put hours in CH
|
||||
mov si,2[bx] ;get pointer to 2nd parm (min)
|
||||
mov cl,[si] ;put minutes in CL
|
||||
mov si,4[bx] ;get pointer to 3rd parm (sec)
|
||||
mov dh,[si] ;put seconds in DH
|
||||
mov si,6[bx] ;get pointer to 4th parm (1/100 sec)
|
||||
mov dl,[si] ;put 1/100 sec in DL
|
||||
mov ah,stimef ;function number
|
||||
jmp ?pcdos ;return thru DOS
|
||||
|
||||
;******************************************************************************
|
||||
;* S E T V E R #46 *
|
||||
;******************************************************************************
|
||||
setver: ;set/reset verify switch (#46)
|
||||
call getp1 ;get parm...
|
||||
mov al,dl ;to AL
|
||||
mov dl,0 ;DL must be zero for call
|
||||
mov ah,setverf ;function number
|
||||
jmp ?pcdos ;return thru DOS
|
||||
|
||||
end
|
||||
|
37719
Digital Research PLI-86 v1/PL1_Language_Programmers_Guide_Dec82.pdf
Normal file
37719
Digital Research PLI-86 v1/PL1_Language_Programmers_Guide_Dec82.pdf
Normal file
File diff suppressed because one or more lines are too long
29093
Digital Research PLI-86 v1/PL1_Language_Reference_Manual_Oct82.pdf
Normal file
29093
Digital Research PLI-86 v1/PL1_Language_Reference_Manual_Oct82.pdf
Normal file
File diff suppressed because one or more lines are too long
BIN
Digital Research PLI-86 v1/PLI.EXE
Normal file
BIN
Digital Research PLI-86 v1/PLI.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/PLI0.OVR
Normal file
BIN
Digital Research PLI-86 v1/PLI0.OVR
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/PLI1.OVR
Normal file
BIN
Digital Research PLI-86 v1/PLI1.OVR
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/PLI2.OVR
Normal file
BIN
Digital Research PLI-86 v1/PLI2.OVR
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/PLILIB.L86
Normal file
BIN
Digital Research PLI-86 v1/PLILIB.L86
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/RASM86.EXE
Normal file
BIN
Digital Research PLI-86 v1/RASM86.EXE
Normal file
Binary file not shown.
273
Digital Research PLI-86 v1/READ.ME
Normal file
273
Digital Research PLI-86 v1/READ.ME
Normal file
@ -0,0 +1,273 @@
|
||||
|
||||
|
||||
|
||||
-----------------------------------------------------
|
||||
W E L C O M E T O P L / I - 8 6
|
||||
-----------------------------------------------------
|
||||
|
||||
|
||||
|
||||
When you purchase this product, you should receive:
|
||||
|
||||
|
||||
o The PL/I Language Reference Manual
|
||||
|
||||
o The PL/I Language Programmer's Guide
|
||||
|
||||
o The Programmer's Utilities Guide for the IBM Personal Computer
|
||||
Disk Operating System
|
||||
|
||||
o Four 5 1/4"" floppy disks containing the software
|
||||
|
||||
|
||||
|
||||
**********************************************************************
|
||||
*********************** DISTRIBUTION DISKS ***********************
|
||||
**********************************************************************
|
||||
|
||||
|
||||
Digital Research distributes PL/I-86 R1.0 for use with the IBM
|
||||
Personal Computer Disk Operating System Version 1.1 on four single-
|
||||
sided 5 1/4" disks containing the following files:
|
||||
|
||||
|
||||
DISK #1
|
||||
|
||||
File Contents
|
||||
|
||||
PLI.CMD PL/I-86 compiler root module
|
||||
PLI0.OVR PL/I-86 compiler overlay
|
||||
PLI1.OVR PL/I-86 compiler overlay
|
||||
PLI2.OVR PL/I-86 compiler overlay
|
||||
|
||||
READ.ME Self-explanatory
|
||||
RELNOTES.PRN Release notes containing latest
|
||||
information about the product
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
DISK #2
|
||||
|
||||
File Contents
|
||||
|
||||
|
||||
|
||||
PCDIO.A86 Assembly language source for
|
||||
direct operating system calls
|
||||
PCCALLS.PLI Direct operating system calls
|
||||
general test program
|
||||
SEQCOPY.PLI Tests sequential I/O using
|
||||
direct operating system calls
|
||||
RNDCOPY.PLI Tests random I/O using direct
|
||||
operating system calls
|
||||
BLOKCOPY.PLI Tests block I/O using direct
|
||||
operating system calls
|
||||
|
||||
DIOMOD.DCL %INCLUDE file used in PCCALLS.PLI
|
||||
FCB.DCL %INCLUDE file used in PCCALLS.PLI
|
||||
|
||||
PLILIB.L86 PL/I-86 Run-time Subroutine Library
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
DISK #3
|
||||
|
||||
File Contents
|
||||
|
||||
A.PLI Sample PL/I program
|
||||
ACK.PLI Sample PL/I program
|
||||
ACKTST.PLI Sample PL/I program
|
||||
ALLTST.PLI Sample PL/I program
|
||||
ANNUITY.PLI Sample PL/I program
|
||||
CALL.PLI Sample PL/I program
|
||||
COPY.PLI Sample PL/I program
|
||||
COPYLPT.PLI Sample PL/I program
|
||||
CREATE.PLI Sample PL/I program
|
||||
DECPOLY.PLI Sample PL/I program
|
||||
DEMO.PLI Sample PL/I program
|
||||
DEPREC.PLI Sample PL/I program
|
||||
DFACT.PLI Sample PL/I program
|
||||
DTEST.PLI Sample PL/I program
|
||||
ENTER.PLI Sample PL/I program
|
||||
EXPR1.PLI Sample PL/I program
|
||||
EXPR2.PLI Sample PL/I program
|
||||
FDTEST.PLI Sample PL/I program
|
||||
FFACT.PLI Sample PL/I program
|
||||
FLTPOLY.PLI Sample PL/I program
|
||||
FLTPOLY2.PLI Sample PL/I program
|
||||
FSCAN.PLI Sample PL/I program
|
||||
IFACT.PLI Sample PL/I program
|
||||
INVERT.PLI Sample PL/I program
|
||||
KEYFILE.PLI Sample PL/I program
|
||||
LABELS.PLI Sample PL/I program
|
||||
LOAN1.PLI Sample PL/I program
|
||||
LOAN2.PLI Sample PL/I program
|
||||
MAININVT.PLI Sample PL/I program
|
||||
NETWORK.PLI Sample PL/I program
|
||||
OPTIMIST.PLI Sample PL/I program
|
||||
REPORT.PLI Sample PL/I program
|
||||
RETRIEVE.PLI Sample PL/I program
|
||||
REVERSE.PLI Sample PL/I program
|
||||
REVERT.PLI Sample PL/I program
|
||||
RFACT.PLI Sample PL/I program
|
||||
SAMPLE.PLI Sample PL/I program
|
||||
TEST.PLI Sample PL/I program
|
||||
UPDATE.PLI Sample PL/I program
|
||||
DIV2.A86 Sample 8086 assembly language program
|
||||
FDIV2.A86 Sample 8086 assembly language program
|
||||
MATSIZE.LIB %INCLUDE file
|
||||
RECORD.DCL %INCLUDE file
|
||||
|
||||
|
||||
|
||||
|
||||
DISK #4
|
||||
|
||||
File Contents
|
||||
|
||||
LIB86.CMD LIB-86 software librarian
|
||||
LINK86.CMD LINK-86 Linkage editor
|
||||
RASM86.CMD RASM-86 Relocating 8086 assembler
|
||||
XREF86.CMD XREF-86 cross reference utility
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
**********************************************************************
|
||||
*********************** CONFIGURING YOUR SYSTEM ********************
|
||||
**********************************************************************
|
||||
|
||||
|
||||
|
||||
If you want to program only in PL/I and do not need the relocating
|
||||
assembler RASM-86, we suggest the following configuration:
|
||||
|
||||
o DISK #1 The compiler root (PLI.CMD) and overlays (PLI0.OVR,
|
||||
PLI1.OVR, PLI2.OVR)
|
||||
|
||||
o DISK #2 The linker (LINK86.CMD) and the Run-time Subroutine
|
||||
Library (PLILIB.L86)
|
||||
|
||||
|
||||
This is only a suggestion. You can configure your system to suit your
|
||||
individual needs.
|
||||
|
||||
|
||||
**********************************************************************
|
||||
************************** RELEASE NOTES ***************************
|
||||
**********************************************************************
|
||||
|
||||
|
||||
|
||||
The file RELNOTES.PRN contains the latest information regarding this
|
||||
product. You should read this file before using the software.
|
||||
|
||||
|
||||
**********************************************************************
|
||||
**************************** PROBLEMS ******************************
|
||||
**********************************************************************
|
||||
|
||||
|
||||
|
||||
We call your attention to the enclosed Software Performance Report
|
||||
(SPR). Should you encounter a problem with the software, please use
|
||||
the SPR, and enclose a listing of the source code, the compilation,
|
||||
and/or the run-time output for the smallest test case that generates
|
||||
the problem.
|
||||
|
||||
We also call your attention to the Reader Comment Form in the back of
|
||||
each of the manuals in the documentation set. Please let us know of
|
||||
any errors, or omissions in the documentation so we incorporate them
|
||||
into subsequent printings.
|
||||
|
||||
Thank you for purchasing PL/I-86. We are sure you will find it the
|
||||
most powerful and sophisticated programming language you've ever used.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
9
Digital Research PLI-86 v1/RECORD.DCL
Normal file
9
Digital Research PLI-86 v1/RECORD.DCL
Normal file
@ -0,0 +1,9 @@
|
||||
dcl
|
||||
1 record,
|
||||
2 name character(30) varying,
|
||||
2 addr character(30) varying,
|
||||
2 city character(20) varying,
|
||||
2 state character(10) varying,
|
||||
2 zip fixed decimal(6),
|
||||
2 phone character(12) varying;
|
||||
|
199
Digital Research PLI-86 v1/RELNOTES.PRN
Normal file
199
Digital Research PLI-86 v1/RELNOTES.PRN
Normal file
@ -0,0 +1,199 @@
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
*********************** ***********************
|
||||
*********************** PL/I-86 Release 1.0 ***********************
|
||||
*********************** For use with ***********************
|
||||
********* The IBM Personal Computer Disk Operating System ***********
|
||||
************************** Version 1.1 ******************************
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
*********** ************
|
||||
******** Release Notes *********
|
||||
******* ********
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
******* *******
|
||||
******* Copyright (c) 1983 by Digital Research *******
|
||||
******* *******
|
||||
******* CP/M-86 is a trademark of Digital Research. *******
|
||||
******* PL/I-86 is a trademark of Digital Research. *******
|
||||
******* IBM is a tradename of International Business Machines. *******
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
***** *****
|
||||
***** These release notes provide the most current information *****
|
||||
***** regarding both the software and the documentation set for *****
|
||||
***** for the Digital Research product, PL/I-86. *****
|
||||
***** *****
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
***********************************************************************
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1
|
||||
|
||||
|
||||
|
||||
***********************************************************************
|
||||
************************* SOFTWARE NOTES ****************************
|
||||
***********************************************************************
|
||||
|
||||
|
||||
DOS
|
||||
|
||||
IBM Personal Computer DOS V1.1 does not interpret ANSI standard escape
|
||||
sequences. Consequently, programs that attempt to handle displays via
|
||||
escape sequences for cursor control will not run properly.
|
||||
|
||||
|
||||
PL/I-86 R1.0
|
||||
|
||||
The following features are described in the PL/I Language Reference
|
||||
Manual, but are NOT implemented in PL/I-86 R1.0 running under DOS:
|
||||
|
||||
o Double-precision FLOAT BINARY data
|
||||
|
||||
o File password protection in the ENVIRONMENT option
|
||||
|
||||
o File and record locking using the built-in LOCK and UNLOCK
|
||||
functions.
|
||||
|
||||
o The error messages emitted by the compiler during Pass 1 and Pass
|
||||
2 are the same error messages used in PL/I-86 R1.0 running under
|
||||
CP/M-86. Appendix E.2 states that there are new error messages in
|
||||
Pass 1 and Pass 2. The new error messages will be included in
|
||||
Release 1.1.
|
||||
|
||||
|
||||
RASM-86 R1.0
|
||||
|
||||
The following features are described in the Programmer's Utilities
|
||||
Guide, but are NOT implemented in RASM-86 R1.0 running under DOS:
|
||||
|
||||
o Release 1.0 does not implement the Stack, Local, and Absolute
|
||||
combine types (see Section 3.2.3).
|
||||
|
||||
o Release 1.0 does not implement user-defined class names (Section
|
||||
3.2.4).
|
||||
|
||||
|
||||
LINK-86 R1.0
|
||||
|
||||
The following features are described in the Programmer's Utilities
|
||||
Guide, but are NOT implemented in LINK-86 R1.0 running under DOS:
|
||||
|
||||
o Release 1.0 does not implement the Class, Group, Origin, and
|
||||
Segment command-line options (Sections 7.7.1 and 7.7.3).
|
||||
|
||||
o The general-purpose overlay manager OVLMGR.OBJ is not included in
|
||||
R1.0. The PL/I-86 Run-time Subroutine Library (PLILIB.L86)
|
||||
includes an overlay manager.
|
||||
|
||||
|
||||
Note: The features that are not included in R1.0 have no impact on the
|
||||
PL/I-86 programmer. They will be implemented in future versions.
|
||||
|
||||
|
||||
|
||||
|
||||
2
|
||||
|
||||
|
||||
|
||||
***********************************************************************
|
||||
*************************** SOFTWARE BUGS ***************************
|
||||
***********************************************************************
|
||||
|
||||
|
||||
The following are known software bugs in PL/I-86 R1.0 running under
|
||||
DOS:
|
||||
|
||||
o An array reference such as
|
||||
|
||||
A(constant-expression) = constant;
|
||||
|
||||
gives a compilation error. You can program around this using the
|
||||
following mechanism:
|
||||
|
||||
i = constant-expression;
|
||||
A(i) = constant;
|
||||
|
||||
|
||||
o A CALL statement cannot contain a null argument list. For
|
||||
example,
|
||||
|
||||
CALL A();
|
||||
|
||||
You can program around this by always using
|
||||
|
||||
CALL A;
|
||||
|
||||
|
||||
o There is an incorrect string assignment if the right-hand string
|
||||
overlaps the left-hand string. The example in the Language
|
||||
Reference Manual, page 6-7 is correct; the compiler is not.
|
||||
|
||||
o The RANK built-in function doesn't accept SUBSTR as an argument.
|
||||
For example, RANK(SUBSTR(C,1,1)) causes a compilation error.
|
||||
|
||||
o A statement in column 1 following a simple DO statement causes a
|
||||
compilation error.
|
||||
|
||||
o At run-time, end-of-file is not noticed if the column descriptor
|
||||
in the format specifies a location past the actual end of the
|
||||
file.
|
||||
|
||||
o Static, initialized data with odd-numbered byte boundaries can
|
||||
sometimes overwrite storage reserved for the File Parameter Block,
|
||||
thereby causing OPEN errors. For example,
|
||||
|
||||
declare x fixed binary(7) static initial(0);
|
||||
|
||||
You can program around this by declaring the data with the STATIC
|
||||
and EXTERNAL attributes, or by using a declaration that forces
|
||||
storage on a word (double-byte) boundary, for example FIXED
|
||||
BINARY(15). Omitting the INITIAL attribute also solves the
|
||||
problem.
|
||||
|
||||
|
||||
Digital Research is in the process of fixing these software bugs, and
|
||||
will either furnish field patches through Technical Support, or issue a
|
||||
new version.
|
||||
|
||||
|
||||
|
||||
3
|
||||
|
||||
|
55
Digital Research PLI-86 v1/REPORT.PLI
Normal file
55
Digital Research PLI-86 v1/REPORT.PLI
Normal file
@ -0,0 +1,55 @@
|
||||
/******************************************************/
|
||||
/* This program reads an employee data base and */
|
||||
/* prints a list of paychecks. */
|
||||
/******************************************************/
|
||||
report:
|
||||
procedure options(main);
|
||||
declare
|
||||
1 employee static,
|
||||
2 name character(30) varying,
|
||||
2 address,
|
||||
3 street character(30) varying,
|
||||
3 city character(10) varying,
|
||||
3 state character(12) varying,
|
||||
3 zip fixed decimal(5),
|
||||
2 age fixed decimal(3),
|
||||
2 wage fixed decimal(5,2),
|
||||
2 hours fixed decimal(5,1);
|
||||
|
||||
declare
|
||||
i fixed,
|
||||
dashes character(15) static initial
|
||||
('$--------------'),
|
||||
buff character(20) varying,
|
||||
(grosspay, withhold) fixed decimal(7,2),
|
||||
(repfile, empfile) file;
|
||||
|
||||
open file(empfile) keyed environment(f(128),b(4000))
|
||||
title ('$1.EMP');
|
||||
open file(repfile) stream print environment(b(2000))
|
||||
title('$2.$2');
|
||||
|
||||
put list('Set Top of Forms, Press Return');
|
||||
get skip;
|
||||
|
||||
do while('1'b);
|
||||
read file(empfile) into(employee);
|
||||
if name = 'EOF' then
|
||||
stop;
|
||||
put file(repfile) skip(2);
|
||||
buff = '[' !! name !! ']^m^j';
|
||||
write file(repfile) from (buff);
|
||||
grosspay = wage * hours;
|
||||
withhold = grosspay * .15;
|
||||
buff = grosspay - withhold;
|
||||
do i = 1 to 15
|
||||
while (substr(buff,i,1) = ' ');
|
||||
end;
|
||||
i = i - 1;
|
||||
substr(buff,1,i) = substr(dashes,1,i);
|
||||
write file (repfile) from(buff);
|
||||
end;
|
||||
|
||||
end report;
|
||||
|
||||
|
56
Digital Research PLI-86 v1/RETRIEVE.PLI
Normal file
56
Digital Research PLI-86 v1/RETRIEVE.PLI
Normal file
@ -0,0 +1,56 @@
|
||||
/******************************************************/
|
||||
/* This program reads a name and address data file */
|
||||
/* and displays the information on request. */
|
||||
/******************************************************/
|
||||
retrieve:
|
||||
procedure options(main);
|
||||
|
||||
%include 'record.dcl';
|
||||
%replace
|
||||
true by '1'b,
|
||||
false by '0'b;
|
||||
|
||||
declare
|
||||
(sysprint, input) file,
|
||||
filename character(14) varying,
|
||||
(lower, upper) character(30) varying,
|
||||
eofile bit(1);
|
||||
|
||||
open file(sysprint) print title('$con');
|
||||
put list('Name and Address Retrieval, File Name: ');
|
||||
get list(filename);
|
||||
|
||||
do while(true);
|
||||
lower = 'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA';
|
||||
upper = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz';
|
||||
put skip(2) list('Type Lower, Upper Bounds: ');
|
||||
get list(lower,upper);
|
||||
if lower = 'EOF' then
|
||||
stop;
|
||||
|
||||
open file(input) stream input environment(b(1024))
|
||||
title(filename);
|
||||
eofile = false;
|
||||
do while (^eofile);
|
||||
get file(input) list(name);
|
||||
eofile = (name = 'EOF');
|
||||
if ^eofile then
|
||||
do;
|
||||
get file(input)
|
||||
list(addr,city,state,zip,phone);
|
||||
if name >= lower & name <= upper then
|
||||
do;
|
||||
put page skip(3)list(name);
|
||||
put skip list(addr);
|
||||
put skip list(city,state);
|
||||
put skip list(zip);
|
||||
put skip list(phone);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
close file(input);
|
||||
end;
|
||||
|
||||
end retrieve;
|
||||
|
||||
|
54
Digital Research PLI-86 v1/REVERSE.PLI
Normal file
54
Digital Research PLI-86 v1/REVERSE.PLI
Normal file
@ -0,0 +1,54 @@
|
||||
/******************************************************/
|
||||
/* This program reads a sentence and reverses it. */
|
||||
/******************************************************/
|
||||
reverse:
|
||||
procedure options(main);
|
||||
declare
|
||||
sentence pointer,
|
||||
1 wordnode based (sentence),
|
||||
2 word character(30) varying,
|
||||
2 next pointer;
|
||||
|
||||
do while('1'b);
|
||||
call read_it();
|
||||
if sentence = null then
|
||||
stop;
|
||||
call write_it();
|
||||
end;
|
||||
|
||||
read_it:
|
||||
procedure;
|
||||
declare
|
||||
newword character(30) varying,
|
||||
newnode pointer;
|
||||
sentence = null;
|
||||
put skip list('What''s up? ');
|
||||
do while('1'b);
|
||||
get list(newword);
|
||||
if newword = '.' then
|
||||
return;
|
||||
allocate wordnode set (newnode);
|
||||
newnode->next = sentence;
|
||||
sentence = newnode;
|
||||
word = newword;
|
||||
end;
|
||||
end read_it;
|
||||
|
||||
write_it:
|
||||
procedure;
|
||||
declare
|
||||
p pointer;
|
||||
put skip list('Actually, ');
|
||||
do while (sentence ^= null);
|
||||
put list(word);
|
||||
p = sentence;
|
||||
sentence = next;
|
||||
free p->wordnode;
|
||||
end;
|
||||
put list('.');
|
||||
put skip;
|
||||
end write_it;
|
||||
|
||||
end reverse;
|
||||
|
||||
|
34
Digital Research PLI-86 v1/REVERT.PLI
Normal file
34
Digital Research PLI-86 v1/REVERT.PLI
Normal file
@ -0,0 +1,34 @@
|
||||
/******************************************************/
|
||||
/* This program is nonfunctional. Its purpose is to */
|
||||
/* illustrate how PL/I executes the ON and REVERT */
|
||||
/* statements. */
|
||||
/******************************************************/
|
||||
auto_revert:
|
||||
procedure options(main);
|
||||
declare
|
||||
i fixed,
|
||||
sysin file;
|
||||
|
||||
do i = 1 to 10000;
|
||||
call p(i,exit);
|
||||
exit:
|
||||
end;
|
||||
|
||||
P:
|
||||
procedure (index,lab);
|
||||
declare
|
||||
(t, index) fixed,
|
||||
lab label;
|
||||
|
||||
on endfile(sysin)
|
||||
goto lab;
|
||||
|
||||
put skip list(index,':');
|
||||
get list(t);
|
||||
if t = index then
|
||||
goto lab;
|
||||
end P; /* implicit REVERT supplied here */
|
||||
|
||||
end auto_revert;
|
||||
|
||||
|
24
Digital Research PLI-86 v1/RFACT.PLI
Normal file
24
Digital Research PLI-86 v1/RFACT.PLI
Normal file
@ -0,0 +1,24 @@
|
||||
/******************************************************/
|
||||
/* This program evaluates the Factorial function (n!) */
|
||||
/* using recursion. */
|
||||
/******************************************************/
|
||||
rfact:
|
||||
procedure options(main);
|
||||
declare
|
||||
i fixed;
|
||||
do i = 0 repeat(i+1);
|
||||
put skip list('factorial(',i,')=',factorial(i));
|
||||
end;
|
||||
stop;
|
||||
|
||||
factorial:
|
||||
procedure(i) returns(fixed) recursive;
|
||||
declare
|
||||
i fixed;
|
||||
if i = 0 then return (1);
|
||||
return (i * factorial(i-1));
|
||||
end factorial;
|
||||
|
||||
end rfact;
|
||||
|
||||
|
254
Digital Research PLI-86 v1/RNDCOPY.PLI
Normal file
254
Digital Research PLI-86 v1/RNDCOPY.PLI
Normal file
@ -0,0 +1,254 @@
|
||||
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;
|
||||
|
41
Digital Research PLI-86 v1/SAMPLE.PLI
Normal file
41
Digital Research PLI-86 v1/SAMPLE.PLI
Normal file
@ -0,0 +1,41 @@
|
||||
sample:
|
||||
procedure options(main);
|
||||
declare
|
||||
c character(10) varying,
|
||||
i fixed binary(15);
|
||||
|
||||
do;
|
||||
put skip list('Input: ');
|
||||
get list(c);
|
||||
c = upper(c); /* function reference */
|
||||
put skip list('Output: ',c);
|
||||
end;
|
||||
|
||||
begin;
|
||||
declare
|
||||
c float binary(24);
|
||||
|
||||
put skip list('Input: ');
|
||||
get list(c);
|
||||
call output(c); /* subroutine invocation */
|
||||
end;
|
||||
|
||||
upper:
|
||||
procedure(c) returns(character(10) varying);
|
||||
declare
|
||||
c character(10) varying;
|
||||
|
||||
return(translate(c,'ABCDEFGHIJKLMNOPQRSTUVWXYZ',
|
||||
'abcdefghijklmnopqrstuvwxyz'));
|
||||
end upper;
|
||||
|
||||
output:
|
||||
procedure(c);
|
||||
declare
|
||||
c float binary(24);
|
||||
|
||||
put skip edit(c) (column(20),e(10,2));
|
||||
end output;
|
||||
|
||||
end sample;
|
||||
|
181
Digital Research PLI-86 v1/SEQCOPY.PLI
Normal file
181
Digital Research PLI-86 v1/SEQCOPY.PLI
Normal file
@ -0,0 +1,181 @@
|
||||
diocopy: procedure options(main);
|
||||
|
||||
******************************************************************************
|
||||
* *
|
||||
* 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>seqcopy 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,
|
||||
eofile bit(1),
|
||||
(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 */
|
||||
1 dest_file,
|
||||
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 FCB's */
|
||||
srcfcb_ptr = dfcb0();
|
||||
source_file.drive = 0;
|
||||
dest_file.drive = 0;
|
||||
|
||||
/* get the filenames */
|
||||
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,'.');
|
||||
dest_file.name = substr(tempdest,1,i-1) || ' ';
|
||||
dest_file.name = substr(dest_file.name,1,8);
|
||||
dest_file.type = substr(tempdest,i+1,3) || ' ';
|
||||
dest_file.type = substr(dest_file.type,1,3);
|
||||
|
||||
/* 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;
|
||||
|
||||
/* 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;
|
||||
|
||||
/* Copy the file. Read sequentially until the buffers are full, then write
|
||||
sequentially until the buffers are empty, then read... until the file
|
||||
is copied. */
|
||||
|
||||
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 rdseq(addr(source_file)) ^= 0 then do;
|
||||
eofile = true;
|
||||
/* truncate buffer */
|
||||
num_buffs = i;
|
||||
end;
|
||||
end;
|
||||
m = 0;
|
||||
/* write buffers */
|
||||
do i = 0 to num_buffs - 1;
|
||||
call setdma(addr(memory(m)));
|
||||
m = m + buffer_size;
|
||||
if wrseq(addr(dest_file)) ^= 0 then do;
|
||||
put skip list('Disk Full');
|
||||
call reboot();
|
||||
end;
|
||||
end;
|
||||
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;
|
||||
|
||||
end diocopy;
|
||||
|
BIN
Digital Research PLI-86 v1/SIEVE.EXE
Normal file
BIN
Digital Research PLI-86 v1/SIEVE.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/SIEVE.OBJ
Normal file
BIN
Digital Research PLI-86 v1/SIEVE.OBJ
Normal file
Binary file not shown.
253
Digital Research PLI-86 v1/SIEVE.SYM
Normal file
253
Digital Research PLI-86 v1/SIEVE.SYM
Normal file
@ -0,0 +1,253 @@
|
||||
|
||||
0000 VARIABLES 05B8 DATA
|
||||
2C12 ?FILAT 2C1C ?FPB 2C4A ?FPBSTK 2C5E SYSIN 2C84 SYSPRINT
|
||||
2CAC ERRMSG 2CBE ?CONSP 2CE0 ?ONCOD 2CE4 ?CNCOL 2CE6 ?FMTS
|
||||
2CEE ?EBUFF
|
||||
0000 LABELS 0040 CODE
|
||||
0005 SIEVE
|
||||
00DC ?SIOPR
|
||||
0273 ?OIOPR
|
||||
0431 ?CIOPR
|
||||
044B ?WNIPR
|
||||
04DE ?KEYPR
|
||||
0578 ?GNCPR
|
||||
05D9 ?PAGOP
|
||||
05E9 ?RNIPR
|
||||
06B4 ?PNCPR
|
||||
07A2 ?SKPPR
|
||||
084F ?GNVPR
|
||||
09C9 COS
|
||||
0A88 EXP
|
||||
0B2E TAN
|
||||
0B77 LOG
|
||||
0B8C SIN
|
||||
0C5C SQRT
|
||||
0D51 ASIN
|
||||
0EB6 ATAN
|
||||
0F86 COSH
|
||||
0FC5 LOG2
|
||||
0FE0 SIND
|
||||
1004 COSD
|
||||
1028 TANH
|
||||
107C TAND
|
||||
10C5 ACOS
|
||||
1116 SINH
|
||||
1155 ATAND
|
||||
1170 LOG10
|
||||
118B ?LOG
|
||||
12F9 ?EXP
|
||||
139F ?CHEBY
|
||||
144F ?CNVER
|
||||
1455 ?ZEROD
|
||||
145E ?OVERF 1462 ?UNDER
|
||||
1472 ?SVBLK
|
||||
156D ?OFCOP 14CE ?RSBLK 1514 ?RECOV
|
||||
159B ?ALLOP 164B ?FREOP
|
||||
1765 ?OVLAY 1733 ?OVLA0
|
||||
0000 VARIABLES 05B8 DATA
|
||||
272B CGROUP_END 2731 DGROUP_END 2746 SIGMSG 2741 SIGSUB 272D CGROUP_LEN
|
||||
2733 DGROUP_LEN 2750 ERRMSG 2744 SIGAUX 2737 PRESET
|
||||
2735 OVERLAY_ENTRY 2770 DRVERR 2738 SIGLST 2782 NSTERR
|
||||
2779 SIZERR 26D7 DMABASE 26B2 OVFCB 2729 CGROUP_OFFSET
|
||||
272F DGROUP_OFFSET 2740 SIGCOD 26D9 OVTAB 2767 NOFILE
|
||||
2742 SIGFIL 278B RDERR
|
||||
0000 LABELS 0040 CODE
|
||||
191F SETDMAB 1955 COPYF 1895 ENTOK 1821 DRIVE_ERR 1906 RESET
|
||||
1878 UPDATE 1938 READ_ERROR 17C2 LOADOV 1960 PRF00 193B ERROR
|
||||
18D0 CHECKRANGE 18E2 UPPER 1845 LOAD_GROUP 18EC UPRET 179E OVRET
|
||||
1915 RANDBLKRD 189A INSERT 187E UP0 174A OV1
|
||||
1824 GET_GROUP_INFO 1969 PRF0 1875 RDBLKERR 1971 PRF1
|
||||
18A0 INS0 18AC INS1 17A6 SEAR0 18B6 INS2 1933 NEST_ERROR
|
||||
1929 DRIVE_ERROR 18CD NESTERR 192E SIZE_ERROR
|
||||
1924 NOFILE_ERROR 1903 NOFILEERR 197E COPYFRET 1844 NO_OFLO
|
||||
1865 RDBLK 1782 OVLAY05 185A RDSEC 190B OPEN 1761 XFER
|
||||
1910 CLOSE 179F SEARCH 18ED OPENF 18E1 CHECKOK 1779 OVLAY0
|
||||
17BA FOUND 179B OVLAY1 1760 NOLOAD 191A SETDMA
|
||||
0000 NUMBERS
|
||||
0001 TRUE 0008 CG_OFFSET_BYTE 000C DG_OFFSET_BYTE
|
||||
0010 ENTRY_LEN 000A CG_END_BYTE 000E DG_END_BYTE
|
||||
0005 MAXNST 0008 MSGSIZ 0080 DBUFF 0080 SECTOR_SIZE
|
||||
0000 FALSE 0000 HEADER_CGROUP_OFFSET 0009 HEADER_DGROUP_OFFSET
|
||||
0000 LABELS 0040 CODE
|
||||
197F ?SIGOP 1992 ?SIGNAL
|
||||
1C5C ?REVOP 1C1F ?ONPRO 1C84 ?ONCPC 1C20 ?ONCOP
|
||||
1CB8 ?WRCHR
|
||||
1CD5 ?QIOOP 1CE6 ?FPBIN 1D51 ?FPBOU
|
||||
0000 VARIABLES 05B8 DATA
|
||||
28E6 ?MEMRY 28E4 ?CMEMRY 28E1 ?RECLST 28DF ?BEGIN 28E3 ?DFDRV
|
||||
28D9 ?STACK
|
||||
0000 LABELS 0040 CODE
|
||||
1E0B ?SUBIO 1D73 ?START 1EE1 ?STOPX 1DF3 ?ADDIO 1F03 ?BDOS
|
||||
1EF9 ?ERMSG
|
||||
1F19 ?DSUOP
|
||||
1F32 ?DNGOP
|
||||
1F44 ?DMUOP
|
||||
2015 ?DADOP
|
||||
2037 ?DMODF 203B ?DDVOP
|
||||
2152 ?DLDOP
|
||||
2179 ?DSTOP
|
||||
21BB ?DCOMP 21B3 ?DCMOP
|
||||
21E5 ?DSIOP
|
||||
2205 ?DOVER
|
||||
220B ?DCRET
|
||||
221B ?CS2AD 2221 ?CS3AD 221A ?VS2AD 2217 ?VS3AD
|
||||
2237 ?SCVMS
|
||||
224C ?SCVVM
|
||||
2255 ?SCSTS
|
||||
2271 ?SCCVM
|
||||
2277 ?SCVCM
|
||||
227D ?SCSVM 2280 ?SCSCM
|
||||
2294 ?SCCMS
|
||||
22A6 ?SCCCM
|
||||
22D6 ?SASVM
|
||||
22EA ?SAVVM 22EB ?SACVM
|
||||
2302 ?SJSVM 2305 ?SJSCM
|
||||
2317 ?SJSTS
|
||||
2330 ?SLCTS 232F ?SLVTS
|
||||
2342 ?SSCFS
|
||||
2354 ?SSVFS
|
||||
2372 ?SMCVM 236F ?SMVVM
|
||||
2380 ?SMVCM 2383 ?SMCCM
|
||||
23A9 ?VCRET
|
||||
23C2 ?FD44
|
||||
2490 ?FD44M
|
||||
2495 ?S44MM
|
||||
24A2 ?FD44S
|
||||
24A7 ?S44SS
|
||||
24C0 ?FD44L
|
||||
24C5 ?S44SM
|
||||
24D8 ?FD44R
|
||||
24DD ?S44MS
|
||||
24F2 ?FP40
|
||||
2539 ?FU40
|
||||
2577 ?FM44
|
||||
25C0 ?FM44M
|
||||
25C5 ?FM44S
|
||||
25CA ?FM44L
|
||||
25CF ?FM44R
|
||||
25D4 ?FC44C
|
||||
25E6 ?FC44M
|
||||
25F1 ?FC44S
|
||||
2607 ?FC44L
|
||||
2618 ?FPRET
|
||||
2620 ?FC44R
|
||||
2631 ?FS44M
|
||||
2636 ?FS44S
|
||||
263B ?FS44L
|
||||
2640 ?FS44R
|
||||
2645 ?FS44 2649 ?FA44
|
||||
26ED ?FA44L
|
||||
26F2 ?FA44M
|
||||
26F7 ?FA44S
|
||||
26FC ?FA44R
|
||||
2701 ?FL40M
|
||||
2708 ?FN40M
|
||||
2714 ?FN40S
|
||||
271B ?FX44S
|
||||
2723 ?FE40S
|
||||
272D ?FE40M
|
||||
2743 ?IE12N
|
||||
2747 ?IE10N
|
||||
2751 ?IE20N
|
||||
2776 ?BC12N 275D ?BC22N
|
||||
279E ?BSL16 2795 ?BSL08
|
||||
27B7 ?BST16 27A7 ?BST08
|
||||
283F ?QB16C 283B ?QB08C
|
||||
285E ?QB16I 285A ?QB08I
|
||||
2869 ?QCB16 2865 ?QCB08
|
||||
289C ?QCDOP
|
||||
2960 ?QCFOP
|
||||
2B28 ?QCIOP
|
||||
2B9B ?QDCOP
|
||||
2C1D ?QDDOP
|
||||
2C34 ?QDDSL
|
||||
2CD7 ?QDDSR
|
||||
2D54 ?QDI15 2D54 ?QDI07
|
||||
2E9A ?UML10 2E61 ?UDV10 2ECA ?USLOP 2EAF ?UADOP 2D67 ?QFCMS
|
||||
2EEC ?QFCSS
|
||||
2F09 ?QFI07
|
||||
2F1D ?QFI15
|
||||
2F50 ?QI15B 2F4D ?QI07B
|
||||
2F68 ?QICOP
|
||||
2FAF ?QI15D 2FAC ?QI07D
|
||||
2FF2 ?QI15F 2FF0 ?QI07F
|
||||
3009 ?NSTOP
|
||||
3012 ?NC22N
|
||||
3015 ?NCOMP
|
||||
3090 ALLWDS 302A MAXWDS 3024 TOTWDS 30A7 STKSIZ
|
||||
30BF FTC
|
||||
316D ?FMODF
|
||||
319F ?FABSF
|
||||
31B1 ?FMINF 31A6 ?FMAXF
|
||||
31D3 ?FROUN
|
||||
3232 ?FTRNC
|
||||
32A7 ?FCEIL 3260 ?FFLOR
|
||||
32C7 ?FPSHF
|
||||
32DC ?FEX15 32D9 ?FEX07
|
||||
331B ?FPEX2
|
||||
3353 ?FFXOP
|
||||
3392 ?IAB15 338B ?IAB07
|
||||
339E ?IMINF 3399 ?IMAXF
|
||||
33A4 ?IMDOP
|
||||
33CA ?IROUN
|
||||
33EC ?IEXOP
|
||||
3412 ?DMINF 33FD ?DMAXF
|
||||
3419 ?DABSF
|
||||
3425 ?DROUN
|
||||
34AC ?DCEIL 347F ?DFLOR
|
||||
34C3 ?DEXOP
|
||||
350F ?CXVMS
|
||||
3526 ?CXSVM 3529 ?CXSCM
|
||||
353D ?CXCVM
|
||||
3545 ?CXCMS
|
||||
355B ?CXSTS
|
||||
357B ?CXVCM
|
||||
3581 ?CXVVM
|
||||
3588 ?CXCCM
|
||||
35AF ?QCCOP
|
||||
35FD ?XL2OP
|
||||
365C ?XL3OP
|
||||
36DC COLLATE
|
||||
36F6 ?BIX16 36EC ?BIX08
|
||||
3758 ?VEROP
|
||||
378E ?BOOLF
|
||||
37B9 ?EDITF 37BE ?GNFMT
|
||||
38B6 ?EDTOV 3C66 ?GETND
|
||||
3C86 ?ENPOP
|
||||
4011 ?EDTOB
|
||||
40B2 ?OUTFM 4180 ?PNC
|
||||
41B3 ?EDTIV
|
||||
4485 ?INPFM
|
||||
44EF ?BADFM
|
||||
44F5 ?FPBIO
|
||||
45DC LINENO 45A7 ONKEY 4559 ONCODE 45D7 PAGENO 4560 ONFILE
|
||||
4603 ?CIOOP
|
||||
460D ?GNVOP
|
||||
466A ?KEYOP 467E ?KEYTO
|
||||
469C ?OIOOP
|
||||
4706 ?PNVOP 46D2 ?PNBOP 46D7 ?PNCOP
|
||||
47EA ?SIOOP 47E2 ?SYSIN 47E6 ?SYSPR
|
||||
4816 ?SKPOP
|
||||
481F ?WNIOP
|
||||
482F ?RNIOP
|
||||
4FDF ?GETKY 4C8A ?OPNFIL 4DE1 ?RDBYTE 4E5D ?WRBUFF 5019 ?SETKY
|
||||
4DF7 ?WRBYTE 4F70 ?PATH 4F98 ?CLOSE 4E36 ?RDBUFF
|
||||
516C ?RFSIZ 5216 ?RRFCB 521A ?RWFCB
|
||||
52F1 DATE 52EF TIME
|
||||
0000 VARIABLES 05B8 DATA
|
||||
2B28 ?JTABLE
|
||||
0000 LABELS 0040 CODE
|
||||
53D3 ?PCDOS
|
||||
55B0 SELECT 5517 DFCB1 5665 BLOCKRD 55AB RESET 5655 SETREC
|
||||
554B CONINP 565D NEWSEG 552D WRCON 56D2 SETDATE 569F PARSFN
|
||||
5645 WRRAN 551F REBOOT 5600 CURDSK 5561 DIN1 5565 DIN2
|
||||
550D MEMWDS 56E5 GETTIME 564D FILSIZ 55E8 WRSEQ 5682 BLOCKWR
|
||||
5504 MEMSIZ 54FF MEMPTR 5559 CONOUT 571E SETVER 5706 SETTIME
|
||||
5543 WRLST 553F WRPUN 55F0 MAKE 557E CLRKB1 559D CLRKB2
|
||||
5569 WRSTR 5579 BREAK 551B DBUFF 55C8 SEAR 55B8 OPEN
|
||||
55D8 DELETE 5571 RDBUF 55C0 CLOSE 5529 RDCON 563D RDRAN
|
||||
55F8 RENAME 55D0 SEARN 560D ALLTBL 56B8 GETDATE 5605 SETDMA
|
||||
5531 RDRDR 55E0 RDSEQ 5513 DFCB0
|
||||
572A DIV2
|
||||
574F FDIV2
|
||||
|
35
Digital Research PLI-86 v1/TEST.PLI
Normal file
35
Digital Research PLI-86 v1/TEST.PLI
Normal file
@ -0,0 +1,35 @@
|
||||
/***************************************************/
|
||||
/* This program computes the largest of three */
|
||||
/* FLOAT BINARY numbers x, y, and z */
|
||||
/***************************************************/
|
||||
test:
|
||||
procedure options(main);
|
||||
declare
|
||||
(a,b,c) float binary;
|
||||
|
||||
put list ('Type Three Numbers: ');
|
||||
get list (a,b,c);
|
||||
put list ('The Largest Value is',max3(a,b,c));
|
||||
|
||||
/* this procedure computes the largest of x, y, and z */
|
||||
max3:
|
||||
procedure(x,y,z) returns(float binary);
|
||||
declare
|
||||
(x,y,z,max) float binary;
|
||||
|
||||
if x > y then
|
||||
if x > z then
|
||||
max = x;
|
||||
else
|
||||
max = z;
|
||||
else
|
||||
if y > z then
|
||||
max = y;
|
||||
else
|
||||
max = z;
|
||||
return(max);
|
||||
end max3;
|
||||
|
||||
end test;
|
||||
|
||||
|
67
Digital Research PLI-86 v1/UPDATE.PLI
Normal file
67
Digital Research PLI-86 v1/UPDATE.PLI
Normal file
@ -0,0 +1,67 @@
|
||||
/******************************************************/
|
||||
/* This program allows you to retrieve and update */
|
||||
/* individual records in an employee data base using */
|
||||
/* a keyed file. */
|
||||
/******************************************************/
|
||||
update:
|
||||
procedure options(main);
|
||||
declare
|
||||
1 employee static,
|
||||
2 name character(30) varying,
|
||||
2 address,
|
||||
3 street character(30) varying,
|
||||
3 city character(10) varying,
|
||||
3 state character(12) varying,
|
||||
3 zip fixed decimal(5),
|
||||
2 age fixed decimal(3),
|
||||
2 wage fixed decimal(5,2),
|
||||
2 hours fixed decimal(5,1);
|
||||
|
||||
declare
|
||||
1 keylist (100),
|
||||
2 keyname character(30) varying,
|
||||
2 keyval fixed binary;
|
||||
|
||||
declare
|
||||
(i, endlist) fixed,
|
||||
eolist bit(1) static initial('0'b),
|
||||
matchname character(30) varying,
|
||||
(emp, keys) file;
|
||||
|
||||
open file(emp) update direct environment(f(128))
|
||||
title ('$1.EMP');
|
||||
|
||||
open file(keys) stream environment(b(4000))
|
||||
title('$1.key');
|
||||
|
||||
do i = 1 to 100 while(^eolist);
|
||||
get file(keys) list(keyname(i),keyval(i));
|
||||
eolist = keyname(i) = 'EOF';
|
||||
end;
|
||||
|
||||
do while('1'b);
|
||||
put skip list('Employee: ');
|
||||
get list(matchname);
|
||||
if matchname = 'EOF' then
|
||||
stop;
|
||||
do i = 1 to 100;
|
||||
if matchname = keyname(i) then
|
||||
do;
|
||||
read file(emp) into(employee)
|
||||
key(keyval(i));
|
||||
put skip list('Address: ',
|
||||
street, city, state, zip);
|
||||
put skip list(' ');
|
||||
get list(street, city, state, zip);
|
||||
put list('Hours:',hours,': ');
|
||||
get list(hours);
|
||||
write file(emp) from (employee)
|
||||
keyfrom(keyval(i));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end update;
|
||||
|
||||
|
||||
|
BIN
Digital Research PLI-86 v1/XREF86.EXE
Normal file
BIN
Digital Research PLI-86 v1/XREF86.EXE
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/db.obj
Normal file
BIN
Digital Research PLI-86 v1/db.obj
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/dbttt.obj
Normal file
BIN
Digital Research PLI-86 v1/dbttt.obj
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/dm.obj
Normal file
BIN
Digital Research PLI-86 v1/dm.obj
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/dmcopy.obj
Normal file
BIN
Digital Research PLI-86 v1/dmcopy.obj
Normal file
Binary file not shown.
BIN
Digital Research PLI-86 v1/dmttt.obj
Normal file
BIN
Digital Research PLI-86 v1/dmttt.obj
Normal file
Binary file not shown.
33
Digital Research PLI-86 v1/e.pli
Normal file
33
Digital Research PLI-86 v1/e.pli
Normal file
@ -0,0 +1,33 @@
|
||||
e:
|
||||
proc options( main );
|
||||
%replace
|
||||
DIGITS by 200;
|
||||
|
||||
dcl a( 200 ) fixed;
|
||||
dcl ( high, n, x ) fixed;
|
||||
|
||||
high = DIGITS;
|
||||
x = 0;
|
||||
|
||||
n = high - 1;
|
||||
do while ( n > 0 );
|
||||
a( n ) = 1;
|
||||
n = n - 1;
|
||||
end;
|
||||
|
||||
a( 1 ) = 2;
|
||||
a( 0 ) = 0;
|
||||
|
||||
do while ( high > 9 );
|
||||
high = high - 1;
|
||||
n = high;
|
||||
do while ( 0 ^= n );
|
||||
a( n ) = mod( x, n );
|
||||
x = 10 * a( n - 1 ) + x / n;
|
||||
n = n - 1;
|
||||
end;
|
||||
put list( x );
|
||||
end;
|
||||
|
||||
put skip list( 'done' );
|
||||
end e;
|
6
Digital Research PLI-86 v1/m.bat
Normal file
6
Digital Research PLI-86 v1/m.bat
Normal file
@ -0,0 +1,6 @@
|
||||
ntvdm pli.exe %1 $L $I
|
||||
ntvdm link86 %1,plilib.l86,pcdio.obj,div2.obj,fdiv2.obj
|
||||
|
||||
ntvdm -c -p %1
|
||||
|
||||
|
6
Digital Research PLI-86 v1/mnf.bat
Normal file
6
Digital Research PLI-86 v1/mnf.bat
Normal file
@ -0,0 +1,6 @@
|
||||
ntvdm pli.exe %1 $L
|
||||
ntvdm link86 %1,pcdio.obj,plilib.l86
|
||||
|
||||
ntvdm -c -p %1
|
||||
|
||||
|
40
Digital Research PLI-86 v1/sieve.pli
Normal file
40
Digital Research PLI-86 v1/sieve.pli
Normal file
@ -0,0 +1,40 @@
|
||||
/*
|
||||
PL/I implementation of BYTE magazine's sieve benchmark
|
||||
*/
|
||||
|
||||
sieve:
|
||||
proc options( main );
|
||||
%replace
|
||||
size by 8190,
|
||||
false by '0'b,
|
||||
true by '1'b;
|
||||
|
||||
dcl
|
||||
flags( 0:8191 ) bit(1),
|
||||
( i, prime, k, count, iter ) fixed;
|
||||
|
||||
put list( '10 iterations');
|
||||
|
||||
do iter = 1 to 10;
|
||||
count = 0;
|
||||
|
||||
do i = 0 to size;
|
||||
flags( i ) = true;
|
||||
end;
|
||||
|
||||
do i = 0 to size;
|
||||
if flags( i ) then do;
|
||||
prime = i + i + 3;
|
||||
k = i + prime;
|
||||
do while ( k <= size );
|
||||
flags( k ) = false;
|
||||
k = k + prime;
|
||||
end;
|
||||
|
||||
count = count + 1;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
put skip list( count, 'primes' );
|
||||
end sieve;
|
351
Digital Research PLI-86 v1/ttt.pli
Normal file
351
Digital Research PLI-86 v1/ttt.pli
Normal file
@ -0,0 +1,351 @@
|
||||
/*
|
||||
PL/I version of an app that proves you can't win at tic-tac-toe if the opponent is competent.
|
||||
Written for Digital Research PL/I-86 version 1.0 for MS-DOS
|
||||
To build (first build PL/I's ms-dos system call wrappers in pcdio.a86)
|
||||
ntvdm rasm86 pcdio
|
||||
ntvdm pli %1
|
||||
ntvdm link86 %1,pcdio.obj
|
||||
*/
|
||||
|
||||
ttt:
|
||||
|
||||
proc options( main );
|
||||
%include 'diomod.dcl';
|
||||
%replace
|
||||
ScoreWin by 6,
|
||||
ScoreTie by 5,
|
||||
ScoreLose by 4,
|
||||
ScoreMax by 9,
|
||||
ScoreMin by 2,
|
||||
pieceX by 1,
|
||||
pieceO by 2,
|
||||
pieceBlank by 0,
|
||||
DefaultIterations by 1;
|
||||
|
||||
dcl board(9) binary(7);
|
||||
dcl movecount binary;
|
||||
dcl ( x, iterations, tstart, tend ) binary;
|
||||
dcl funcs(9) entry variable returns( binary(7) );
|
||||
dcl thefunc entry variable returns( binary(7) );
|
||||
|
||||
funcs( 0 ) = func0;
|
||||
funcs( 1 ) = func1;
|
||||
funcs( 2 ) = func2;
|
||||
funcs( 3 ) = func3;
|
||||
funcs( 4 ) = func4;
|
||||
funcs( 5 ) = func5;
|
||||
funcs( 6 ) = func6;
|
||||
funcs( 7 ) = func7;
|
||||
funcs( 8 ) = func8;
|
||||
|
||||
iterations = readcommandtail();
|
||||
if 0 = iterations then
|
||||
iterations = DefaultIterations;
|
||||
|
||||
tstart = getticks();
|
||||
|
||||
do x = 1 to iterations;
|
||||
movecount = 0;
|
||||
call findsolution( 0 );
|
||||
call findsolution( 1 );
|
||||
call findsolution( 4 );
|
||||
end;
|
||||
|
||||
tend = getticks();
|
||||
|
||||
put skip list( 'moves: ', movecount );
|
||||
put skip list( 'iterations: ', iterations );
|
||||
put skip list( 'hundredths of a second: ', tend - tstart );
|
||||
stop;
|
||||
|
||||
findsolution: proc( move );
|
||||
dcl move binary(7);
|
||||
dcl result binary(7);
|
||||
|
||||
board( move ) = pieceX;
|
||||
result = minmax( ScoreMin, ScoreMax, 0, move );
|
||||
board( move ) = pieceBlank;
|
||||
end findsolution;
|
||||
|
||||
minmax: proc( alpha, beta, depth, move ) returns ( binary(7) ) recursive;
|
||||
dcl (alpha, beta, depth, move) binary(7);
|
||||
dcl (value, score, pieceMove, p, m) binary(7);
|
||||
|
||||
movecount = movecount + 1;
|
||||
|
||||
if depth >= 4 then do;
|
||||
/*p = winner();*/
|
||||
/*p = winner2( move );*/
|
||||
|
||||
thefunc = funcs( move ); /* can't invoke the function via the array directly due to a compiler bug */
|
||||
p = thefunc();
|
||||
|
||||
if pieceBlank ^= p then do;
|
||||
if pieceX = p then return ( ScoreWin );
|
||||
return ( ScoreLose );
|
||||
end;
|
||||
|
||||
if 8 = depth then return ( ScoreTie );
|
||||
end;
|
||||
|
||||
if pieceO = board( move ) then do;
|
||||
value = ScoreMin;
|
||||
pieceMove = pieceX;
|
||||
end;
|
||||
else do;
|
||||
value = ScoreMax;
|
||||
pieceMove = pieceO;
|
||||
end;
|
||||
|
||||
do m = 0 to 8;
|
||||
if pieceBlank = board( m ) then do;
|
||||
board( m ) = pieceMove;
|
||||
score = minmax( alpha, beta, depth + 1, m );
|
||||
board( m ) = pieceBlank;
|
||||
|
||||
if pieceX = pieceMove then do;
|
||||
/* put skip list ( 'odd depth, score: ', score ); */
|
||||
if ScoreWin = score then return ( ScoreWin );
|
||||
if score > value then do;
|
||||
/* put skip list ( 'score > value, alpha and beta ', score, value, alpha, beta ); */
|
||||
if score >= beta then return ( score );
|
||||
value = score;
|
||||
if value > alpha then alpha = value;
|
||||
end;
|
||||
end;
|
||||
else do;
|
||||
/* put skip list ( 'even depth, score: ', score ); */
|
||||
if ScoreLose = score then return ( ScoreLose );
|
||||
if score < value then do;
|
||||
/* put skip list ( 'score < value, alpha and beta ', score, value, alpha, beta ); */
|
||||
if score <= alpha then return ( score );
|
||||
value = score;
|
||||
if value < beta then beta = value;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
return ( value );
|
||||
end minmax;
|
||||
|
||||
winner: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 0 );
|
||||
if pieceBlank ^= p then do;
|
||||
if p = board(1) & p = board(2) then return ( p );
|
||||
if p = board(3) & p = board(6) then return ( p );
|
||||
end;
|
||||
|
||||
p = board(3);
|
||||
if PieceBlank ^= p & p = board(4) & p = board(5) then return ( p );
|
||||
|
||||
p = board(6);
|
||||
if PieceBlank ^= p & p = board(7) & p = board(8) then return ( p );
|
||||
|
||||
p = board(1);
|
||||
if PieceBlank ^= p & p = board(4) & p = board(7) then return ( p );
|
||||
|
||||
p = board(2);
|
||||
if PieceBlank ^= p & p = board(5) & p = board(8) then return ( p );
|
||||
|
||||
p = board(4);
|
||||
if pieceBlank ^= p then do;
|
||||
if p = board(0) & p = board(8) then return ( p );
|
||||
if p = board(2) & p = board(6) then return ( p );
|
||||
end;
|
||||
|
||||
return ( pieceBlank );
|
||||
end winner;
|
||||
|
||||
winner2: proc( m ) returns ( binary(7) );
|
||||
dcl m binary(7);
|
||||
dcl v binary(7);
|
||||
|
||||
v = board( m );
|
||||
|
||||
/* the 'if' expressions below can't be combined or the DOS version of
|
||||
PL/I generates bad code. */
|
||||
|
||||
go to q( m );
|
||||
q(0):
|
||||
if ( v = board(1) & v = board(2) ) then return ( v );
|
||||
if ( v = board(3) & v = board(6) ) then return ( v );
|
||||
if ( v = board(4) & v = board(8) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
/* this generates bad code from PL/I-86 Compiler Version 1.0 Digital Research, Inc.
|
||||
if ( ( ( v = board(1) ) & ( v = board(2) ) |
|
||||
( ( v = board(3) ) & ( v = board(6) ) |
|
||||
( ( v = board(4) ) & ( v = board(8) ) ) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
*/
|
||||
q(1):
|
||||
if ( v = board(0) & v = board(2) ) then return ( v );
|
||||
if ( v = board(4) & v = board(7) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(2):
|
||||
if ( v = board(0) & v = board(1) ) then return ( v );
|
||||
if ( v = board(5) & v = board(8) ) then return ( v );
|
||||
if ( v = board(4) & v = board(6) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(3):
|
||||
if ( v = board(4) & v = board(5) ) then return ( v );
|
||||
if ( v = board(0) & v = board(6) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(4):
|
||||
if ( v = board(0) & v = board(8) ) then return ( v );
|
||||
if ( v = board(2) & v = board(6) ) then return ( v );
|
||||
if ( v = board(1) & v = board(7) ) then return ( v );
|
||||
if ( v = board(3) & v = board(5) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(5):
|
||||
if ( v = board(3) & v = board(4) ) then return ( v );
|
||||
if ( v = board(2) & v = board(8) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(6):
|
||||
if ( v = board(7) & v = board(8) ) then return ( v );
|
||||
if ( v = board(0) & v = board(3) ) then return ( v );
|
||||
if ( v = board(4) & v = board(2) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(7):
|
||||
if ( v = board(6) & v = board(8) ) then return ( v );
|
||||
if ( v = board(1) & v = board(4) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
q(8):
|
||||
if ( v = board(6) & v = board(7) ) then return ( v );
|
||||
if ( v = board(2) & v = board(5) ) then return ( v );
|
||||
if ( v = board(0) & v = board(4) ) then return ( v );
|
||||
return ( pieceBlank );
|
||||
endq:
|
||||
|
||||
return ( pieceBlank );
|
||||
end winner2;
|
||||
|
||||
func0: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 0 );
|
||||
if ( p = board( 1 ) & p = board( 2 ) ) then return( p );
|
||||
if ( p = board( 3 ) & p = board( 6 ) ) then return( p );
|
||||
if ( p = board( 4 ) & p = board( 8 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func0;
|
||||
|
||||
func1: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 1 );
|
||||
if ( p = board( 0 ) & p = board( 2 ) ) then return( p );
|
||||
if ( p = board( 4 ) & p = board( 7 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func1;
|
||||
|
||||
func2: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 2 );
|
||||
if ( p = board( 0 ) & p = board( 1 ) ) then return( p );
|
||||
if ( p = board( 5 ) & p = board( 8 ) ) then return( p );
|
||||
if ( p = board( 4 ) & p = board( 6 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func2;
|
||||
|
||||
func3: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 3 );
|
||||
if ( p = board( 4 ) & p = board( 5 ) ) then return( p );
|
||||
if ( p = board( 0 ) & p = board( 6 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func3;
|
||||
|
||||
func4: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 4 );
|
||||
if ( p = board( 0 ) & p = board( 8 ) ) then return( p );
|
||||
if ( p = board( 2 ) & p = board( 6 ) ) then return( p );
|
||||
if ( p = board( 1 ) & p = board( 7 ) ) then return( p );
|
||||
if ( p = board( 3 ) & p = board( 5 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func4;
|
||||
|
||||
func5: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 5 );
|
||||
if ( p = board( 3 ) & p = board( 4 ) ) then return( p );
|
||||
if ( p = board( 2 ) & p = board( 8 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func5;
|
||||
|
||||
func6: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 6 );
|
||||
if ( p = board( 7 ) & p = board( 8 ) ) then return( p );
|
||||
if ( p = board( 0 ) & p = board( 3 ) ) then return( p );
|
||||
if ( p = board( 4 ) & p = board( 2 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func6;
|
||||
|
||||
func7: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 7 );
|
||||
if ( p = board( 6 ) & p = board( 8 ) ) then return( p );
|
||||
if ( p = board( 1 ) & p = board( 4 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func7;
|
||||
|
||||
func8: proc returns ( binary(7) );
|
||||
dcl p binary(7);
|
||||
|
||||
p = board( 8 );
|
||||
if ( p = board( 6 ) & p = board( 7 ) ) then return( p );
|
||||
if ( p = board( 2 ) & p = board( 5 ) ) then return( p );
|
||||
if ( p = board( 0 ) & p = board( 4 ) ) then return( p );
|
||||
|
||||
return( 0 );
|
||||
end func8;
|
||||
|
||||
readcommandtail: proc returns ( binary );
|
||||
dcl dbuff_ptr pointer,
|
||||
command character(127) varying based ( dbuff_ptr );
|
||||
dcl memory (0:256) bit(8) based( dbuff_ptr );
|
||||
dcl ( r, v, x ) binary;
|
||||
|
||||
r = 0;
|
||||
|
||||
dbuff_ptr = dbuff();
|
||||
/*put edit ('Command Tail: ',command) (a);*/
|
||||
|
||||
/* command tail is bytes with length, space, and the command-line arguments */
|
||||
|
||||
if 0 ^= memory( 0 ) then do;
|
||||
do x = 2 to 10;
|
||||
v = memory( x );
|
||||
if v < 48 | v > 57 then return ( r );
|
||||
r = ( r * 10 ) + v - 48;
|
||||
end;
|
||||
end;
|
||||
|
||||
return ( r );
|
||||
end readcommandtail;
|
||||
|
||||
getticks: proc returns ( binary );
|
||||
dcl ( hour, minute, second, fraction ) binary(7);
|
||||
call gettime( addr(hour), addr(minute), addr(second), addr(fraction) );
|
||||
return ( minute * 60 * 100 + second * 100 + fraction );
|
||||
end getticks;
|
||||
|
||||
end ttt;
|
Loading…
Reference in New Issue
Block a user