Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site seismo.CSS.GOV
Posting-Version: version B 2.10.2 9/3/84; site panda.UUCP
Path: seismo!harvard!talcott!panda!sources-request
From: sources-request@panda.UUCP
Newsgroups: mod.sources
Subject: IEEE Calculator (part 2 of 6)
Message-ID: <859@panda.UUCP>
Date: 3 Sep 85 21:57:57 GMT
Sender: jpn@panda.UUCP
Lines: 1169
Approved: jpn@panda.UUCP

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