digital research pl/i-86 v1.0

This commit is contained in:
davidly 2024-06-30 12:01:25 -07:00
parent 349e15087f
commit 643f795c5a
87 changed files with 72770 additions and 0 deletions

View File

@ -0,0 +1,6 @@
a:
procedure(x) returns (float); /* external procedure */
declare x float;
return (x/2);
end a;


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


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


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


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


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


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


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


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


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


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


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


Binary file not shown.

Binary file not shown.

Binary file not shown.

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


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


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


View 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


Binary file not shown.

Binary file not shown.

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


Binary file not shown.

Binary file not shown.

View 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


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


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


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


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


View 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


Binary file not shown.

Binary file not shown.

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


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


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


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


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


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


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


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


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


Binary file not shown.

Binary file not shown.

Binary file not shown.

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


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


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


View File

@ -0,0 +1,4 @@
%replace
maxrow by 26,
maxcol by 40;


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


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


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


View 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


File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View 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.


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


View 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


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


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


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


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


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


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


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


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


Binary file not shown.

Binary file not shown.

View 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


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


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


Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

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

View 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

View File

@ -0,0 +1,6 @@
ntvdm pli.exe %1 $L
ntvdm link86 %1,pcdio.obj,plilib.l86
ntvdm -c -p %1

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

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