|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 16896 (0x4200)
Types: TextFileVerbose
Names: »tsqrttest«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »tsqrttest«
job bbl 3 600 time 11 0 perm mini 100 1 size 92000
(
pascal80 codesize.12000 spacing.12000 debugenvir
bsqrttest = set 1 mini
bsqrttest = move pass6code
if ok.yes
scope user bsqrttest
finis)
(* process "sqrttest", 25/8/80, pemn.
this program tests the modules: realtype, linttype and zontype.
*)
process sqrttest( var sysvector : system_vector );
(*
module : zonetype.
pemn, 22/8/80.
adopted from a module ( testopen testout ) by wib and stb.
*)
type
buffertype = record
first, last, next : integer;
name : alfa;
data : array ( 1 .. 80 ) of char
end;
zone = record
testoutpool : pool 1 of buffertype;
testoutsem : semaphore;
opsem : ^ semaphore;
opref : reference
end;
procedure outopen (
var z: zone;
modulename: alfa;
ps: ^semaphore);
var
opref: reference;
\f
begin
z.opsem:= ps;
while openpool(z.testoutpool) do
begin
alloc (opref, z.testoutpool, z.testoutsem);
opref^.u1:= 2;
lock opref as opbuf: buffertype do
with opbuf do
begin
first:= 6+alfalength;
next:= 1;
name:= modulename;
end (* with opbuf do *);
return(opref);
end; (* while openpool *)
end (* testopen *);
\f
procedure outchar( var z : zone; ch : char );
(* writes the ch into the output buffer . *)
begin
if nil( z. opref ) then
begin
wait( z.opref, z. testoutsem );
lock z.opref as opbuf : buffertype do
with opbuf do
begin
data( 1 ) := ch;
next := 2
end
end
else
lock z.opref as opbuf : buffertype do
with opbuf do
begin
data( next ) := ch;
next:= next + 1;
end;
end (* outchar *);
\f
procedure outinteger(var z:zone;int,positions:integer);
(* writes the integer "int" into opbuf starting at
"outputpoint", which is updated accordingly *)
const
maxpos = 20; (* max number of positions in layout *)
base = 10;
var
digits:array(1..maxpos) of char;
used,i:integer;
negative:boolean;
begin
(* first we initialise the digits array *)
for i:=1 to maxpos do digits(i):=sp;
i:=maxpos;
negative:= int<0;
int:=abs(int);
repeat
(* now we unpack the digits backwards and put them
into the digits array *)
digits(i):= chr(int mod base + ord("0"));
int:=int div base;
i:=i-1;
until (i=1) or (int=0);
if negative then
begin
digits(i):="-";
i:=i-1;
end;
used:=maxpos-i;
if int <> 0 then digits(1):= "*";
(* i n{ste linje skal 20 erstattes af maxpos !!!!!!!!!!!!!!!!!!!!!!!*)
if (not (positions in (. 1 .. 20 .)) )
or (positions < used) then
positions:=used;
for i:=maxpos+1-positions to maxpos do
outchar( z, digits(i) );
end (* out integer *);
\f
procedure outstring( var z:zone; text: alfa);
(* writes the text into opbuf starting at opbuf.next
which is updated accordingly *)
var
i: integer;
begin
for i:=1 to alfalength do
outchar( z, text(i) );
end (* out string *);
\f
procedure outnl( var z : zone );
begin
outchar( z, nl );
with z do begin
lock opref as opbuf : buffertype do
with opbuf do
last := next + 16;
opref^ .u2 := 0;
signal( opref, opsem^ )
end
end;
procedure outclose( var z : zone );
begin
with z do
begin
if not nil( opref ) then outnl( z );
wait( opref, testoutsem );
release( opref )
end
end;
var
z : zone;
i : integer;
procedure error( kind, where : integer );
forward;
(*
module: lint_type
22/8/80, pemn.
*)
const
int___n = 32767;
(* the range of values of the standard type "integer"
must contain the closed interval: [ -int___n .. int___n ]
*)
lint___base = 181;
(* the value of "lint___base" is the base of the ( multi-length )
integer of the type "lint". the value must satisfy:
lint___base <= sqrt( int___n + 1 )
*)
lint___digits = 30;
(* the value of "lint___digits" is the number of digits ( base:
"lint___base" ) in the ( multi-length ) integers of the type "lint" .
*)
type
lint = array ( 1 .. lint___digits ) of integer;
(* the value l of the type "lint" is defined to be:
l[1] + l[2]*( lint___base**1 ) + l[3]*( lint___base**2 ) + ......
......+ l[k]*( lint___base**(k-1) ) + ...............
ending with k=lint___digits.
The vlues of the digits l[i] must satisfy:
-lint___base <= l[ lint___digits ] < lint___base
and 0 <= l[k] < lint___base , for k= 1,2....(lint___digits - 1 ) .
reference: Chr. Gram et al : Datamatik, vol 2, Regnecentralen/Studentlitteratur.
*)
function lint_lt_zero( li : lint ) : boolean;
forward;
function lint_eq( la, lb : lint ) : boolean;
forward;
function lint_neg( li : lint ) : lint;
forward;
function lint_eq_zero( li : lint ) : boolean;
forward;
procedure lint___exception( kind, where : integer );
begin
(* this procedure is called by routines in this prefix
when the specified function cannot be performed. It may
also be called similar procedures on a higher level of
abstraction.
*)
error( kind, where )
end;
function lint_from_integer( i : integer ) : lint;
var
a : lint;
k : integer;
begin
if i < 0 then
a := lint_neg( lint_from_integer( -i ) )
else
for k := 1 to lint___digits do
begin
a(k) := i mod lint___base;
i := i div lint___base
end;
lint_from_integer := a
end;
function lint_neg( li : lint ) : lint;
var
digit, carry : integer;
r : lint;
k : integer;
begin
carry := 0;
for k := 1 to ( lint___digits - 1 ) do
begin
digit := lint___base - carry -li(k);
if digit = lint___base then digit := 0
else
carry := 1;
r(k) := digit
end;
digit := -li( lint___digits ) - carry;
if digit = lint___base then
lint___exception( 1, 1 )
else
r( lint___digits ) := digit;
lint_neg := r
end;
function lint_abs( li : lint ) : lint;
begin
if lint_lt_zero( li ) then
lint_abs := lint_neg( li )
else
lint_abs := li
end;
function lint_add( la, lb : lint ) : lint;
var
k : integer;
r : lint;
digit, carry : integer;
begin
carry := 0;
for k := 1 to lint___digits do
begin
digit := la(k) + lb(k) + carry;
if digit >= lint___base then
begin
carry := 1;
digit := digit - lint___base
end
else
carry := 0;
r(k) := digit
end;
if ( carry = 1 ) or ( r( lint___digits ) < ( - lint___base ) ) then
lint___exception( 1, 2 );
lint_add := r
end;
function lint_sub( la, lb : lint ) : lint;
begin
lint_sub := lint_add( la, lint_neg( lb ) )
end;
function lint_mult( la, lb : lint ) : lint;
var
sign : boolean;
r : lint;
kk, k, i, j : integer;
c, prod, mente, ciffer : integer;
begin
sign := false;
if lint_lt_zero( la ) then
begin
sign := not sign; la := lint_neg( la )
end;
if lint_lt_zero( lb ) then
begin
sign := not sign; lb := lint_neg( lb )
end;
for k := 1 to lint___digits do r( k ) := 0;
for k := 1 to lint___digits do
for i := 1 to k do
begin
prod := la( i ) * lb( k - i + 1 );
mente := prod div lint___base;
ciffer := prod - mente * lint___base;
kk := k;
repeat
begin
if kk > lint___digits then lint___exception( 1, 3 );
c := r( kk ) + ciffer; r( kk ) := c;
if c >= lint___base then
begin
mente := mente + 1;
r( kk ) := c - lint___base
end;
ciffer := mente;
mente := 0;
kk := kk + 1
end
until ciffer = 0
end (* i , k ...... *);
for i := 2 to lint___digits do
begin
c := la( i );
for j := lint___digits - i + 2 to lint___digits do
if c * lb( j ) <> 0 then lint___exception( 1, 4 )
end (* i .... *);
if sign then
lint_mult := lint_neg( r )
else
lint_mult := r
end;
procedure lint___quotient( la, lb : lint; var lq : lint; var lr : lint );
var
k, d, i, j : integer;
c1, qk, forrige_qk, ai, mente_j : integer;
rest_for_stor, equal : boolean;
begin
if lint_lt_zero( lb ) then lint___exception( 2, 5 );
if lint_eq_zero( lb ) then lint___exception( 2, 6 );
for k := 1 to lint___digits do lq( k ) := 0;
d := lint___digits;
while lb( d ) = 0 do d := d - 1;
c1 := lb( d );
for k := lint___digits - d + 1 downto 1 do
begin
i := k + d - 1;
forrige_qk := 0;
repeat
ai := la( i );
if ai >= 0 then
qk := ai div c1
else
qk := ( ai - c1 + 1 ) div c1;
if qk = - forrige_qk then
begin
if qk < 0 then
qk := qk + 1
else
qk := qk - 1
end;
forrige_qk := qk;
mente_j := la( k ) - lb( 1 ) * qk; la( k ) := mente_j;
for j := 2 to d do
begin
if mente_j >= 0 then
mente_j := mente_j div lint___base
else
mente_j := ( mente_j - lint___base + 1 ) div lint___base;
la( k + j - 2 ) := la( k + j - 2 ) - mente_j * lint___base;
mente_j := la( k + j - 1 ) + mente_j - lb( j ) * qk;
la( k + j - 1 ) := mente_j
end;
lq( k ) := lq( k ) + qk;
if mente_j >= 0 then
begin
j := d; equal := true; rest_for_stor := true;
repeat
if la( k + j - 1 ) <> lb( j ) then
begin
equal := false;
if la( k + j - 1 ) < lb( j ) then rest_for_stor := false
end;
j := j - 1
until
( not equal ) or ( j = 0 )
end
until
( not rest_for_stor ) and ( mente_j >= 0 );
if k > 1 then
begin
la( i - 1 ) := la( i - 1 ) + la( i ) * lint___base;
la( i ) := 0
end
end (* for k:= ...... *);
lr := la
end;
function lint_div( la, lb : lint ) : lint;
var
lq, lr : lint;
begin
lint___quotient( la, lb, lq, lr );
lint_div := lq
end;
function lint_mod( la, lb : lint ) : lint;
var
lq, lr : lint;
begin
lint___quotient( la, lb, lq, lr );
lint_mod := lr
end;
function lint_lt_zero( li : lint ) : boolean;
begin
lint_lt_zero := li( lint___digits ) < 0
end;
function lint_lt( la, lb : lint ) : boolean;
var
eq, lt : boolean;
k : integer;
begin
eq := true; lt := false;
k := lint___digits;
while ( k >= 1 ) and eq do
begin
if la( k ) <> lb( k ) then
begin
eq := false;
lt := la( k ) < lb( k )
end;
k := k - 1
end;
lint_lt := lt
end;
function lint_eq_int( li : lint; i : integer ) : boolean;
begin
lint_eq_int := lint_eq( li, lint_from_integer( i ) )
end;
function lint_eq_zero( li : lint ) : boolean;
var
eq : boolean;
k : integer;
begin
eq := true; k := 1;
while ( k <= lint___digits ) and eq do
begin
if li( k ) <> 0 then eq := false;
k := k + 1
end;
lint_eq_zero := eq
end;
function lint_eq( la, lb : lint ) : boolean;
var
eq : boolean;
k : integer;
begin
eq := true; k := 1;
while ( k <= lint___digits ) and eq do
begin
if la( k ) <> lb( k ) then eq := false;
k := k + 1
end;
lint_eq := eq
end;
procedure lint_output( var z : zone; zeroes : boolean; li : lint; positions : integer );
const
g1 = 10;
max_digits = 50;
var
a1 : array ( 1 .. max_digits ) of integer;
i, j, ciffer, mente, d, bl : integer;
sign : boolean;
begin
if lint_lt_zero( li ) then
begin
sign := true;
li := lint_neg( li )
end
else
sign := false;
(* convert "li" to base 10 in "a1" : *)
for j := 1 to max_digits do a1( j ) := 0;
for i := lint___digits downto 1 do
begin
mente := li( i );
for j := 1 to max_digits do
begin
ciffer := a1( j ) * lint___base + mente;
mente := ciffer div g1;
a1( j ) := ciffer - mente * g1
end;
if mente > 0 then lint___exception( 3, 7 )
end;
d := 1;
for i := 2 to max_digits do
if a1( i ) <> 0 then d := i;
bl := positions - d;
if sign then bl := bl - 1;
if zeroes then
begin
if sign then outchar( z, '-' );
for i := 1 to bl do outchar( z, '0' )
end
else
begin
for i := 1 to bl do outchar( z, ' ' );
if sign then outchar( z, '-' )
end;
for i := d downto 1 do
outchar( z, chr( a1( i ) + ord( '0' ) ) )
end;
(*
module: real_type.
pemn, 21/8/80.
a value r of type "real" is represented as a fraction c/d, where c and
d are ( multilength ) integer values of type "lint" satisfying:
d <> 0 and c and d are relative prime.
reference: D.Knuth: Semi numarical algorithms, sec. 4.5.1 .
*)
type
real = record
c, d : lint
end;
procedure real_output( var z : zone; r : real; positions, decimals : integer );
forward;
procedure real___exception( kind, where : integer );
(* kind =
1 , the function is not implemented.
2 , divisor is zero.
*)
begin
(* this procedure is called by routines in this prefix
when the specified function cannot be performed. *)
lint___exception( 0, kind * 100 + where )
end;
function real_from_integer( i : integer ) : real;
var
r : real;
begin
with r do
begin
c := lint_from_integer( i );
d := lint_from_integer( 1 )
end;
real_from_integer := r
end;
function real_const( char_rep : alfa ) : real;
begin
real___exception( 1, 1 );
real_const := real_from_integer( 0 )
end;
function real_to_integer( r : real ) : integer;
begin
real___exception( 1, 2 );
real_to_integer := 0
end;
function real___normalize( r : real ) : real;
var
u, v, w : lint;
r1 : real;
begin
u := lint_abs( r.c );
v := lint_abs( r.d );
while not lint_eq_zero( v ) do
begin
w := lint_mod( u, v );
u := v;
v:= w
end;
if lint_eq_int( u, 1 ) then
real___normalize := r
else
begin
r1.c := lint_div( r.c, u );
r1.d := lint_div( r.d, u );
real___normalize := r1
end
end;
function real_neg( r : real ) : real;
var
r1 : real;
begin
with r1 do
begin
c := lint_neg( r.c );
d := r.d
end;
real_neg := r1
end;
function real_abs( r : real ) : real;
var
r1 : real;
begin
with r1 do
begin
c := lint_abs( r.c );
d := lint_abs( r.d )
end;
real_abs := r1
end;
function real_add( r1, r2 : real ) : real;
var
r : real;
begin
with r do
begin
c := lint_add( lint_mult( r1.c, r2.d ), lint_mult( r2.c, r1.d ) );
d := lint_mult( r1.d, r2.d )
end;
real_add := real___normalize( r )
end;
function real_sub( r1, r2 : real ) : real;
var
r : real;
l1,l2 : lint;
begin
with r do
begin
l1:= lint_mult( r1.c, r2.d );
lint_output( z, false, l1, 20 ); outnl( z );
l2:= lint_mult( r2.c, r1.d );
lint_output( z, false, l2, 20 ); outnl( z );
c:= lint_sub( l1, l2 );
d := lint_mult( r1.d, r2.d );
lint_output( z, false, c, 20 ); outnl( z );
lint_output( z, false, d, 20 ); outnl( z );
end;
real_sub := real___normalize( r )
end;
function real_mult( r1, r2 : real ) : real;
var
r : real;
begin
with r do
begin
c := lint_mult( r1.c, r2.c );
d := lint_mult( r1.d, r2.d )
end;
real_mult := real___normalize( r )
end;
function real_div( r1, r2 : real ) : real;
var
r : real;
begin
if lint_eq_zero( r2.c ) then real___exception( 2, 3 );
with r do
begin
c := lint_mult( r1.c, r2.d );
d := lint_mult( r2.c, r1.d )
end;
real_div := real___normalize( r )
end;
function real_lt( r1, r2 : real ) : boolean;
var
l1,l2 : lint;
s1, s2 : boolean;
begin
s1 := lint_lt_zero( r1.d );
s2 := lint_lt_zero( r2.d );
l1 := lint_mult( r1.c, r2.d );
l2 := lint_mult( r1.d, r2.c );
if s1 = s2 then
real_lt := lint_lt( l1, l2 )
else
real_lt := lint_lt( l2, l1 )
end;
function real_sqrt( var z : zone; x : real; eps : real ) : real;
var
x0, x1 : real;
y0, y1 : real;
b : boolean;
begin
(* newton's method.
x must satisfy: x > 1 .
*)
x1 := x;
repeat
x0 := x1;
x1 := real_div( real_add( x0, real_div ( x, x0 ) ), real_from_integer( 2 ) );
real_output( z, x1, 10, 5 ); outnl( z );
y0 := real_sub( x1, x0 ); real_output( z, y0, 10, 5 ); outnl( z );
y1 := real_mult( eps, x1 ); real_output( z, y1, 10, 5 ); outnl( z );
y0 := real_abs( y0 ); real_output( z, y0, 10, 5 ); outnl( z );
b := real_lt( y0, y1 );
if b then outstring( z, 'true ' )
else outstring( z, 'false ' ); outnl( z );
until
b;
real_sqrt := x0
end;
procedure real_output( var z : zone; r : real; positions, decimals : integer );
var
sign : boolean;
li10 : lint;
lf, li : lint;
i : integer;
begin
if lint_lt_zero( r.d ) then
begin
r.d := lint_neg( r.d );
r.c := lint_neg( r.c )
end;
if lint_lt_zero( r.c ) then
begin
sign := true;
r.c := lint_neg( r.c )
end
else
sign := false;
li := lint_div( r.c, r.d );
if lint_eq_zero( li ) and sign then
begin
for i := 1 to positions - decimals - 3 do outchar( z, ' ' );
outchar( z, '-' ); outchar( z, '0' )
end
else
begin
if sign then li := lint_neg( li );
lint_output( z, false, li, positions - decimals - 1 );
end;
outchar( z, '.' );
lf := lint_mod( r.c, r.d );
li := lint_from_integer( 1 ); li10 := lint_from_integer( 10 );
for i := 1 to decimals do li := lint_mult( li, li10 );
lint_output( z, true, lint_div( lint_mult( lf, li ), r.d ), decimals )
end;
var
eps : real;
procedure error( kind, where : integer );
begin
outnl( z );
outstring( z, ' error: ' );
outinteger( z, kind, 5 ); outinteger( z, where, 5 );
outnl( z );
outclose( z );
(* terminate the execution by provoking an exception: *)
kind := 0; kind := kind div kind
end;
begin
outopen( z, own.incname, sysvector( operatorsem ) );
outstring( z, 'sqrt table: ' ); outnl( z );
eps := real_div( real_from_integer( 1 ), real_from_integer( 100 ) );
outstring( z, 'eps: ' );
real_output( z, eps, 10, 6 );
outnl( z );
outinteger( z, 1, 3 ); outchar( z, ':' );
real_output( z, real_from_integer( 1 ), 10, 3 );
outnl( z );
for i := 2 to 10 do
begin
outinteger( z, i, 3 ); outchar( z, ':' );
real_output( z, real_sqrt( z, real_from_integer( i ) , eps ), 10, 3 );
outnl( z )
end;
outstring( z, 'end program ' ); outnl( z );
outclose( z )
end.
«eof»