seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 00:14:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
SAMPLE CODE/PLI PROG SAMPLE CODE/A.PLI Normal file
View File

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


34
SAMPLE CODE/PLI PROG SAMPLE CODE/ACK.PLI Normal file
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;


45
SAMPLE CODE/PLI PROG SAMPLE CODE/ACKTST.PLI Normal file
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;


35
SAMPLE CODE/PLI PROG SAMPLE CODE/ALLTST.PLI Normal file
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;


83
SAMPLE CODE/PLI PROG SAMPLE CODE/ANNUITY.PLI Normal file
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;


35
SAMPLE CODE/PLI PROG SAMPLE CODE/CALL.PLI Normal file
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;


24
SAMPLE CODE/PLI PROG SAMPLE CODE/COPY.PLI Normal file
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;


81
SAMPLE CODE/PLI PROG SAMPLE CODE/COPYLPT.PLI Normal file
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;


49
SAMPLE CODE/PLI PROG SAMPLE CODE/CREATE.PLI Normal file
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;


33
SAMPLE CODE/PLI PROG SAMPLE CODE/DECPOLY.PLI Normal file
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;


15
SAMPLE CODE/PLI PROG SAMPLE CODE/DEMO.PLI Normal file
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;


297
SAMPLE CODE/PLI PROG SAMPLE CODE/DEPREC.PLI Normal file
View File

