IEEE Calculator (part 2 of 6)
sources-request at panda.UUCP
sources-request at panda.UUCP
Wed Sep 4 07:57:57 AEST 1985
Mod.sources: Volume 3, Issue 4
Submitted by: decvax!decwrl!sun!dgh!dgh (David Hough)
#! /bin/sh
: make a directory, cd to it, and run this through sh
echo If this kit is complete, "End of Kit" will echo at the end
echo Extracting calc.p
cat >calc.p <<'End-Of-File'
program calculator (input, output) ;
(* File calc.p, Version 9 October 1984. *)
(* calc is a calculator style program to demonstrate the proposed
IEEE floating point arithmetic *)
#include 'sane.h'
#include 'oldfplib.h'
#include 'calctest.h'
#include 'calcsingle.h'
#include 'calcdouble.h'
#include 'global.i'
#include 'forward.i'
#include 'init.i'
#include 'divrem.i'
#include 'extra.i'
#include 'storage.i'
#include 'addsubpas.i'
#include 'utility.i'
#include 'function.i'
#include 'hex.i'
#include 'base.i'
procedure store (* var x : internal *) ;
(* Rounds x to current storage mode, setting exceptions accordingly,
then puts result back in internal format. *)
var
yx : cextended ;
yd : cdouble ;
ys : csingle ;
yi : cint64 ;
begin
case storagemode of
i16, i32, i64 : tointeger( storagemode, x, yi ) ;
flt32 : tosingle ( x, ys ) ;
f64 : todouble ( x, yd ) ;
ext80 : toextended ( x, yx ) ;
otherwise
end ;
end ;
procedure commandloop ;
var
c : char ;
s : strng ;
i,j : integer ;
found, exit : boolean ;
ps : pstack ;
badnan, x, y, z, r : internal ;
(* Rule is: x gets the top of stack, y the next,
for use in DOTEST *)
error : boolean ;
cc : conditioncode ;
oldtop : internal ; (* Saves previous top of stack, so we can tell when it
changes. New tops of stack are displayed. *)
heap : ^ integer ; (* Heap marker. *)
yx : cextended ;
yd : cdouble ;
yi : cint64 ;
xs, ys, zs : csingle ;
tx : real ;
es : integer ;
fpe : xcpn ;
buffer : strng ; (* Used to buffer multiple commands. *)
semipos : integer ; (* Used to record end of command. *)
fulldisplay : boolean ; (* Flag set at the end of a calculator operation;
if true, the top of stack will be displayed;
if false, only traps, if any, will be displayed. *)
procedure clear ;
(* Clears stack and heap. *)
begin
stack := nil ;
end ;
procedure docommand ( var found : boolean ) ;
var fpe : xcpn ;
procedure subc ;
var i : integer ;
begin
if sequal(s , 'COMPARE') then begin
found := true ;
popstack(x) ;
popstack(y) ;
compare( y, x, cc) ;
write(' Compare result: ') ;
case cc of
lesser : writeln(' < ') ;
equal : writeln(' = ' ) ;
greater : writeln(' > ') ;
notord : writeln(' Unordered ') ;
end ;
for i := 0 to 6 do yi[i] := 0 ;
yi[7] := ord(cc) ;
unpackinteger(yi,z,i16) ;
pushstack(z) ;
end else
if sequal(s , 'CLEAR') then begin (* CLEAR *) found := true ;
clear end
else if sequal(s , 'CRUNCH') then begin (* Clear stack except for top two entries. *)
found := true ;
popstack(x) ;
popstack(y) ;
clear ;
pushstack(y) ;
pushstack(x) ;
end
;
end ;
procedure subd ;
begin
if sequal(s , 'DUP') then begin (* Duplicate top of stack *)
popstack(x) ;
pushstack(x) ;
pushstack(x) ;
found := true ;
end
else if sequal(s , 'DIV') then begin
found := true ;
popstack(x) ;
popstack(y) ;
divrem( y, x, z, r ) ;
writeln(' REM: ') ;
display(r) ;
pushstack(z) ;
end else if sequal(s, 'DUMP') then begin (* DUMP STACK *)
found := true ;
ps := stack ;
while ps <> nil do begin
display(ps^.x ) ;
ps := ps^.next ;
end ;
end ;
end ;
procedure subRR ;
begin
if sequal(s, 'REV') then begin (* reverse top two entries on stack *)
found := true ;
popstack(x) ;
popstack(y) ;
pushstack(x) ;
pushstack(y) ;
end
else if sequal(s, 'REM') then begin
found := true ;
popstack(x) ;
popstack(y) ;
divrem( y, x, z, r ) ;
writeln(' DIV: ') ;
display(z) ;
pushstack(r) ;
end else if sequal(s, 'RN') then begin
found := true ;
fpstatus.mode.round := rnear ;
end
else if sequal(s, 'RM') then begin
found := true ;
fpstatus.mode.round := rneg ;
end
else if sequal(s, 'RP') then begin
found := true ;
fpstatus.mode.round := rpos ;
end
else if sequal(s, 'RZ') then begin
found := true ;
fpstatus.mode.round := rzero ;
end else if sequal(s, 'R24') then begin
found := true ;
fpstatus.mode.precision := sprec ; (* Round cextended to 24 significant bits. *)
end else if sequal(s, 'R53') then begin
found := true ;
fpstatus.mode.precision := dprec ;
(* Round cextended to 53 significant bits. *)
end end ;
procedure subS ;
begin
{
if sequal(s, 'SOFT') then begin
found := true ;
ffloat_ ; ffunc_ ;
end else if sequal(s, 'SKY') then begin
found := true ;
sfloat_ ; sfunc_ ;
end else }
if sequal(s, 'SCALE') then begin
found := true ;
popstack(x) ;
popstack(y) ;
cscale( y, x, z ) ;
pushstack( z ) ;
end else if sequal(s, 'SQRT') then begin
found := true ;
popstack(x) ;
csqrt( x, z) ;
pushstack(z) ;
end else if sequal(s, 'STOF32') then begin (* Set storage mode. *)
found := true ;
storagemode := flt32 ;
end
else if sequal(s, 'STOF64') then begin
found := true ;
storagemode := f64 ;
end
else if sequal(s, 'STOX80') then begin
found := true ;
storagemode := ext80 ;
end
else if sequal(s, 'STOI16') then begin
found := true ;
storagemode := i16 ;
end else if sequal(s, 'STOI32') then begin
found := true ;
storagemode := i32 ;
end else if sequal(s, 'STOI64') then begin
found := true ;
storagemode := i64
end
end ;
procedure subT ;
var yi : cint64 ;
begin
if sequal(s, 'TOF32') then begin (* Convert to csingle. *)
found := true ;
popstack(x);z:=x ;
tosingle( z, ys) ;
pushstack(z) ;
end else if sequal(s, 'TOF32I') then begin (* Convert to csingle integral. *)
found := true ;
popstack(x);z:=x ;
roundint( z, fpstatus.mode.round, sprec ) ;
tosingle( z, ys) ;
pushstack(z) ;
end else if sequal(s, 'TOF64') then begin (* Convert to cdouble. *)
found := true ;
popstack(x);z:=x ;
todouble( z, yd) ;
pushstack(z) ;
end else if sequal(s, 'TOF64I') then begin (* Convert to cdouble integral. *)
found := true ;
popstack(x);z:=x ;
roundint( z, fpstatus.mode.round, dprec ) ;
todouble( z, yd) ;
pushstack(z) ;
end else if sequal(s, 'TOX80' )then begin (* Convert to cextended. *)
found := true ;
popstack(x);z:=x ;
toextended( z, yx) ;
pushstack(z) ;
end else if sequal(s, 'TOX80I') then begin (* Convert to cextended integral. *)
found := true ;
popstack(x);z:=x ;
roundint( z, fpstatus.mode.round, xprec ) ;
toextended( z, yx) ;
pushstack(z) ;
end else if sequal(s, 'TOI16') then begin (* Convert to 16 bit integer. *)
found := true ;
popstack(x);z:=x ;
tointeger( i16, z, yi) ;
pushstack(z) ;
end else if sequal(s, 'TOI32') then begin (* Convert to 32 bit integer. *)
found := true ;
popstack(x);z:=x ;
tointeger( i32, z, yi) ;
pushstack(z) ;
end else if sequal(s, 'TOI64' )then begin (* Convert to 64 bit integer. *)
found := true ;
popstack(x);z:=x ;
tointeger(i64, z, yi) ;
pushstack(z) ;
end
else if sequal(s, 'TEST') then begin (* Toggle test flag *)
found := true ;
testflag := not testflag ;
end ;
end ;
begin
found := false ;
if length(s) > 0 then case s[1] of
'+' : if length(s)=1 then begin
found := true ;
popstack(x) ;popstack(y) ;
add( y, x, z ) ;
pushstack(z) ;
end ;
'-' : if length(s)=1 then begin
found := true ;
popstack(x) ;popstack(y) ;
r := x ; r.sign := not x.sign ;
add( y, r, z ) ;
pushstack(z) ;
end ;
'*' : if length(s)=1 then begin
found := true ;
popstack(x) ; popstack(y) ;
multiply ( y, x, z) ;
pushstack(z) ;
end ;
'/' : if length(s)=1 then begin
found := true ;
popstack(x) ;popstack(y) ;
divide ( y, x, z) ;
pushstack(z) ;
end ;
'A' : if sequal(s, 'ABS') then begin
found := true ;
popstack(x) ;
z := x ;
z.sign := false ;
pushstack(z) ;
end
else if sequal(s, 'AFF') then begin
found := true ;
fpstatus.mode.clos := affine ;
end ;
'C' : subc ;
'D' : subd ;
'E' : if length(s)=1 then begin
found := true ;
pushstack(e) ;
end else if sequal(s, 'EXIT') then begin (* EXIT *) found := true ; exit := true end ;
'L' : if sequal(s, 'LOGB') then begin
found := true ;
popstack(x) ;
clogb( x, z ) ;
pushstack( z ) ;
end ;
'N' : if sequal(s, 'NEG') then begin (* NEGATE top of stack *)
found := true ;
popstack(x) ;
z := x ;
z.sign := not z.sign ;
pushstack(z) ;
end
else if sequal(s, 'NORM') then begin
found := true ;
fpstatus.mode.norm := normalizing ;
end else if sequal(s, 'NEXT') then begin (* Compute NEXTAFTER function. *)
found := true ;
popstack(x) ;
popstack(y) ;
cnextafter( y, x, z ) ;
pushstack ( z ) ;
end ;
'P' : if sequal(s, 'POP') then begin
found := true ;
if stack <> nil then stack := stack^.next ;
end
else if sequal(s, 'PI') then begin
found := true ;
pushstack(pi) ;
end else if sequal(s, 'PROJ') then begin
found := true ;
fpstatus.mode.clos := proj ;
end ;
'R' : subRr ;
'S' : subS ;
'T' : subT ;
'U' : if sequal(s, 'UNROUNDED') then begin
found := true ;
storagemode := unrounded ;
fpstatus.mode.precision := xprec ;
end ;
'W' : if sequal(s, 'WARN') then begin
found := true ;
fpstatus.mode.norm := warning ;
end ;
otherwise
end ;
if found then writeln( ' Did ',s) ;
if (length(s)=2) and not found then begin (* Is is a trap enable toggle? *)
for fpe := invop to inexact do
if (s[1]=xcpnname[fpe,1]) and (s[2]=xcpnname[fpe,2]) then begin
found := true ; (* Command was name of exception so toggle that trap enable. *)
if fpe in fpstatus.trap then
fpstatus.trap := fpstatus.trap - [fpe] (* If on, turn off. *)
else
fpstatus.trap := fpstatus.trap + [fpe] ; (* If off, turn on. *)
end ;
end ;
if not found then begin (* check for decimal input *)
decbin(s, x, error ) ;
fpstatus.curexcep := fpstatus.curexcep - [invop] ;
badnan.sign := x.sign ; (* Set up BadNaN to compare correctly with x. *)
if (not error) and (not equalinternal(x,badnan)) then begin
found := true ;
pushstack(x) ;
end
end ;
if not found then begin (* check for hex input *)
hexbin(s, x, error ) ;
fpstatus.curexcep := fpstatus.curexcep - [invop] ;
if not error then begin
found := true ;
pushstack(x) ;
end
end ;
if found then begin
if stack <> nil then store(stack^.x) ;
fpstatus.excep := fpstatus.excep + fpstatus.curexcep ; (* Add in current
exceptions. *)
fulldisplay := stack <> nil ;
if fulldisplay then
fulldisplay := (fpstatus.curexcep <> []) or
(not equalinternal( stack^.x, oldtop )) ;
if fulldisplay then begin
displaystatus ;
trapmessage ;
fpstatus.curexcep := [] ;
display(stack^.x) ;
end
else trapmessage
end
else writeln(' Command not recognized: ',s) ;
end ;
begin
clear ;
makenan(nanascnan,badnan) ; (* Create a Bad-NaN Nan for use later. *)
repeat
exit := false ;
fpstatus.excep := [] ;
(* Reset exception flag register for new command strng. *)
writeln(' Command: ') ;
i := 1 ;
while not eoln do
begin
read(c) ;
buffer[i] := c ;
i := i + 1 ;
end ;
buffer[0] := chr(i-1) ;
readln ;
concatchar( buffer, ';' ) ;
while (not exit) and (length(buffer) > 1) do begin (* Get next command. *)
semipos := pos(';', buffer) ; (* Find boundary of next command. *)
copy( buffer, 1, semipos - 1,s ) ; (* Extract next command. *)
delete ( buffer, 1, semipos ) ; (* Remove next command from buffer. *)
if stack <> nil then oldtop := stack^.x ; (* Save old top of stack. *)
fpstatus.curexcep := [] ; (* Reset exception flags for new operation. *)
j := 0 ;
for i := 1 to length(s) do if s[i] <> ' ' then begin (* suppress blanks
and lower case *)
j := j + 1 ;
s[j] := upcase(s[i]) ;
end ;
copy(s,1,j,s) ;
for i := ord(s[0])+1 to maxfpstring do s[i] := ' ' ;
docommand ( found ) ;
if found and testflag then dotest ( s, found, x, y ) ;
end ;
until exit ;
end ;
procedure execute ;
begin
writeln(' Begin IEEE Calculator version 2 September 1985 ') ;
initialize ;
commandloop ;
end ;
#include 'dotest.i'
begin (* Outer block. *)
execute ;
end .
End-Of-File
echo Extracting calcf32.p
cat >calcf32.p <<'End-Of-File'
(* File calcf32.p, Version 9 October 1984. *)
(* This version of the calculator test unit tests 32 bit single precision
IEEE arithmetic accessed by the "shortreal" type. *)
#include 'sane.h'
#include 'oldfplib.h'
#include 'calctest.h'
#include 'calcsingle.h'
type bite = -128..+127 ;
function getbite ( b : bite ) : byt ;
begin
if b >= 0 then getbite := b else getbite := b + 256 ;
end ;
function setbite ( b : byt ) : bite ;
begin
if b < 128 then setbite := b else setbite := b - 256 ;
end ;
procedure swapexcep (* var e : excepset *) ;
var t : excepset ;
begin
e := [] ;
end ;
procedure swaptrap (* var e : excepset *) ;
var t : excepset ;
begin
e := [] ;
end ;
procedure swapmode (* var e : fpmodetype *) ;
var t : fpmodetype ;
begin
t.round := rnear ;
t.clos := affine ;
t.norm := normalizing ;
t.precision := xprec ;
e := t ;
end ;
procedure toreal ( s : csingle ; var r : shortreal ) ;
(* kluge to call a csingle a shortreal *)
type
klugetype = record
case boolean of
false : ( sk : packed array[0..3] of -128..+127 ) ;
true : ( rk : shortreal ) ;
end ;
var
kluge : klugetype ;
i : 0..3 ;
begin
for i := 0 to 3 do kluge.sk[i] := setbite(s[i]) ;
r := kluge.rk ;
end ;
procedure fromreal ( r : shortreal ; var s : csingle ) ;
(* kluge to call a shortreal a csingle *)
type
klugetype = record
case boolean of
false : ( sk : packed array[0..3] of -128..+127 ) ;
true : ( rk : shortreal ) ;
end ;
var
kluge : klugetype ;
i : 0..3 ;
begin
kluge.rk := r ;
for i := 0 to 3 do s[i] := getbite(kluge.sk[i]) ;
end ;
procedure pretest (* var storemode : arithtype *) ;
begin
storemode := flt32 ;
end ;
procedure tstore (* var z : internal *) ;
begin end ;
procedure tabs(* x : internal ; var z : internal *) ;
var
xs : csingle ; xr : shortreal ;
begin
tosingle(x,xs) ; toreal (xs,xr) ;
xr := abs(xr) ;
fromreal(xr,xs) ; unpacksingle(xs,z) ;
end ;
procedure tsqrt(* x : internal ; var z : internal *) ;
var
xs : csingle ; xr : shortreal ;
begin
tosingle(x,xs) ; toreal (xs,xr) ;
fromreal(sqrt(xr),xs) ; unpacksingle(xs,z) ;
end ;
procedure tneg(* x : internal ; var z : internal *) ;
var
xs : csingle ; xr : shortreal ;
begin
tosingle(x,xs) ; toreal (xs,xr) ;
xr := -xr ;
fromreal(xr,xs) ; unpacksingle(xs,z) ;
end ;
procedure tadd (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
zr := xr + yr ;
fromreal(zr,zs) ;
unpacksingle(zs,z) ;
end ;
procedure tsub (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
zr := xr - yr ;
fromreal(zr,zs) ;
unpacksingle(zs,z) ;
end ;
procedure tmul (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
zr := xr * yr ;
fromreal(zr,zs) ;
unpacksingle(zs,z) ;
end ;
procedure tdiv (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
zr := xr / yr ;
fromreal(zr,zs) ;
unpacksingle(zs,z) ;
end ;
procedure trem (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
fromreal(xr - yr * round(xr/yr),zs) ;
unpacksingle(zs,z) ;
end ;
procedure tcompare (* x, y : internal ; var cc : conditioncode *) ;
var
xs,ys,zs : csingle ;
xr,yr,zr : shortreal ;
begin
tosingle(x,xs) ; toreal(xs,xr) ; tosingle(y,ys) ; toreal(ys,yr) ;
write ( ' Tests affirm these predicates: ') ;
if xr=yr then write(' EQ ') ;
IF XR<>YR THEN write(' NE ') ;
IF XR<YR THEN write(' LT ') ;
IF XR<=YR THEN write(' LE ') ;
IF XR>YR THEN write(' GT ') ;
IF XR>=YR THEN write(' GE ') ;
writeln ;
IF xr=yr then cc := equal else
if xr>yr then cc := greater else
if xr<yr then cc := lesser else
cc := notord ;
end ;
procedure tconvert(* x : internal ; var z : internal ; a : arithtype *) ;
var yx : cextended ; yd : cdouble ; ys : csingle ;
yi64 : cint64 ; yi16 : integer ;
xs : csingle ; xr : shortreal ; xl : longint ;
begin
If a=i32 then begin
tosingle(x,xs) ; toreal(xs,xr) ;
xl := round(xr) ;
yi16 := xl ;
writeln(' Intermediate i16 ',yi16) ;
xr := xl ;
fromreal(xr,xs) ; unpacksingle(xs,z) ;
end
else begin
z := x ;
end
end ;
procedure tintconvert(* x : internal ; var z : internal ; a : arithtype *) ;
var yx : cextended ; yd : cdouble ; ys : csingle ;
yi64 : cint64 ; yi16 : integer ;
xs : csingle ; xr : shortreal ; xl : longint ;
begin
If a=i32 then begin
tosingle(x,xs) ; toreal(xs,xr) ;
xl := trunc(xr) ;
yi16 := xl ;
writeln(' Intermediate i16 ',yi16) ;
xr := xl ;
fromreal(xr,xs) ; unpacksingle(xs,z) ;
end
else begin
z := x ;
end
end ;
procedure tdisplay(* x : internal *) ;
var
xs : csingle ; xr : shortreal ;
s : fpstring ; i,j : integer ; error : boolean ;
begin
tosingle(x,xs) ; toreal(xs,xr) ;
{write (' Free ') ;
for i := 1 to 4 do begin
f32_ascii(xr,5*i- 1,0,0,fp_free,s,error ) ;
for j := length(s)+1 to 5*i-1 do write(' ') ;
write(' ',s) ;
end ;
writeln ;
write (' Lisa ') ;
for i := 1 to 4 do begin
f32_ascii(xr,5*i-1,0,0,fp_lisa,s,error ) ;
for j := length(s)+1 to 5*i-1 do write(' ') ;
write(' ',s) ;
end ;
writeln ;
}
writeln(' Efmt ',xr:5, xr:10, xr : 15, xr : 20 ) ;
writeln(' Ffmt ', xr : 5 : 0, xr : 10 : 5, xr : 15 : 7, xr : 20 : 10 ) ;
end ;
procedure tdecbin
(* s : fpstring ; var xout : internal ; var error : boolean *) ;
(* converts decimal fpstring s to internal format *)
(* error is set true if bad format *)
var
r : shortreal ;
xs : csingle ;
next : integer ;
f : text ;
i : integer ;
begin
rewrite(f) ;
for i := 1 to ord(s[0]) do write(f,s[i]) ;
writeln(f) ;
reset(f) ;
readln(f,r) ;
fromreal(r,xs) ; unpacksingle(xs,x) ;
end ;
End-Of-File
echo Extracting calcf64.p
cat >calcf64.p <<'End-Of-File'
(* File calcf64.p, Version 8 October 1984. *)
(* This version of the calculator test unit tests 64 bit double precision
IEEE arithmetic accessed by the "real" type. *)
#include 'sane.h'
#include 'oldfplib.h'
#include 'calctest.h'
#include 'calcdouble.h'
type bite = -128..+127 ;
function getbite ( b : bite ) : byt ;
begin
if b >= 0 then getbite := b else getbite := b + 256 ;
end ;
function setbite ( b : byt ) : bite ;
begin
if b < 128 then setbite := b else setbite := b - 256 ;
end ;
procedure swapexcep (* var e : excepset *) ;
var t : excepset ;
begin
e := [] ;
end ;
procedure swaptrap (* var e : excepset *) ;
var t : excepset ;
begin
e := [] ;
end ;
procedure swapmode (* var e : fpmodetype *) ;
var t : fpmodetype ;
begin
t.round := rnear ;
t.clos := affine ;
t.norm := normalizing ;
t.precision := xprec ;
e := t ;
end ;
procedure toreal ( s : cdouble ; var r : real ) ;
(* kluge to call a cdouble a real *)
type
klugetype = record
case boolean of
false : ( sk : packed array[0..7] of -128..+127 ) ;
true : ( rk : real ) ;
end ;
var
kluge : klugetype ;
i : 0..7 ;
begin
for i := 0 to 7 do kluge.sk[i] := setbite(s[i]) ;
r := kluge.rk ;
end ;
procedure fromreal ( r : real ; var s : cdouble ) ;
(* kluge to call a real a cdouble *)
type
klugetype = record
case boolean of
false : ( sk : packed array[0..7] of -128..+127 ) ;
true : ( rk : real ) ;
end ;
var
kluge : klugetype ;
i : 0..7 ;
begin
kluge.rk := r ;
for i := 0 to 7 do s[i] := getbite(kluge.sk[i]) ;
end ;
procedure pretest (* var storemode : arithtype *) ;
begin
storemode := f64 ;
end ;
procedure tstore (* var z : internal *) ;
begin end ;
procedure tabs(* x : internal ; var z : internal *) ;
var
xs : cdouble ; xr : real ;
begin
todouble(x,xs) ; toreal (xs,xr) ;
xr := abs(xr) ;
fromreal(xr,xs) ; unpackdouble(xs,z) ;
end ;
procedure tsqrt(* x : internal ; var z : internal *) ;
var
xs : cdouble ; xr : real ;
begin
todouble(x,xs) ; toreal (xs,xr) ;
fromreal(sqrt(xr),xs) ; unpackdouble(xs,z) ;
end ;
procedure tneg(* x : internal ; var z : internal *) ;
var
xs : cdouble ; xr : real ;
begin
todouble(x,xs) ; toreal (xs,xr) ;
xr := -xr ;
fromreal(xr,xs) ; unpackdouble(xs,z) ;
end ;
procedure tadd (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
zr := xr + yr ;
fromreal(zr,zs) ;
unpackdouble(zs,z) ;
end ;
procedure tsub (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
zr := xr - yr ;
fromreal(zr,zs) ;
unpackdouble(zs,z) ;
end ;
procedure tmul (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
zr := xr * yr ;
fromreal(zr,zs) ;
unpackdouble(zs,z) ;
end ;
procedure tdiv (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
zr := xr / yr ;
fromreal(zr,zs) ;
unpackdouble(zs,z) ;
end ;
procedure trem (* x, y : internal ; var z : internal *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
fromreal(xr - yr * round(xr/yr),zs) ;
unpackdouble(zs,z) ;
end ;
procedure tcompare (* x, y : internal ; var cc : conditioncode *) ;
var
xs,ys,zs : cdouble ;
xr,yr,zr : real ;
begin
todouble(x,xs) ; toreal(xs,xr) ; todouble(y,ys) ; toreal(ys,yr) ;
write ( ' Tests affirm these predicates: ') ;
if xr=yr then write(' EQ ') ;
IF XR<>YR THEN write(' NE ') ;
IF XR<YR THEN write(' LT ') ;
IF XR<=YR THEN write(' LE ') ;
IF XR>YR THEN write(' GT ') ;
IF XR>=YR THEN write(' GE ') ;
writeln ;
IF xr=yr then cc := equal else
if xr>yr then cc := greater else
if xr<yr then cc := lesser else
cc := notord ;
end ;
procedure tconvert(* x : internal ; var z : internal ; a : arithtype *) ;
var yx : cextended ; yd : cdouble ; ys : csingle ;
yi64 : cint64 ; yi16 : integer ;
xs : cdouble ; xr : real ; xl : longint ;
begin
If a=i32 then begin
todouble(x,xs) ; toreal(xs,xr) ;
xl := round(xr) ;
yi16 := xl ;
writeln(' Intermediate i16 ',yi16) ;
xr := xl ;
fromreal(xr,xs) ; unpackdouble(xs,z) ;
end
else begin
z := x ;
end
end ;
procedure tintconvert(* x : internal ; var z : internal ; a : arithtype *) ;
var yx : cextended ; yd : cdouble ; ys : csingle ;
yi64 : cint64 ; yi16 : integer ;
xs : cdouble ; xr : real ; xl : longint ;
begin
If a=i32 then begin
todouble(x,xs) ; toreal(xs,xr) ;
xl := trunc(xr) ;
yi16 := xl ;
writeln(' Intermediate i16 ',yi16) ;
xr := xl ;
fromreal(xr,xs) ; unpackdouble(xs,z) ;
end
else begin
z := x ;
end
end ;
procedure tdisplay(* x : internal *) ;
var
xs : cdouble ; xr : real ;
s : fpstring ; i,j : integer ; error : boolean ;
begin
todouble(x,xs) ; toreal(xs,xr) ;
{write (' Free ') ;
for i := 1 to 4 do begin
f32_ascii(xr,5*i- 1,0,0,fp_free,s,error ) ;
for j := length(s)+1 to 5*i-1 do write(' ') ;
write(' ',s) ;
end ;
writeln ;
write (' Lisa ') ;
for i := 1 to 4 do begin
f32_ascii(xr,5*i-1,0,0,fp_lisa,s,error ) ;
for j := length(s)+1 to 5*i-1 do write(' ') ;
write(' ',s) ;
end ;
writeln ;
}
writeln(' Efmt ',xr:5, xr:10, xr : 15, xr : 20 ) ;
writeln(' Ffmt ', xr : 5 : 0, xr : 10 : 5, xr : 15 : 7, xr : 20 : 10 ) ;
end ;
procedure tdecbin
(* s : fpstring ; var xout : internal ; var error : boolean *) ;
(* converts decimal fpstring s to internal format *)
(* error is set true if bad format *)
var
r : real ;
xs : cdouble ;
next : integer ;
f : text ;
i : integer ;
begin
rewrite(f) ;
for i := 1 to ord(s[0]) do write(f,s[i]) ;
writeln(f) ;
reset(f) ;
readln(f,r) ;
fromreal(r,xs) ; unpackdouble(xs,x) ;
end ;
End-Of-File
echo Extracting calctest.p
cat >calctest.p <<'End-Of-File'
(* File calctest.p, Version 5 October 1984. *)
#include 'sane.h'
#include 'oldfplib.h'
#include 'calctest.h'
procedure pretest (* var storemode : arithtype *) ;
begin
end ;
procedure tstore (* var z : internal *) ;
begin
end ;
procedure tadd (* x, y : internal ; var z : internal *) ;
begin
end ;
procedure tsub (* x, y : internal ; var z : internal *) ;
begin
end ;
procedure tmul (* x, y : internal ; var z : internal *) ;
begin
end ;
procedure tdiv (* x, y : internal ; var z : internal *) ;
begin
end ;
procedure trem (* x, y : internal ; var z : internal *) ;
begin
end ;
procedure tcompare (* x, y : internal ; var cc : conditioncode *) ;
begin
end ;
procedure tconvert (* x : internal ; var z : internal ; a : arithtype *) ;
begin
end ;
procedure tintconvert
(* x : internal ; var z : internal ; a : arithtype *) ;
begin
end ;
procedure tabs (* x : internal ; var z : internal *) ;
begin
end ;
procedure tsqrt (* x : internal ; var z : internal *) ;
begin
end ;
procedure tneg (* x : internal ; var z : internal *) ;
begin
end ;
procedure tdisplay (* x : internal *) ;
begin
end ;
procedure tdecbin
(* s : fpstring ; var x : internal ; var error : boolean *) ;
begin
end ;
procedure swapexcep (* var e : excepset *) ;
begin
end ;
procedure swaptrap (* var e : excepset *) ;
begin
end ;
procedure swapmode (* var e : fpmodetype *) ;
begin
end ;
End-Of-File
echo ""
echo "End of Kit"
exit
More information about the Mod.sources
mailing list