@@ -0,0 +1,297 @@
/*******************************************************/
/* This program calculates three kinds of depreciation */
/* schedules: straight_line, sum_of_the_years, and */
/* double_declining. */
/*******************************************************/
depreciate:
procedure options(main);
%replace
clear_screen by '^z',
indent by 15,
ITC_rate by .1,
bonus_rate by .1,
bonus_max by 2000;
declare
selling_price decimal(8,2),
adjusted_price decimal(8,2),
residual_value decimal(8,2),
year_value decimal(8,2),
depreciation_value decimal(8,2),
total_depreciation decimal(8,2),
book_value decimal(8,2),
tax_rate decimal(3,2),
sales_tax decimal(8,2),
tax_bracket decimal(2),
FYD decimal(8,2),
ITC decimal(8,2),
bonus_dep decimal(8,2),
months_remaining decimal(2),
new character(4),
factor decimal(2,1),
years decimal(2),
year_sum decimal(3),
current_year decimal(2),
select_sched character(1);
declare
copy_to_list character(4),
output file variable,
(sysprint, list) file;
declare
schedules character(3) static initial ('syd'),
schedule (0:3) entry variable;
schedule (0) = error;
schedule (1) = straight_line;
schedule (2) = sum_of_years;
schedule (3) = double_declining;
open file (sysprint) stream print pagesize(0)
title ('$con');
do while('1'b);
put list(clear_screen,'^i^i^iDepreciation Schedule');
put skip(3) list('^i^iSelling Price? ');
get list(selling_price);
put list('^i^iResidual Value? ');
get list(residual_value);
put list('^i^iSales Tax (%)? ');
get list(tax_rate);
put list('^i^iTax Bracket(%)? ');
get list(tax_bracket);
put list('^i^iProRate Months? ');
get list(months_remaining);
put list('^i^iHow Many Years? ');
get list(years);
put list('^i^iNew? (yes/no) ');
get list(new);
put edit('^i^iSchedule:',
'^i^iStraight (s)',
'^i^iSum-of-Yrs (y)',
'^i^iDouble Dec (d)? ') (a,skip);
get list(select_sched);
put list('^i^iList? (yes/no) ');
get list(copy_to_list);
if copy_to_list = 'yes' then
open file(list) stream print title('$lst');
factor = 1.5;
if new = 'yes' then
factor = 2.0;
sales_tax = decimal(selling_price*tax_rate,12,2)/100+.005;
if new = 'yes' | selling_price <= 100000.00 then
ITC = selling_price * ITC_rate;
else
ITC = 100000 * ITC_rate;
bonus_dep = selling_price * bonus_rate;
if bonus_dep > bonus_max then
bonus_dep = bonus_max;
put list(clear_screen);
call display(sysprint);
if copy_to_list = 'yes' then
call display(list);
put skip list('^i^i^i Type RETURN to Continue');
get skip(2);
end;
/******************************************************/
/* This procedure displays the various depreciation */
/* schedules. It calls the appropriate schedule with */
/* an index into an array of entry constants. */
/******************************************************/
display:
procedure(f);
declare
f file;
output = f;
call schedule (index (schedules,select_sched));
end display;
/********************************************/
/* This is a global error recovery routine. */
/********************************************/
error:
procedure;
put file (output) edit('Invalid Schedule - Enter s, y, or d')
(page,column(indent),x(8),a);
call line();
end error;
/*******************************************************/
/* This procedure computes straight_line depreciation. */
/*******************************************************/
straight_line:
procedure;
adjusted_price = selling_price - bonus_dep;
put file (output) edit('S T R A I G H T L I N E')
(page,column(indent),x(14),a);
call header();
depreciation_value = adjusted_price - residual_value;
book_value = adjusted_price;
total_depreciation = 0;
do current_year = 1 to years;
year_value = decimal(depreciation_value/years,8,2) + .005;
if current_year = 1 then
do;
year_value = year_value * months_remaining / 12;
FYD = year_value;
end;
depreciation_value = depreciation_value - year_value;
total_depreciation = total_depreciation + year_value;
book_value = adjusted_price - total_depreciation;
call print_line();
end;
call summary();
end straight_line;
/*************************************************/
/* This procedure computes depreciation based on */
/* the sum_of_the_years. */
/*************************************************/
sum_of_years:
procedure;
adjusted_price = selling_price - bonus_dep;
put file (output) edit('S U M O F T H E Y E A R S')
(page,column(indent),x(11),a);
call header();
depreciation_value = adjusted_price - residual_value;
book_value = adjusted_price;
total_depreciation = 0;
year_sum = 0;
do current_year = 1 to years;
year_sum = year_sum + current_year;
end;
do current_year = 1 to years;
year_value = decimal(depreciation_value *
(years - current_year + 1),12,2)/ year_sum + .005;
if current_year = 1 then
do;
year_value = year_value * months_remaining / 12;
FYD = year_value;
end;
depreciation_value = depreciation_value - year_value;
total_depreciation = total_depreciation + year_value;
book_value = adjusted_price - total_depreciation;
call print_line();
end;
call summary();
end sum_of_years;
/********************************************/
/* This procedure computes double_declining */
/* depreciation. */
/********************************************/
double_declining:
procedure;
adjusted_price = selling_price - bonus_dep;
put file (output) edit('D O U B L E D E C L I N I N G')
(page,column(indent),x(10),a);
call header();
depreciation_value = adjusted_price - residual_value;
book_value = adjusted_price;
total_depreciation = 0;
do current_year = 1 to years
while (depreciation_value > 0);
year_value = decimal(book_value/years,8,2) * factor+.005;
if current_year = 1 then
do;
year_value = year_value * months_remaining / 12;
FYD = year_value;
end;
if year_value > depreciation_value then
year_value = depreciation_value;
depreciation_value = depreciation_value - year_value;
total_depreciation = total_depreciation + year_value;
book_value = adjusted_price - total_depreciation;
call print_line();
end;
call summary();
end double_declining;
/**************************************************/
/* This procedure prints an output header record. */
/**************************************************/
header:
procedure;
declare
new_or_used character(5);
if new = 'yes' then
new_or_used = ' New';
else
new_or_used = ' Used';
put file (output) edit(
'--------------------------------------------------',
'|',selling_price+sales_tax,new_or_used,
residual_value,' Residual Value|',
'|',months_remaining,' Months Left ',
tax_rate,'% Tax',tax_bracket,'% Tax Bracket|')
(2(skip,column(indent),a),
2(p'B$$,$$$,$$9.V99',a),
skip,column(indent),a,x(5),f(2),a,2(x(2),p'B99',a));
put file (output) edit(
'--------------------------------------------------',
'| Y | Depreciation | Depreciation | Book Value |',
'| r | For Year | Remaining | |',
'--------------------------------------------------')
(skip,column(indent),a);
end header;
/*******************************************/
/* This procedure prints the current line. */
/*******************************************/
print_line:
procedure;
put file (output) edit(
'|',current_year,
' |',year_value,
' |',depreciation_value,
' |',book_value,' |')
(skip,column(indent),a,f(2),4(a,p'$z,zzz,zz9v.99'));
end print_line;
/***************************************************/
/* This procedure prints the summary of values for */
/* each type of depreciation schedule. */
/***************************************************/
summary:
procedure;
declare
adj_ITC decimal(8,2),
total decimal(8,2),
direct decimal(8,2);
call line();
adj_ITC = ITC * 100 / tax_bracket;
total = FYD + sales_tax + adj_ITC + bonus_dep;
direct = total * tax_bracket / 100;
put file (output) edit(
'| First Year Reduction in Taxable Income |',
'--------------------------------------------------',
'| Depreciation ' ,FYD, '|',
'| Sales Tax ' ,sales_tax, '|',
'| ITC (Adjusted) ' ,adj_ITC, '|',
'| Bonus Depreciation ' ,bonus_dep, '|',
'| ------------- |',
'| Total for First Year ' ,total, '|',
'| Direct Reduction in Tax ' ,direct, '|')
(2(skip,column(indent),a),2(4(skip,column(indent),a,
p'$z,zzz,zz9v.99',x(3),a),skip,column(indent),a));
call line();
end summary;
/*******************************************/
/* This procedure prints a line of dashes. */
/*******************************************/
line:
procedure;
put file (output) edit(
'--------------------------------------------------')
(skip,column(indent),a);
end line;
end depreciate;

26
SAMPLE CODE/PLI PROG SAMPLE CODE/DFACT.PLI Normal file
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;


51
SAMPLE CODE/PLI PROG SAMPLE CODE/DIV2.A86 Normal file
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


19
SAMPLE CODE/PLI PROG SAMPLE CODE/DTEST.PLI Normal file
View File

@@ -0,0 +1,19 @@
/******************************************************/
/* 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;

62
SAMPLE CODE/PLI PROG SAMPLE CODE/ENTER.PLI Normal file
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;


70
SAMPLE CODE/PLI PROG SAMPLE CODE/EXPR1.PLI Normal file
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;


99
SAMPLE CODE/PLI PROG SAMPLE CODE/EXPR2.PLI Normal file
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;


60
SAMPLE CODE/PLI PROG SAMPLE CODE/FDIV2.A86 Normal file
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


18
SAMPLE CODE/PLI PROG SAMPLE CODE/FDTEST.PLI Normal file
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;


24
SAMPLE CODE/PLI PROG SAMPLE CODE/FFACT.PLI Normal file
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;


33
SAMPLE CODE/PLI PROG SAMPLE CODE/FLTPOLY.PLI Normal file
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;


39
SAMPLE CODE/PLI PROG SAMPLE CODE/FLTPOLY2.PLI Normal file
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;


51
SAMPLE CODE/PLI PROG SAMPLE CODE/FSCAN.PLI Normal file
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;


20
SAMPLE CODE/PLI PROG SAMPLE CODE/IFACT.PLI Normal file
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;


30
SAMPLE CODE/PLI PROG SAMPLE CODE/INVERT.PLI Normal file
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;


33
SAMPLE CODE/PLI PROG SAMPLE CODE/KEYFILE.PLI Normal file
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;


45
SAMPLE CODE/PLI PROG SAMPLE CODE/LABELS.PLI Normal file
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;


BIN
SAMPLE CODE/PLI PROG SAMPLE CODE/LIB86.EXE Normal file
View File

Binary file not shown.

BIN
SAMPLE CODE/PLI PROG SAMPLE CODE/LINK86.EXE Normal file
View File

Binary file not shown.

42
SAMPLE CODE/PLI PROG SAMPLE CODE/LOAN1.PLI Normal file
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;


221
SAMPLE CODE/PLI PROG SAMPLE CODE/LOAN2.PLI Normal file
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;


65
SAMPLE CODE/PLI PROG SAMPLE CODE/MAININVT.PLI Normal file
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;


4
SAMPLE CODE/PLI PROG SAMPLE CODE/MATSIZE.LIB Normal file
View File

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


267
SAMPLE CODE/PLI PROG SAMPLE CODE/NETWORK.PLI Normal file
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;


49
SAMPLE CODE/PLI PROG SAMPLE CODE/OPTIMIST.PLI Normal file
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;


BIN
SAMPLE CODE/PLI PROG SAMPLE CODE/RASM86.EXE Normal file
View File

Binary file not shown.

306
SAMPLE CODE/PLI PROG SAMPLE CODE/READ.ME Normal file
View File

@@ -0,0 +1,306 @@
*****************************
* R E L E A S E N O T E S *
*****************************
PROGRAMMER'S UTILITIES
VERSION 1.1
FOR THE IBM PERSONAL COMPUTER DISK OPERATING SYSTEM
Copyright (c) 1983 by Digital Research, Inc.
1-1
Programmer's Utilities Release Notes
These release notes pertain to both the software and
the documentation set for the Digital Research
product:
Programmer's Utilities
For the IBM Personal Computer
Disk Operating System
They provide the most current information regarding:
o changes and corrections to the software that
have been identified since the product was
released.
o errors or omissions in the documentation set
that could not be corrected because of the lead
time needed for production and printing.
Note: These release notes have been formatted so you
can print them on your own printer, cut them to size
(6 1/2 x 8 1/2), and place them in your manuals.
1-2
Programmer's Utilities Release Notes
LINK-86 Notes
A new command line option has been added to the
linker. The $MY option directs LINK-86 to send the
.MAP file to your line printer.
A new optional parameter has been added to the MAP
option. The NOCOMMON parameter directs LINK-86 to
suppress the listing of common segment names in the
MAP file.
LINK-86 now displays the filename and module name
indicating the location of an undefined symbol.
LINK-86 can now report three additional error
messages:
CLASS NOT FOUND - The class name specified in
the command line does not exist in any of the
files being linked.
GROUP NOT FOUND - The group name specified in
the command line does not exist in any of the
files being linked.
SEGMENT NOT FOUND - The segment name specified
in the command line does not exist in any of the
files being linked.
1-3
Programmer's Utilities Release Notes
RASM-86 NOTES
A new command line option has been added to the RASM-
86 assembler. The $NC option directs RASM-86 not to
convert letters in symbol names to uppercase. This
feature supports users of the C language.
RASM-86 Version 1.3 now supports 8087 opcodes.
However, RASM-86 does not allow types other than
byte, word, and double-word. Therefore, in order to
support the 8087 instructions, the form of the RASM-
86 instruction is slightly different from the Intel
convention.
All memory reference instructions have two characters
appended to the end of the opcode name. The two
characters represent the number of bits referenced by
the instruction. For example,
FADD64 byte ptr my_var
This instruction assumes that my_var contains 64 bits
(4 bytes). This convention applies to all 8087
instructions that reference user memory, except those
that always reference the same number of bits (i.e.
FSTCW).
Also, in the Intel convention, any instruction that
is followed by a P causes the stack to be popped. In
RASM-86, the P follows the number of bits. For
example,
FSUB80P byte ptr my_var; sub and pop temp real
We recommend that you carefully study all the Intel
documentation about the 8087 coprocessor and its
opcodes before using them in RASM-86.
1-4
Programmer's Utilities Release Notes
END OF READ.ME FILE
1-5

311
SAMPLE CODE/PLI PROG SAMPLE CODE/README.MARKDOWN Normal file
View File

@@ -0,0 +1,311 @@
Here are some sample programs, and utilities for PL/I for PC-DOS
/READ.ME
*****************************
* R E L E A S E N O T E S *
*****************************
PROGRAMMER'S UTILITIES
VERSION 1.1
FOR THE IBM PERSONAL COMPUTER DISK OPERATING SYSTEM
Copyright (c) 1983 by Digital Research, Inc.
1-1
Programmer's Utilities Release Notes
These release notes pertain to both the software and
the documentation set for the Digital Research
product:
Programmer's Utilities
For the IBM Personal Computer
Disk Operating System
They provide the most current information regarding:
o changes and corrections to the software that
have been identified since the product was
released.
o errors or omissions in the documentation set
that could not be corrected because of the lead
time needed for production and printing.
Note: These release notes have been formatted so you
can print them on your own printer, cut them to size
(6 1/2 x 8 1/2), and place them in your manuals.
1-2
Programmer's Utilities Release Notes
LINK-86 Notes
A new command line option has been added to the
linker. The $MY option directs LINK-86 to send the
.MAP file to your line printer.
A new optional parameter has been added to the MAP
option. The NOCOMMON parameter directs LINK-86 to
suppress the listing of common segment names in the
MAP file.
LINK-86 now displays the filename and module name
indicating the location of an undefined symbol.
LINK-86 can now report three additional error
messages:
CLASS NOT FOUND - The class name specified in
the command line does not exist in any of the
files being linked.
GROUP NOT FOUND - The group name specified in
the command line does not exist in any of the
files being linked.
SEGMENT NOT FOUND - The segment name specified
in the command line does not exist in any of the
files being linked.
1-3
Programmer's Utilities Release Notes
RASM-86 NOTES
A new command line option has been added to the RASM-
86 assembler. The $NC option directs RASM-86 not to
convert letters in symbol names to uppercase. This
feature supports users of the C language.
RASM-86 Version 1.3 now supports 8087 opcodes.
However, RASM-86 does not allow types other than
byte, word, and double-word. Therefore, in order to
support the 8087 instructions, the form of the RASM-
86 instruction is slightly different from the Intel
convention.
All memory reference instructions have two characters
appended to the end of the opcode name. The two
characters represent the number of bits referenced by
the instruction. For example,
FADD64 byte ptr my_var
This instruction assumes that my_var contains 64 bits
(4 bytes). This convention applies to all 8087
instructions that reference user memory, except those
that always reference the same number of bits (i.e.
FSTCW).
Also, in the Intel convention, any instruction that
is followed by a P causes the stack to be popped. In
RASM-86, the P follows the number of bits. For
example,
FSUB80P byte ptr my_var; sub and pop temp real
We recommend that you carefully study all the Intel
documentation about the 8087 coprocessor and its
opcodes before using them in RASM-86.
1-4
Programmer's Utilities Release Notes
END OF READ.ME FILE
1-5

8
SAMPLE CODE/PLI PROG SAMPLE CODE/RECORD.DCL Normal file
View File

@@ -0,0 +1,8 @@
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;

55
SAMPLE CODE/PLI PROG SAMPLE CODE/REPORT.PLI Normal file
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;


56
SAMPLE CODE/PLI PROG SAMPLE CODE/RETRIEVE.PLI Normal file
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;


54
SAMPLE CODE/PLI PROG SAMPLE CODE/REVERSE.PLI Normal file
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;


34
SAMPLE CODE/PLI PROG SAMPLE CODE/REVERT.PLI Normal file
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;


24
SAMPLE CODE/PLI PROG SAMPLE CODE/RFACT.PLI Normal file
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;


41
SAMPLE CODE/PLI PROG SAMPLE CODE/SAMPLE.PLI Normal file
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;


35
SAMPLE CODE/PLI PROG SAMPLE CODE/TEST.PLI Normal file
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;


67
SAMPLE CODE/PLI PROG SAMPLE CODE/UPDATE.PLI Normal file
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;


BIN
SAMPLE CODE/PLI PROG SAMPLE CODE/XREF86.EXE Normal file
View File

Binary file not shown.