head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.19.39;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.00.27;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.38.36;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.17.18;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.10.42.39;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.44.29;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.23.11;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.24.26;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.08.07;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.07.19;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.22.39;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.06.59;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.12.47;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.53.21;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.40.09;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.47.31;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.05.22;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.55.43;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.40.49;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.23.39;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.45.55;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.30.49;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.21.56;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.35.10;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.13.56;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.26.51;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.02.02;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.35.52;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.42.53;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.04.04;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.41.41;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.26.06;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.54.27;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.23.12;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.58.27;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.19.45;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.36.14;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.12.40;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.55.26;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.40.53;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.53.31;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.10.14;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.06.00;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.22.01;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.34.52;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.06.44;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.07.02;  author jws;  state Exp;
branches ;
next     13.2;

13.2
date     87.03.18.11.06.47;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.21.21;  author jws;  state Exp;
branches ;
next     12.2;

12.2
date     87.02.18.14.55.39;  author bayes;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.10.25;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.36.20;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.43.50;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.14.18.42;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.40.49;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.29.51;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.37.42;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.16.23.38;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.33.01;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.42.52;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.27.15;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.14.14.40;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@*
*  FILE:        allreals
*
*  This file contains the math routines for the Pascal Workstation.
*  Major modifications for the 98635A card (hardware floating point) were
*  done by Paul Beiser   March 25, 1984.
*
	sprint
	nosyms
	refa    sysglobals
	refa    asm_adelement,fltpthdw
	lmode   asm_adelement,fltpthdw
	rorg    0

****************************************************************************
*
*  The following are the addresses of the coefficients used in the evaluation
*  of transcendental functions.
*
cff_loga        equ     $3c26           LOG coefficients
cff_logb        equ     $3c3e
cff_expp        equ     $3c56           EXP coefficients
cff_expq        equ     $3c6e
cff_sin         equ     $3c8e           SIN/COS coefficients
cff_atnp        equ     $3d66           ATN coefficients
cff_atnq        equ     $3d86
*
*  The following are address of tables used in the BCD <-> real conversions
*  and in the evaluation of x^y.
*
tb_pwt          equ     $3658           BCD <-> real tables
tb_pwt8         equ     $3698
tb_pwt4         equ     $36b8
tb_pwtt         equ     $36d8
tb_auxpt        equ     $3ae0
tb_bcd          equ     $3b28
tb_bin          equ     $3bc2
*
*  Pascal Workstation Escapecodes
*
esc_flpt_divzer equ     -5              divide by zero
esc_flpt_over   equ     -6              overflow
esc_flpt_under  equ     -7              underflow
esc_flpt_sincos equ     -15             bad argument - sine/cosine
esc_flpt_natlog equ     -16             bad argument - natural log
esc_flpt_sqrt   equ     -17             bad argument - square root
esc_flpt_relbcd equ     -18             bad argument - real/BCD conversion
esc_flpt_bcdrel equ     -19             bad argument - BCD/real conversion
esc_flpt_misc   equ     -29             misc floating point error


****************************************************************************
*
* The following are some constants that relate to the floating point card.
*
status          equ     $21             offset of the FPU protocol status byte
q               equ     3               bit postion for the q bit in <status>
bogus4          equ     $18             offset to do 4 bogus word reads
bogus4s         equ     $16             offset for 6 word reads: 4 bogus and 2
*                                         to get the status word at <status>
minuszero       equ     $80000000       top 32 bits of the real value -0

flpt_cardaddr   equ     $5c0000         address of floating pt card
flpt_id         equ     $1              offset of the ID byte/write reset
flpt_initmask   equ     $00000008       UEN flag set; RM to nearest
flpt_extracttrap equ    $00000007       mask for extracting the exception type
flpt_card_id    equ     $0a             float card ID byte SFB
*
*  Values returned by the 16081 FPU if an error occurred.
*
flpt_under      equ     1               floating point underflow
flpt_over       equ     2               floating point overflow
flpt_divzero    equ     3               floating point divide-by-zero
flpt_illegal    equ     4               illegal floating point instruction
flpt_invalid    equ     5               invalid floating point operation
flpt_inexact    equ     6               inexact floating point result
flpt_notdoc     equ     7               not furnished by National
*
*  Offsets from "flpt_cardaddr" for the operations to the floating point card.
*
addl_f0_f0      equ     $4000
addl_f0_f2      equ     $4002
addl_f0_f4      equ     $4004
addl_f0_f6      equ     $4006
addl_f2_f0      equ     $4008
addl_f2_f2      equ     $400a
addl_f2_f4      equ     $400c
addl_f2_f6      equ     $400e
addl_f4_f0      equ     $4010
addl_f4_f2      equ     $4012
addl_f4_f4      equ     $4014
addl_f4_f6      equ     $4016
addl_f6_f0      equ     $4018
addl_f6_f2      equ     $401a
addl_f6_f4      equ     $401c
addl_f6_f6      equ     $401e
subl_f0_f0      equ     $4020
subl_f0_f2      equ     $4022
subl_f0_f4      equ     $4024
subl_f0_f6      equ     $4026
subl_f2_f0      equ     $4028
subl_f2_f2      equ     $402a
subl_f2_f4      equ     $402c
subl_f2_f6      equ     $402e
subl_f4_f0      equ     $4030
subl_f4_f2      equ     $4032
subl_f4_f4      equ     $4034
subl_f4_f6      equ     $4036
subl_f6_f0      equ     $4038
subl_f6_f2      equ     $403a
subl_f6_f4      equ     $403c
subl_f6_f6      equ     $403e
mull_f0_f0      equ     $4040
mull_f0_f2      equ     $4042
mull_f0_f4      equ     $4044
mull_f0_f6      equ     $4046
mull_f2_f0      equ     $4048
mull_f2_f2      equ     $404a
mull_f2_f4      equ     $404c
mull_f2_f6      equ     $404e
mull_f4_f0      equ     $4050
mull_f4_f2      equ     $4052
mull_f4_f4      equ     $4054
mull_f4_f6      equ     $4056
mull_f6_f0      equ     $4058
mull_f6_f2      equ     $405a
mull_f6_f4      equ     $405c
mull_f6_f6      equ     $405e
divl_f0_f0      equ     $4060
divl_f0_f2      equ     $4062
divl_f0_f4      equ     $4064
divl_f0_f6      equ     $4066
divl_f2_f0      equ     $4068
divl_f2_f2      equ     $406a
divl_f2_f4      equ     $406c
divl_f2_f6      equ     $406e
divl_f4_f0      equ     $4070
divl_f4_f2      equ     $4072
divl_f4_f4      equ     $4074
divl_f4_f6      equ     $4076
divl_f6_f0      equ     $4078
divl_f6_f2      equ     $407a
divl_f6_f4      equ     $407c
divl_f6_f6      equ     $407e
negl_f0_f0      equ     $4080
negl_f0_f2      equ     $4082
negl_f0_f4      equ     $4084
negl_f0_f6      equ     $4086
negl_f2_f0      equ     $4088
negl_f2_f2      equ     $408a
negl_f2_f4      equ     $408c
negl_f2_f6      equ     $408e
negl_f4_f0      equ     $4090
negl_f4_f2      equ     $4092
negl_f4_f4      equ     $4094
negl_f4_f6      equ     $4096
negl_f6_f0      equ     $4098
negl_f6_f2      equ     $409a
negl_f6_f4      equ     $409c
negl_f6_f6      equ     $409e
absl_f0_f0      equ     $40a0
absl_f0_f2      equ     $40a2
absl_f0_f4      equ     $40a4
absl_f0_f6      equ     $40a6
absl_f2_f0      equ     $40a8
absl_f2_f2      equ     $40aa
absl_f2_f4      equ     $40ac
absl_f2_f6      equ     $40ae
absl_f4_f0      equ     $40b0
absl_f4_f2      equ     $40b2
absl_f4_f4      equ     $40b4
absl_f4_f6      equ     $40b6
absl_f6_f0      equ     $40b8
absl_f6_f2      equ     $40ba
absl_f6_f4      equ     $40bc
absl_f6_f6      equ     $40be
addf_f0_f0      equ     $40c0
addf_f0_f1      equ     $40c2
addf_f0_f2      equ     $40c4
addf_f0_f3      equ     $40c6
addf_f0_f4      equ     $40c8
addf_f0_f5      equ     $40ca
addf_f0_f6      equ     $40cc
addf_f0_f7      equ     $40ce
addf_f1_f0      equ     $40d0
addf_f1_f1      equ     $40d2
addf_f1_f2      equ     $40d4
addf_f1_f3      equ     $40d6
addf_f1_f4      equ     $40d8
addf_f1_f5      equ     $40da
addf_f1_f6      equ     $40dc
addf_f1_f7      equ     $40de
addf_f2_f0      equ     $40e0
addf_f2_f1      equ     $40e2
addf_f2_f2      equ     $40e4
addf_f2_f3      equ     $40e6
addf_f2_f4      equ     $40e8
addf_f2_f5      equ     $40ea
addf_f2_f6      equ     $40ec
addf_f2_f7      equ     $40ee
addf_f3_f0      equ     $40f0
addf_f3_f1      equ     $40f2
addf_f3_f2      equ     $40f4
addf_f3_f3      equ     $40f6
addf_f3_f4      equ     $40f8
addf_f3_f5      equ     $40fa
addf_f3_f6      equ     $40fc
addf_f3_f7      equ     $40fe
addf_f4_f0      equ     $4100
addf_f4_f1      equ     $4102
addf_f4_f2      equ     $4104
addf_f4_f3      equ     $4106
addf_f4_f4      equ     $4108
addf_f4_f5      equ     $410a
addf_f4_f6      equ     $410c
addf_f4_f7      equ     $410e
addf_f5_f0      equ     $4110
addf_f5_f1      equ     $4112
addf_f5_f2      equ     $4114
addf_f5_f3      equ     $4116
addf_f5_f4      equ     $4118
addf_f5_f5      equ     $411a
addf_f5_f6      equ     $411c
addf_f5_f7      equ     $411e
addf_f6_f0      equ     $4120
addf_f6_f1      equ     $4122
addf_f6_f2      equ     $4124
addf_f6_f3      equ     $4126
addf_f6_f4      equ     $4128
addf_f6_f5      equ     $412a
addf_f6_f6      equ     $412c
addf_f6_f7      equ     $412e
addf_f7_f0      equ     $4130
addf_f7_f1      equ     $4132
addf_f7_f2      equ     $4134
addf_f7_f3      equ     $4136
addf_f7_f4      equ     $4138
addf_f7_f5      equ     $413a
addf_f7_f6      equ     $413c
addf_f7_f7      equ     $413e
subf_f0_f0      equ     $4140
subf_f0_f1      equ     $4142
subf_f0_f2      equ     $4144
subf_f0_f3      equ     $4146
subf_f0_f4      equ     $4148
subf_f0_f5      equ     $414a
subf_f0_f6      equ     $414c
subf_f0_f7      equ     $414e
subf_f1_f0      equ     $4150
subf_f1_f1      equ     $4152
subf_f1_f2      equ     $4154
subf_f1_f3      equ     $4156
subf_f1_f4      equ     $4158
subf_f1_f5      equ     $415a
subf_f1_f6      equ     $415c
subf_f1_f7      equ     $415e
subf_f2_f0      equ     $4160
subf_f2_f1      equ     $4162
subf_f2_f2      equ     $4164
subf_f2_f3      equ     $4166
subf_f2_f4      equ     $4168
subf_f2_f5      equ     $416a
subf_f2_f6      equ     $416c
subf_f2_f7      equ     $416e
subf_f3_f0      equ     $4170
subf_f3_f1      equ     $4172
subf_f3_f2      equ     $4174
subf_f3_f3      equ     $4176
subf_f3_f4      equ     $4178
subf_f3_f5      equ     $417a
subf_f3_f6      equ     $417c
subf_f3_f7      equ     $417e
subf_f4_f0      equ     $4180
subf_f4_f1      equ     $4182
subf_f4_f2      equ     $4184
subf_f4_f3      equ     $4186
subf_f4_f4      equ     $4188
subf_f4_f5      equ     $418a
subf_f4_f6      equ     $418c
subf_f4_f7      equ     $418e
subf_f5_f0      equ     $4190
subf_f5_f1      equ     $4192
subf_f5_f2      equ     $4194
subf_f5_f3      equ     $4196
subf_f5_f4      equ     $4198
subf_f5_f5      equ     $419a
subf_f5_f6      equ     $419c
subf_f5_f7      equ     $419e
subf_f6_f0      equ     $41a0
subf_f6_f1      equ     $41a2
subf_f6_f2      equ     $41a4
subf_f6_f3      equ     $41a6
subf_f6_f4      equ     $41a8
subf_f6_f5      equ     $41aa
subf_f6_f6      equ     $41ac
subf_f6_f7      equ     $41ae
subf_f7_f0      equ     $41b0
subf_f7_f1      equ     $41b2
subf_f7_f2      equ     $41b4
subf_f7_f3      equ     $41b6
subf_f7_f4      equ     $41b8
subf_f7_f5      equ     $41ba
subf_f7_f6      equ     $41bc
subf_f7_f7      equ     $41be
mulf_f0_f0      equ     $41c0
mulf_f0_f1      equ     $41c2
mulf_f0_f2      equ     $41c4
mulf_f0_f3      equ     $41c6
mulf_f0_f4      equ     $41c8
mulf_f0_f5      equ     $41ca
mulf_f0_f6      equ     $41cc
mulf_f0_f7      equ     $41ce
mulf_f1_f0      equ     $41d0
mulf_f1_f1      equ     $41d2
mulf_f1_f2      equ     $41d4
mulf_f1_f3      equ     $41d6
mulf_f1_f4      equ     $41d8
mulf_f1_f5      equ     $41da
mulf_f1_f6      equ     $41dc
mulf_f1_f7      equ     $41de
mulf_f2_f0      equ     $41e0
mulf_f2_f1      equ     $41e2
mulf_f2_f2      equ     $41e4
mulf_f2_f3      equ     $41e6
mulf_f2_f4      equ     $41e8
mulf_f2_f5      equ     $41ea
mulf_f2_f6      equ     $41ec
mulf_f2_f7      equ     $41ee
mulf_f3_f0      equ     $41f0
mulf_f3_f1      equ     $41f2
mulf_f3_f2      equ     $41f4
mulf_f3_f3      equ     $41f6
mulf_f3_f4      equ     $41f8
mulf_f3_f5      equ     $41fa
mulf_f3_f6      equ     $41fc
mulf_f3_f7      equ     $41fe
mulf_f4_f0      equ     $4200
mulf_f4_f1      equ     $4202
mulf_f4_f2      equ     $4204
mulf_f4_f3      equ     $4206
mulf_f4_f4      equ     $4208
mulf_f4_f5      equ     $420a
mulf_f4_f6      equ     $420c
mulf_f4_f7      equ     $420e
mulf_f5_f0      equ     $4210
mulf_f5_f1      equ     $4212
mulf_f5_f2      equ     $4214
mulf_f5_f3      equ     $4216
mulf_f5_f4      equ     $4218
mulf_f5_f5      equ     $421a
mulf_f5_f6      equ     $421c
mulf_f5_f7      equ     $421e
mulf_f6_f0      equ     $4220
mulf_f6_f1      equ     $4222
mulf_f6_f2      equ     $4224
mulf_f6_f3      equ     $4226
mulf_f6_f4      equ     $4228
mulf_f6_f5      equ     $422a
mulf_f6_f6      equ     $422c
mulf_f6_f7      equ     $422e
mulf_f7_f0      equ     $4230
mulf_f7_f1      equ     $4232
mulf_f7_f2      equ     $4234
mulf_f7_f3      equ     $4236
mulf_f7_f4      equ     $4238
mulf_f7_f5      equ     $423a
mulf_f7_f6      equ     $423c
mulf_f7_f7      equ     $423e
divf_f0_f0      equ     $4240
divf_f0_f1      equ     $4242
divf_f0_f2      equ     $4244
divf_f0_f3      equ     $4246
divf_f0_f4      equ     $4248
divf_f0_f5      equ     $424a
divf_f0_f6      equ     $424c
divf_f0_f7      equ     $424e
divf_f1_f0      equ     $4250
divf_f1_f1      equ     $4252
divf_f1_f2      equ     $4254
divf_f1_f3      equ     $4256
divf_f1_f4      equ     $4258
divf_f1_f5      equ     $425a
divf_f1_f6      equ     $425c
divf_f1_f7      equ     $425e
divf_f2_f0      equ     $4260
divf_f2_f1      equ     $4262
divf_f2_f2      equ     $4264
divf_f2_f3      equ     $4266
divf_f2_f4      equ     $4268
divf_f2_f5      equ     $426a
divf_f2_f6      equ     $426c
divf_f2_f7      equ     $426e
divf_f3_f0      equ     $4270
divf_f3_f1      equ     $4272
divf_f3_f2      equ     $4274
divf_f3_f3      equ     $4276
divf_f3_f4      equ     $4278
divf_f3_f5      equ     $427a
divf_f3_f6      equ     $427c
divf_f3_f7      equ     $427e
divf_f4_f0      equ     $4280
divf_f4_f1      equ     $4282
divf_f4_f2      equ     $4284
divf_f4_f3      equ     $4286
divf_f4_f4      equ     $4288
divf_f4_f5      equ     $428a
divf_f4_f6      equ     $428c
divf_f4_f7      equ     $428e
divf_f5_f0      equ     $4290
divf_f5_f1      equ     $4292
divf_f5_f2      equ     $4294
divf_f5_f3      equ     $4296
divf_f5_f4      equ     $4298
divf_f5_f5      equ     $429a
divf_f5_f6      equ     $429c
divf_f5_f7      equ     $429e
divf_f6_f0      equ     $42a0
divf_f6_f1      equ     $42a2
divf_f6_f2      equ     $42a4
divf_f6_f3      equ     $42a6
divf_f6_f4      equ     $42a8
divf_f6_f5      equ     $42aa
divf_f6_f6      equ     $42ac
divf_f6_f7      equ     $42ae
divf_f7_f0      equ     $42b0
divf_f7_f1      equ     $42b2
divf_f7_f2      equ     $42b4
divf_f7_f3      equ     $42b6
divf_f7_f4      equ     $42b8
divf_f7_f5      equ     $42ba
divf_f7_f6      equ     $42bc
divf_f7_f7      equ     $42be
negf_f0_f0      equ     $42c0
negf_f0_f1      equ     $42c2
negf_f0_f2      equ     $42c4
negf_f0_f3      equ     $42c6
negf_f0_f4      equ     $42c8
negf_f0_f5      equ     $42ca
negf_f0_f6      equ     $42cc
negf_f0_f7      equ     $42ce
negf_f1_f0      equ     $42d0
negf_f1_f1      equ     $42d2
negf_f1_f2      equ     $42d4
negf_f1_f3      equ     $42d6
negf_f1_f4      equ     $42d8
negf_f1_f5      equ     $42da
negf_f1_f6      equ     $42dc
negf_f1_f7      equ     $42de
negf_f2_f0      equ     $42e0
negf_f2_f1      equ     $42e2
negf_f2_f2      equ     $42e4
negf_f2_f3      equ     $42e6
negf_f2_f4      equ     $42e8
negf_f2_f5      equ     $42ea
negf_f2_f6      equ     $42ec
negf_f2_f7      equ     $42ee
negf_f3_f0      equ     $42f0
negf_f3_f1      equ     $42f2
negf_f3_f2      equ     $42f4
negf_f3_f3      equ     $42f6
negf_f3_f4      equ     $42f8
negf_f3_f5      equ     $42fa
negf_f3_f6      equ     $42fc
negf_f3_f7      equ     $42fe
negf_f4_f0      equ     $4300
negf_f4_f1      equ     $4302
negf_f4_f2      equ     $4304
negf_f4_f3      equ     $4306
negf_f4_f4      equ     $4308
negf_f4_f5      equ     $430a
negf_f4_f6      equ     $430c
negf_f4_f7      equ     $430e
negf_f5_f0      equ     $4310
negf_f5_f1      equ     $4312
negf_f5_f2      equ     $4314
negf_f5_f3      equ     $4316
negf_f5_f4      equ     $4318
negf_f5_f5      equ     $431a
negf_f5_f6      equ     $431c
negf_f5_f7      equ     $431e
negf_f6_f0      equ     $4320
negf_f6_f1      equ     $4322
negf_f6_f2      equ     $4324
negf_f6_f3      equ     $4326
negf_f6_f4      equ     $4328
negf_f6_f5      equ     $432a
negf_f6_f6      equ     $432c
negf_f6_f7      equ     $432e
negf_f7_f0      equ     $4330
negf_f7_f1      equ     $4332
negf_f7_f2      equ     $4334
negf_f7_f3      equ     $4336
negf_f7_f4      equ     $4338
negf_f7_f5      equ     $433a
negf_f7_f6      equ     $433c
negf_f7_f7      equ     $433e
absf_f0_f0      equ     $4340
absf_f0_f1      equ     $4342
absf_f0_f2      equ     $4344
absf_f0_f3      equ     $4346
absf_f0_f4      equ     $4348
absf_f0_f5      equ     $434a
absf_f0_f6      equ     $434c
absf_f0_f7      equ     $434e
absf_f1_f0      equ     $4350
absf_f1_f1      equ     $4352
absf_f1_f2      equ     $4354
absf_f1_f3      equ     $4356
absf_f1_f4      equ     $4358
absf_f1_f5      equ     $435a
absf_f1_f6      equ     $435c
absf_f1_f7      equ     $435e
absf_f2_f0      equ     $4360
absf_f2_f1      equ     $4362
absf_f2_f2      equ     $4364
absf_f2_f3      equ     $4366
absf_f2_f4      equ     $4368
absf_f2_f5      equ     $436a
absf_f2_f6      equ     $436c
absf_f2_f7      equ     $436e
absf_f3_f0      equ     $4370
absf_f3_f1      equ     $4372
absf_f3_f2      equ     $4374
absf_f3_f3      equ     $4376
absf_f3_f4      equ     $4378
absf_f3_f5      equ     $437a
absf_f3_f6      equ     $437c
absf_f3_f7      equ     $437e
absf_f4_f0      equ     $4380
absf_f4_f1      equ     $4382
absf_f4_f2      equ     $4384
absf_f4_f3      equ     $4386
absf_f4_f4      equ     $4388
absf_f4_f5      equ     $438a
absf_f4_f6      equ     $438c
absf_f4_f7      equ     $438e
absf_f5_f0      equ     $4390
absf_f5_f1      equ     $4392
absf_f5_f2      equ     $4394
absf_f5_f3      equ     $4396
absf_f5_f4      equ     $4398
absf_f5_f5      equ     $439a
absf_f5_f6      equ     $439c
absf_f5_f7      equ     $439e
absf_f6_f0      equ     $43a0
absf_f6_f1      equ     $43a2
absf_f6_f2      equ     $43a4
absf_f6_f3      equ     $43a6
absf_f6_f4      equ     $43a8
absf_f6_f5      equ     $43aa
absf_f6_f6      equ     $43ac
absf_f6_f7      equ     $43ae
absf_f7_f0      equ     $43b0
absf_f7_f1      equ     $43b2
absf_f7_f2      equ     $43b4
absf_f7_f3      equ     $43b6
absf_f7_f4      equ     $43b8
absf_f7_f5      equ     $43ba
absf_f7_f6      equ     $43bc
absf_f7_f7      equ     $43be
movfl_f0_f0     equ     $43c0
movfl_f0_f2     equ     $43c2
movfl_f0_f4     equ     $43c4
movfl_f0_f6     equ     $43c6
movfl_f1_f0     equ     $43c8
movfl_f1_f2     equ     $43ca
movfl_f1_f4     equ     $43cc
movfl_f1_f6     equ     $43ce
movfl_f2_f0     equ     $43d0
movfl_f2_f2     equ     $43d2
movfl_f2_f4     equ     $43d4
movfl_f2_f6     equ     $43d6
movfl_f3_f0     equ     $43d8
movfl_f3_f2     equ     $43da
movfl_f3_f4     equ     $43dc
movfl_f3_f6     equ     $43de
movfl_f4_f0     equ     $43e0
movfl_f4_f2     equ     $43e2
movfl_f4_f4     equ     $43e4
movfl_f4_f6     equ     $43e6
movfl_f5_f0     equ     $43e8
movfl_f5_f2     equ     $43ea
movfl_f5_f4     equ     $43ec
movfl_f5_f6     equ     $43ee
movfl_f6_f0     equ     $43f0
movfl_f6_f2     equ     $43f2
movfl_f6_f4     equ     $43f4
movfl_f6_f6     equ     $43f6
movfl_f7_f0     equ     $43f8
movfl_f7_f2     equ     $43fa
movfl_f7_f4     equ     $43fc
movfl_f7_f6     equ     $43fe
movlf_f0_f0     equ     $4400
movlf_f0_f1     equ     $4402
movlf_f0_f2     equ     $4404
movlf_f0_f3     equ     $4406
movlf_f0_f4     equ     $4408
movlf_f0_f5     equ     $440a
movlf_f0_f6     equ     $440c
movlf_f0_f7     equ     $440e
movlf_f2_f0     equ     $4410
movlf_f2_f1     equ     $4412
movlf_f2_f2     equ     $4414
movlf_f2_f3     equ     $4416
movlf_f2_f4     equ     $4418
movlf_f2_f5     equ     $441a
movlf_f2_f6     equ     $441c
movlf_f2_f7     equ     $441e
movlf_f4_f0     equ     $4420
movlf_f4_f1     equ     $4422
movlf_f4_f2     equ     $4424
movlf_f4_f3     equ     $4426
movlf_f4_f4     equ     $4428
movlf_f4_f5     equ     $442a
movlf_f4_f6     equ     $442c
movlf_f4_f7     equ     $442e
movlf_f6_f0     equ     $4430
movlf_f6_f1     equ     $4432
movlf_f6_f2     equ     $4434
movlf_f6_f3     equ     $4436
movlf_f6_f4     equ     $4438
movlf_f6_f5     equ     $443a
movlf_f6_f6     equ     $443c
movlf_f6_f7     equ     $443e
movl_f0_f0      equ     $4440
movl_f0_f2      equ     $4442
movl_f0_f4      equ     $4444
movl_f0_f6      equ     $4446
movl_f2_f0      equ     $4448
movl_f2_f2      equ     $444a
movl_f2_f4      equ     $444c
movl_f2_f6      equ     $444e
movl_f4_f0      equ     $4450
movl_f4_f2      equ     $4452
movl_f4_f4      equ     $4454
movl_f4_f6      equ     $4456
movl_f6_f0      equ     $4458
movl_f6_f2      equ     $445a
movl_f6_f4      equ     $445c
movl_f6_f6      equ     $445e
movf_f0_f0      equ     $4460
movf_f0_f1      equ     $4462
movf_f0_f2      equ     $4464
movf_f0_f3      equ     $4466
movf_f0_f4      equ     $4468
movf_f0_f5      equ     $446a
movf_f0_f6      equ     $446c
movf_f0_f7      equ     $446e
movf_f1_f0      equ     $4470
movf_f1_f1      equ     $4472
movf_f1_f2      equ     $4474
movf_f1_f3      equ     $4476
movf_f1_f4      equ     $4478
movf_f1_f5      equ     $447a
movf_f1_f6      equ     $447c
movf_f1_f7      equ     $447e
movf_f2_f0      equ     $4480
movf_f2_f1      equ     $4482
movf_f2_f2      equ     $4484
movf_f2_f3      equ     $4486
movf_f2_f4      equ     $4488
movf_f2_f5      equ     $448a
movf_f2_f6      equ     $448c
movf_f2_f7      equ     $448e
movf_f3_f0      equ     $4490
movf_f3_f1      equ     $4492
movf_f3_f2      equ     $4494
movf_f3_f3      equ     $4496
movf_f3_f4      equ     $4498
movf_f3_f5      equ     $449a
movf_f3_f6      equ     $449c
movf_f3_f7      equ     $449e
movf_f4_f0      equ     $44a0
movf_f4_f1      equ     $44a2
movf_f4_f2      equ     $44a4
movf_f4_f3      equ     $44a6
movf_f4_f4      equ     $44a8
movf_f4_f5      equ     $44aa
movf_f4_f6      equ     $44ac
movf_f4_f7      equ     $44ae
movf_f5_f0      equ     $44b0
movf_f5_f1      equ     $44b2
movf_f5_f2      equ     $44b4
movf_f5_f3      equ     $44b6
movf_f5_f4      equ     $44b8
movf_f5_f5      equ     $44ba
movf_f5_f6      equ     $44bc
movf_f5_f7      equ     $44be
movf_f6_f0      equ     $44c0
movf_f6_f1      equ     $44c2
movf_f6_f2      equ     $44c4
movf_f6_f3      equ     $44c6
movf_f6_f4      equ     $44c8
movf_f6_f5      equ     $44ca
movf_f6_f6      equ     $44cc
movf_f6_f7      equ     $44ce
movf_f7_f0      equ     $44d0
movf_f7_f1      equ     $44d2
movf_f7_f2      equ     $44d4
movf_f7_f3      equ     $44d6
movf_f7_f4      equ     $44d8
movf_f7_f5      equ     $44da
movf_f7_f6      equ     $44dc
movf_f7_f7      equ     $44de

movf_m_f7       equ     $44e0
movf_m_f6       equ     $44e4
movf_m_f5       equ     $44e8
movf_m_f4       equ     $44ec
movf_m_f3       equ     $44f0
movf_m_f2       equ     $44f4
movf_m_f1       equ     $44f8
movf_m_f0       equ     $44fc
movif_m_f7      equ     $4500
movif_m_f6      equ     $4504
movif_m_f5      equ     $4508
movif_m_f4      equ     $450c
movif_m_f3      equ     $4510
movif_m_f2      equ     $4514
movif_m_f1      equ     $4518
movif_m_f0      equ     $451c
movil_m_f6      equ     $4520
movil_m_f4      equ     $4524
movil_m_f2      equ     $4528
movil_m_f0      equ     $452c
movfl_m_f6      equ     $4530
movfl_m_f4      equ     $4534
movfl_m_f2      equ     $4538
movfl_m_f0      equ     $453c
lfsr_m_m        equ     $4540

movf_f7_m       equ     $4550
movf_f6_m       equ     $4554
movf_f5_m       equ     $4558
movf_f4_m       equ     $455c
movf_f3_m       equ     $4560
movf_f2_m       equ     $4564
movf_f1_m       equ     $4568
movf_f0_m       equ     $456c
movlf_f6_m      equ     $4570
movlf_f4_m      equ     $4574
movlf_f2_m      equ     $4578
movlf_f0_m      equ     $457c
sfsr_m_m        equ     $4580
	     page
	def     asm_rmul,asm_rdiv,asm_rsub,asm_radd
	def     asm_round,asm_trunc,asm_float
	def     asm_bcd_real,asm_real_bcd,asm_bcdround
	def     asm_pack,asm_unpack
	def     asm_hex,asm_octal,asm_binary
	def     asm_eq,asm_ne,asm_lt,asm_le,asm_gt,asm_ge
	def     asm_sin,asm_cos,asm_arctan,asm_sqrt,asm_exp,asm_ln
	def     asm_addsetrange
	def     asm_flpt_error,asm_flpt_reset

asm_flpt_error  bra     flpt_error
asm_flpt_reset  bra     flpt_reset

*******************************************************************************
*
*       Procedures : asm_radd / asm_rsub / asm_rmul / asm_rdiv
*
*       Description: These are the compiler interface routines for
*                    doing real +, -, *, and /.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand2
*
*       Registers  : a0         - return address
*                    a1         - address of the card
*                    d0-d3      - the operands
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : radd, rsbt, rmul, rdvd, flpt_cardaddr, flpt_error
*
*******************************************************************************

asm_radd  movea.l (sp)+,a0              get the return address
	movem.l (sp)+,d0-d3             get the operands
	tst.b   fltpthdw                is fp hardware there
	beq.s   s@@1                     branch if not
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   addl_f0_f2(a1)          f2 + f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@1     bsr     radd                   do the operation in software
	move.l  d1,-(sp)                return the result
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rsub  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@3
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   subl_f0_f2(a1)          f2 - f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@3     bsr     rsbt
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rmul  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@5
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   mull_f0_f2(a1)          f2 * f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@5     bsr     rmul
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rdiv  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@7
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   divl_f0_f2(a1)          f2 / f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@7     bsr     rdvd
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_sin / asm_cos / asm_arctan / asm_sqrt
*                    asm_exp / asm_ln
*
*       Description: These are the compiler interface routines for
*                    the transendentals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand
*
*       Result     : The result is returned on the stack by the
*                    called routine.
*
*       Error(s)   : Generated in the called routines.
*
*       References : See text.
*
*******************************************************************************

asm_sin tst.b   fltpthdw                is hardware there?
	beq     soft_sin                software transcendental
	bra     flpt_sin

asm_cos tst.b   fltpthdw
	beq     soft_cos
	bra     flpt_cos

asm_arctan tst.b   fltpthdw
	beq     soft_arctan
	bra     flpt_arctan

asm_sqrt tst.b  fltpthdw
	beq     soft_sqrt
	bra     flpt_sqrt

asm_exp tst.b   fltpthdw
	beq     soft_exp
	bra     flpt_exp

asm_ln  tst.b   fltpthdw
	beq     soft_ln
	bra     flpt_ln
	page
*******************************************************************************
*
*       Procedures : asm_float / asm_round / asm_trunc
*
*       Description: These are the compiler interface routines for
*                    converting integers to reals and reals to integers.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand (if present)
*
*       Registers  : a0         - return address
*                    d0-d1      - the operand(s)
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : lntrel, rellnt, rellntt
*
*       Miscel     : The floating point card is not used for any of these
*                    conversions mainly because our hardware does not support
*                    conversions from reals to integers and, in the other
*                    direction, floating point registers would have to be
*                    saved and restored, making the hardware versions not
*                    much faster than the software versions.
*
*******************************************************************************

asm_float movea.l (sp)+,a0              return address
	move.l  (sp)+,d0                operand to convert
	bsr     lntrel
	move.l  d1,-(sp)                place result on stack
	move.l  d0,-(sp)
	jmp     (a0)

asm_round movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellnt
	move.l  d0,(sp)
	jmp     (a0)

asm_trunc movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellntt
	move.l  d0,(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_bcd_real / asm_real_bcd
*
*       Description: These are the compiler interface routines for
*                    converting between reals and decimals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : asm_bcd_real
*                       4(sp)   - address of the result real
*                       8(sp)   - address of the bcd number to convert
*                    asm_real_bcd
*                       4(sp)   - address of the result bcd number
*                       8(sp)   - address of the real to convert
*
*       Registers  : See the text of the code.
*
*       Result     : See "Parameters".
*
*       Error(s)   : Generated in the called routines.
*
*       References : relbcd, bcdrel
*
*       Miscel     : Both bcdrel and relbcd still do software multiplies.
*
*******************************************************************************

asm_bcd_real movea.l 8(sp),a0           address of the bcd to convert
	bsr     bcdrel                  return real in (d0,d1)
	movea.l (sp)+,a0                return address
	movea.l (sp)+,a1                address of the result real
	move.l  d0,(a1)+
	move.l  d1,(a1)
	addq.l  #4,sp
	jmp     (a0)

asm_real_bcd moveq  #16,d7      16 digits requested
	movea.l (sp)+,a1        return address
	movea.l (sp)+,a0        address of result bcd number
	movea.l (sp),a2         address of number to convert
	move.l  (a2)+,d0
	move.l  (a2),d1
	move.l  a1,(sp)
	bsr     relbcd
	rts
	page
*******************************************************************************
*
*       Procedure  : rmul
*
*       Description: Do a software 64 bit real multiply.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Registers  : d4,d5,d6   - partial products
*                    d7         - sticky bit information
*                    a0         - result exponent
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

retzero moveq   #0,d0           return zero
	move.l  d0,d1
	rts
*
*  Shortness is defined as < 17 bits of mantissa.
*
short2  tst.l   d3              test opnd2lo for zero
	bne.s   ts2
	   move.l  d0,d6           test both operandhi for
	   or.l    d2,d6           shortness
	   swap    d6
	   and.w   #$1f,d6
	   beq     shxsh           short times a short
	      move.l  d2,d6           test opnd2hi for shortness
	      swap    d6
	      and.w   #$1f,d6
	      bne.s   ts2
		 exg     d0,d2
		 exg     d1,d3            short opnd in d0-d1
		 bra     longxsh          long times a short
*
*  If here then opnd2 is definitely not short.
*
ts2     move.l  d0,d6
	swap    d6              test opnd1hi for shortness
	and.w   #$1f,d6
	bne.s   phase1
	   bra     longxsh
short1  move.l  d2,d6           test opnd2hi
	swap    d6              for shortness
	and.w   #$1f,d6
	bne.s   ph1a
	   exg     d0,d2
	   exg     d1,d3
	   bra     longxsh

*******************************************************************************
*
*  64 bit real multiply begins here.
*
rmul      cmp.l   #minuszero,d0 check first operand for -0
	  beq.s   retzero       return +0 as the answer
	  cmp.l   #minuszero,d2 check second operand for -0
	  beq.s   retzero       return +0 as the answer
	  move.l  #$80007ff0,d5 mask for exponent evaluation
	  move.l  d0,d7         high order opnd1 -> d7
	  beq.s   retzero       branch if zero operand
	  swap    d0            duplicate high order word into
	  move.w  d0,d7         low order word of d7
	  move.l  d2,d6         do the same for opnd2 into d6
	  beq.s   retzero       branch if zero operand
	  move.l  a0,-(sp)      a0 must not be altered by this routine
	  swap    d2
	  move.w  d2,d6
	  and.l   d5,d6         use mask to put sign in high order
	  and.l   d5,d7         and exponent in low order word
	  add.l   d6,d7         form result sign and exponent at once
	  moveq   #$f,d6        mask for removing exponent
	  and.w   d6,d0         extract mantissas
	  and.w   d6,d2
	  moveq   #$10,d6       mask for inserting hidden one
	  or.w    d6,d2         put in hidden one
	  or.w    d6,d0
	  movea.l d7,a0         store result exponent in a0
	  moveq   #0,d7         use d7 for sticky bit
	  tst.l   d1            can we do a faster multiply?
	  beq     short2
*
*                                     B3    B2   B1   B0
*                          X          A3    A2   A1   A0
*                               ---------------------------
*                                               [A0 X B0] (1)
*                                          [A0 X B1]      (2.1)
*                                          [A1 X B0]      (2.2)
*                                     [A1 X B1]           (3.1)
*                                     [A2 X B0]           (3.2)
*                                     [A0 X B2]           (3.3)
*                                [A3 X B0]                (4.1)
*                                [A2 X B1]                (4.2)
*                                [A0 X B3]                (4.3)
*                                [A1 X B2]                (4.4)
*                           [A3 X B1]                     (5.1)
*                           [A1 X B3]                     (5.2)
*                           [A2 x B2]                     (5.3)
*                      [A2 X B3]                          (6.1)
*                      [A3 X B2]                          (6.2)
*                 [A3 X B3]                               (7)
*-------------------------------------------------------------
*                 PP7  PP6  PP5  PP4  PP3  PP2  PP1  PP0
*
* Keep PP4 thru PP7; use PP0 thru PP3 for stickiness.

*
*                       Phase 1
*                        (1)
*
phase1   move.l  d3,d5          check for shortness
	 beq.s   short1
ph1a     mulu    d1,d5          A0*B0
	 or.w    d5,d7          keep track of lost bits for stickiness
	 clr.w   d5             discard bits 0-15
	 swap    d5
*
*                       Phase 2
*
*                       (2.1)
*
	 move.l  d3,d6
	 swap    d6
	 mulu    d1,d6          A0*B1
	 add.l   d6,d5
*
*                       (2.2)
*
	 clr.w   d4
	 move.l  d1,d6
	 swap    d6
	 mulu    d3,d6          A1*B0
	 add.l   d6,d5
	 addx.w  d4,d4
	 or.w    d5,d7
	 move.w  d4,d5
	 swap    d5
*
*                       Phase 3
*                       (3.1)
*
*
	 move.l  d3,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B1
	 swap    d1
	 add.l   d6,d5
*
*                       (3.2)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B0
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (3.3)
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d1,d6          A0*B2
	 add.l   d6,d5
	 or.w    d5,d7
	 move.w  d4,d5
	 negx.w  d5
	 neg.w   d5
	 swap    d5
*
*                       Phase 4
*                       (4.1)
*
	 move.w  d0,d6
	 mulu    d3,d6          A3*B0
	 add.l   d6,d5
*
*                       (4.2)
*
	 swap    d3
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B1
	 swap    d3
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (4.3)
*
	 move.w  d2,d6
	 mulu    d1,d6          A0*B3
	 add.l   d6,d5
	 negx.w  d4
	 neg     d4
*
*                       (4.4)
*
	 move.l  d2,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B2
	 swap    d1
	 add.l   d6,d5
	 negx.w  d4
	 neg.w   d4
	 swap    d4
	 swap    d5
	 move.w  d5,d4
*
*                       Phase 5
*                       (5.1)
*
*
	 clr.w   d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A3*B1
	 add.l   d6,d4
*
*                       (5.2)
*
*
	 move.l  d1,d6
	 swap    d6
	 mulu    d2,d6          A1*B3
	 add.l   d6,d4
*
*                       (5.3)
*
*
	 move.l  d2,d6
	 swap    d6
	 swap    d0
	 mulu    d0,d6          A2*B2
	 swap    d0
	 add.l   d6,d4
	 addx.w  d5,d5
	 move.w  d5,d6
	 move.w  d4,d5
	 move.w  d6,d4
	 swap    d5
	 swap    d4
*
*                       Phase 6
*
*                       (6.1)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d2,d6          A2*B3
	 add.l   d6,d4
*
*                       (6.2)
*
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A3*B2
	 add.l   d6,d4
*
*                       Phase 7
*
*                       (7)
*
	 move.w  d0,d6
	 mulu    d2,d6          A3*B3
	 swap    d6
	 add.l   d6,d4
*
*  Post normalization after multiplication
*
p_norm   btst    #25,d4
	 bne.s   m_norm_1
*
*  Shift whole mantissa 4 places right. This avoids 1 shift left.
*
	 suba.w  #$10,a0        adjust exponent
	 move.l  d4,d0
	 lsr.l   #4,d0
	 and.l   #$f,d4
	 ror.l   #4,d4
	 move.l  d5,d1
	 lsr.l   #4,d1
	 or.l    d4,d1
	 add.l   d5,d5          put round and stcky bits in place
	 bra.s   mround
*
*  Now shift whole mantissa right 5 places.
*
m_norm_1 move.l  d4,d0
	 lsr.l   #5,d0
	 and.l   #$1f,d4
	 ror.l   #5,d4
	 move.l  d5,d1
	 lsr.l   #5,d1
	 or.l    d4,d1
*
*  Result in (d0,d1). Now round.
*
mround   btst    #4,d5          test round bit
	 beq.s   roundun        if clear then no rounding to do
	 and.b   #$f,d5         get bits lost during last alignment
	 or.b    d5,d7          factor into sticky bit
mul_rnd2 tst.w   d7             test mr. sticky
	 bne.s   round_up       if sticky and round then round up
	    btst    #0,d1          test lsb of result
	    beq.s   roundun        else round to even
round_up addq.l  #1,d1
	 bcc.s   rm_4
	    addq.l  #1,d0
rm_4     btst    #21,d0
	 beq.s   roundun        test for mantissa overflow
	    lsr.l   #1,d0          d1 must already be zero
	    adda.w  #$10,a0
*
*  Extract result sign for later 'or' with the exponent.
*
roundun  move.l  a0,d6          get sign
	 swap    d6             place in bottom word
*
*  Complete exponent calculation with tests for overflow and underflow.
*
	 move.l  a0,d7          exponent with the sign
	 bpl.s   no_clear       branch if top portion already cleared
	    swap    d7             else clear the sign bit
	    clr.w   d7
	    swap    d7
no_clear movea.l  (sp)+,a0      restore original value of a0
	 sub.l   #$4000-$10,d7  remove extra bias minus hidden one
	 bmi     err_underflow  exponent underflow?
	 cmp.w   #$7fd0,d7      hidden bit add on later
	 bhi     err_overflow   or overflow?
*
*  Merge exponent and mantissa.
*
	 or.w    d6,d7          place sign with the exponent
	 swap    d7             place exponent into top portion
	 add.l   d7,d0          aha, hidden bit finally adds back!
	 rts

********************************************************************************
*
*  Shorter precision multiply when possible.
*
shxsh    swap    d0             align 16 bits of mantissa into d0
	 swap    d2             same for d2
	 lsr.l   #5,d0
	 lsr.l   #5,d2
	 mulu    d2,d0          A0*B0 only one multiply required here
	 swap    d0             rotate and mask result into correct bits
	 move.l  d0,d1
	 clr.w   d1
	 lsl.l   #5,d1
	 rol.l   #5,d0
	 and.l   #$001fffff,d0
	 btst    #20,d0         test for post-normalize
	 bne.s   roundun        note: no rounding possible, too few bits
	    add.l   d1,d1          shift mantissa left one position
	    addx.l  d0,d0
	    suba.w  #$10,a0        compensate exponent
	    bra     roundun
*
*  Long times shorter.
*
longxsh  swap    d0             align 16 bits of mantissa into d0
	 lsr.l   #5,d0
	 move.w  d3,d5
	 mulu    d0,d5          A0 * B0
	 or.w    d5,d7          keep PP0 in d7 for rounding
	 clr.w   d5
	 swap    d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A0 * B1
	 add.l   d6,d5
	 move.w  d5,d4
	 clr.w   d5
	 swap    d5
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A0 * B2
	 add.l   d6,d5
	 swap    d4
	 move.w  d5,d4
	 swap    d4
	 clr.w   d5
	 swap    d5
	 move.w  d2,d6
	 mulu    d0,d6          A0 * B3
	 add.l   d6,d5
	 move.l  d5,d0
	 move.l  d4,d1
	 btst    #20,d0         test for post-normalize
	 bne.s   lxs2
	    add.w   d7,d7          shift entire fraction left
	    addx.l  d1,d1
	    addx.l  d0,d0
	    suba.w  #$10,a0        fix exponent
lxs2     add.w   d7,d7          round bit into carry, leaving stickyness in d7
	 bcc     roundun
	    bra     mul_rnd2       possible rounding to do
	 page
*******************************************************************************
*
*       Procedure  : rdvd
*
*       Description: Do a software 64 bit real divide.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand (dividend)
*                    (d2,d3)    - second operand (divisor)
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow, real underflow, and divide-by-zero.
*
*       References : err_underflow, err_overflow, err_divzero
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************
*
*
*  This routine called 4 times will produce up to 64 quotient bits
*  d0-d1 is 64 bit dividend
*  d2-d3 is 64 bit divisor      (should be normalized (bit 31 = 1))
*  d4-d5 is 64 bit quotient
*
dv00     swap    d4             shift quotient left 16 bits
	 swap    d5
	 move.w  d5,d4
*
	 tst.l   d0             1st 32 dividend bits  /  1st 16 divisor bits
	 beq.s   dv7
dv0         swap    d2
	    divu    d2,d0
	    bvc.s   normal         branch if no overflow
*
*  Had an overflow on the divide. Our quotient must be $ffff or $fffe, and the
*  fixup for the new dividend is derived as follows.
*
*  DVD := Shl16(d0,d1) - Quotient * (d2,d3)
*      := Shl16(d0,d1) - (2^16-c) * (d2,d3);  c = 1 or 2
*      := Shl16(d0,d1) - Shl16(d2,d3) + c(d2,d3)
*      := Shl16( (d0,d1) - (d2,d3) ) + c(d2,d3)
*
	    swap    d2                restore correct order of divisor
	    move.w  #$ffff,d5         new quotient
	    sub.l   d3,d1             (d0,d1) - (d2,d3)
	    subx.l  d2,d0
	    swap    d0                shift left by 16
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   dv6               fixup up dividend (add back at least once)
*
*  Normal divide - no overflow. Go through standard routine.
*
normal   swap    d2
dv7      move.w  d0,d5          16 bits shifted into quotient register
	 swap    d1             shift dividend left 16 bits
	 move.w  d1,d0          except for remainder in d0 upper
	 clr.w   d1
	 tst.w   d5             finish low order part of division:
	 beq.s   dv1
	 moveq   #0,d7          d7 is used for borrow bit out of dividend
	 move.w  d2,d6          dividend - (quotient * 2nd 16 divisor bits)
	 beq.s   dv2
	    mulu    d5,d6
	    sub.l   d6,d0
	    bcc.s   dv2
	    subq    #1,d7
*
dv2      move.w  d3,d6          dividend - (quotient * 4th 16 divisor bits)
	 beq.s   dv3
	    mulu    d5,d6
	    sub.l   d6,d1
	    bcc.s   dv3
	       subq.l  #1,d0
	       bcc.s   dv3
		  subq    #1,d7
*
dv3      swap    d3             dividend - (quotient * 3rd 16 divisor bits)
	 move.w  d3,d6
	 beq.s   dv4
	    mulu    d5,d6
	    swap    d1
	    sub.w   d6,d1
	    swap    d1
	    swap    d6
	    subx.w  d6,d0
	    bcc.s   dv4
	       sub.l   #$10000,d0
	       bcc.s   dv4
		  subq    #1,d7
dv4      swap    d3
	 tst.w   d7             restore dividend and quotient if it didn't go
	 bpl.s   dv1
*
dv5         subq.l  #1,d5          decrement quotient
	    bcc.s   dv6
	       subq.l  #1,d4          propagate the borrow in the quotient
dv6         add.l   d3,d1          add divisor back to dividend
	    addx.l  d2,d0
	    bcc.s   dv5            repeat till dividend >= 0
*                               (at most twice more if bit 31 of divisor is 1)
dv1     rts

*******************************************************************************
*
*  Main body of the real divide.
*
rdvd     tst.l   d2             check for zero
	 beq     err_divzero     branch if divisor is a zero
	 cmp.l   #minuszero,d2   check for -0
	 beq     err_divzero     branch if divisor is a zero
*
*  Check for a zero dividend.
*
dvndzer  tst.l   d0
	 bne.s   checkn
divret0     moveq   #0,d0          else return a zero result
	    move.l  d0,d1
	    rts
checkn   cmp.l   #minuszero,d0  check for -0
	 beq.s   divret0
*
*  Prepare mantissas for divide, and save exponents for later.
*
procdvd  moveq   #$000f,d6      masks for the mantissa preparation
	 moveq   #$0010,d7
	 swap    d2             get the mantissas
	 move.w  d2,-(sp)       push the divisor exponent
	 and.w   d6,d2
	 or.w    d7,d2
	 swap    d2
	 swap    d0             same for next operand
	 move.w  d0,-(sp)       push the dividend exponent
	 and.w   d6,d0
	 or.w    d7,d0
	 swap    d0             mantissas ready for divide; compute exp
*
*  Divide of the mantissas with the remainder in (d0,d1)
*  and a 55 bit result to enable proper rounding. The result
*  is generated in (d4,d5).
*
	add.l   d1,d1           preshift dividend so quotient lines up right
	addx.l  d0,d0

	moveq   #11,d7          normalize divisor so that bit 31 = 1
	lsl.l   d7,d2
	rol.l   d7,d3
	move.l  d3,d6
	and.w   #$f800,d3
	and.w   #$07ff,d6
	or.w    d6,d2

	bsr     dv0             inner loop of divide
	bsr     dv00
	bsr     dv00
	bsr     dv00
	move.l  d4,d2           place here so sticky bit can be set
	move.l  d5,d3
*
*  Compute the new exponent and sign.
*
	 moveq   #0,d7          contain the exponent and sign of result
	 move.l  d7,d5          exponent calculation registers
	 move.l  d7,d6
	 move.w  (sp)+,d5       get dividend exponent
	 move.w  (sp)+,d6       get divisor exponent
	 eor.w   d5,d6          compute sign of result
	 bpl.s   possign
	     move.w  #$8000,d7     negative sign
possign  eor.w   d5,d6          restore exponents - nice trick
	 move.w  #$7ff0,d4      masks for the exponents
	 and.w   d4,d5          mask out exponents
	 and.w   d4,d6
	 sub.l   d6,d5          dividend exponent - divisor exponent
	 add.l   #$3ff0-$10,d5  bias - hidden bit (hidden bit adds later)
*
*  Normalize mantissa if necessary and compute sticky bit.
*
possitv  btst    #22,d2         check leading bit for normalize
	 bne.s   shftd          branch if already a one
	    add.l   d3,d3          else make it a leading one
	    addx.l  d2,d2
	    sub.l   #$10,d5        adjust exponent
shftd    or.l    d0,d1          set sticky bit with remainder
	 beq.s   rnd            if zero, sticky bit set correctly
	    or.b    #1,d3          else set sticky bit
*
*  Do the round and check for overflow and underflow.
*
rnd      btst    #1,d3          check round bit
	 beq.s   rend           branch if nothing to round
	 addq.l  #$2,d3         add 1 in the round bit
	 bcc.s   rndcon         branch if nothing to propagate
	    addq.l  #1,d2          else propagate the carry
rndcon   move.b  d3,d0          get the sticky bit
	 lsr.b   #1,d0          place into carry
	 bcs.s   norml          branch if number not halfway between
	    and.b   #$f8,d3        all zero so clear lsb (round to even)
norml    btst    #23,d2         check for overflow
	 beq.s   rend           if a zero then no overflow
	    lsr.l   #1,d2          only bit set is #24 because of overflow
	    add.l   #$10,d5        adjust exponent accordingly
rend     tst.l   d5             check for underflow
	 bmi     err_underflow  underflow error handler
	 cmp.w   #$7fd0,d5      check for overflow (remember, hidden bit! )
	 bhi     err_overflow   overflow error handler
*
*  Splice result together.
*
	 lsr.l   #1,d2          throw away round and sticky bits
	 roxr.l  #1,d3
	 lsr.l   #1,d2
	 roxr.l  #1,d3
	 or.w    d5,d7          place exponent with sign
	 swap    d7
	 add.l   d7,d2          ah!, hidden bit finally adds back!!
	 move.l  d2,d0          place in the correct registers
	 move.l  d3,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : radd / rsbt
*
*       Description: Do a software 64 bit real addition/subtraction.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

first_z  move.l  d7,d0          if subtracting from zero then the
	 move.l  d3,d1          result is operand2 with the sign
	 rts                    complemented previously
*
*  This is the subtract front end. The second operand is subtracted
*  by complementing its sign.
*
rsbt     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s   rsbt1
	    rts                    (d0,d1) is the result
rsbt1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   subnonz        zero value?
	    rts                    else (d0,d1) is the result
subnonz  bchg    #31,d7         complement sign bit for subtract
	 bne.s   second_p       test if plus or minus

second_m cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sec11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sec11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        -(d2,d3) is the result
	 bmi.s   same_sig       if signs are different then set

difsigns move.w  #-1,d6         subtract flag
	 bra.s   add1

prenorm  moveq   #0,d4          no prenormalization to do
	 bra.s   do_it          so clear overflow (g,r,s)
*
*  This is the add front end.
*
radd     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s    radd1
	    rts                    (d0,d1) is the result
radd1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   add_11         test for zero
	    rts                    else (d0,d1) is the result
add_11   bmi.s   second_m       test sign
second_p cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sss11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sss11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        also test it for zero
	 bmi.s   difsigns       and check its sign
same_sig clr.w   d6             clear subtract flag

*******************************************************************************
*
*  Common to both the add and subtract.
*
add1     moveq   #$000f,d4      masks for mantissa extraction
	 moveq   #$0010,d5
	 swap    d0             clear out exponent of operand1
	 and.w   d4,d0          and put in hidden one bit
	 or.w    d5,d0
	 swap    d0
	 swap    d2             do the same for operand2
	 and.w   d4,d2
	 or.w    d5,d2
	 swap    d2
	 swap    d6             note: sign flag goes into high part
	 swap    d7
	 move.w  #$7ff0,d4      take difference of exponents
	 move.w  d4,d5
	 and.w   d6,d4
	 and.w   d7,d5
	 sub.w   d5,d4
	 beq.s   prenorm        skip prenormalization
	 asr.w   #4,d4          faster to shift difference
	 bpl.s   add2           larger operand in d0-d1?
	 neg.w   d4             otherwise swap
	 move.w  d7,d6          use larger exponent
	 exg     d0,d2
	 exg     d1,d3
add2     moveq   #-1,d7         all ones mask in d7
	 cmp.w   #32,d4         use move.l for >= 32
	 bge     long_sh
	    lsr.l   d4,d7          rotate mask and merge to shift
	    ror.l   d4,d2          a 64 bit value by N positions
	    ror.l   d4,d3          without looping
	    move.l  d3,d4          dump spillover into d3
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4

do_it    move.w  d6,d5          get result exponent
	 tst.l   d6
	 bmi.s   sub_it         remember subtract flag?
*
*  Add 2 numbers with the same signs.
*
add_it   and.w   #$7ff0,d5      mask out exponent
	 move.l  #$00200000,d7  mask for mantissa overflow test
	 add.l   d3,d1          this is it, sports fans
	 addx.l  d2,d0
	 cmp.l   d7,d0          test for mantissa overflow
	 blt.s   add3
	    add.w   #16,d5         exponent in bits 15/5
	    lsr.l   #1,d0          everything right and increment
	    roxr.l  #1,d1          the exponent
	    roxr.l  #1,d4
	    bcc.s   add3           don't forget to catch the
	       or.w    #1,d4          sticky bit
add3     cmp.l   #$80000000,d4  test for rounding
	 bcs.s   add5           if lower then no rounding to do
	 bhi.s   add4           if higher then round up
	    btst    #0,d1          otherwise test mr. sticky
	    beq.s   add5
add4     addq.l  #1,d1          here we are at the roundup
	 bcc.s   add5
	    addq.l  #1,d0
	    cmp.l   d7,d0          a word to the wise: test for
	    blt.s   add5           mantissa overflow when you
	       lsr.l   #1,d0          round up during an add
	       add.w   #16,d5         exponent in bits 15/5
add5     cmp.w   #$7fe0,d5      check for exponent overflow
	 bhi     err_overflow
	 tst.w    d6            get sign of the result
	 bpl.s   add6           positive result
	    add.w   #$8000,d5      copy sign bit
add6     swap    d5
	 clr.w   d5             for the or
	 bclr    #20,d0         hide hidden one
	 or.l    d5,d0          exponent into mantissa
	 rts
*
*  Add two numbers with differing signs.
*
sub_it   lsr.w   #4,d5          align in correct location
	 and.w   #$07ff,d5      get rid of the sign bit
	 neg.l   d4             zero minus overlow
	 subx.l  d3,d1          subtract low order
	 subx.l  d2,d0          subtract high order
	 tst.l   d0             test for top 21 bits all zero
	 beq     zerores        at least 21 left shifts necessary
	 bpl.s   sign_un        did we do it the right way?
	    add.w   #$8000,d6      flip sign of result
	    neg.l   d1             Note: this path only taken if path
	    negx.l  d0                   thru prenormalized was taken
	    tst.l   d0             check for top 21 bits being zero
	    beq     zerores        at least 21 left shifts necessary
sign_un  move.l  #$00100000,d7  post normalization mask
	 cmp.l   d7,d0          test for post normalization
	 bge.s   sub1
	 add.l   d4,d4          shift everything left one
	 addx.l  d1,d1          shift along guard bit first
	 addx.l  d0,d0          time only
	 subq.w  #1,d5          decrement exponent
	 cmp.l   d7,d0          normalized yet?
	 bge.s   sub1
	 move.l  d0,d4          test for shift by 16
	 and.l   #$001fffe0,d4  test high 16 bits
	 bne.s   norm8lop       if not 16 , check by 8
	    sub.w   #16,d5         adjust exponent
	    swap    d0
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   normlopp       less than 5 shifts left (maybe 0)
norm8lop move.l  d0,d4          test for shift by 8
	 and.l   #$001fe000,d4  check 8 high bits
	 bne.s   normloop       at least one shift still necesarry!
	    sub.w   #8,d5          adjust exponent
	    lsl.l   #8,d0
	    rol.l   #8,d1
	    move.b  d1,d0          d0 correct
	    clr.b   d1             d1 correct
normlopp cmp.l   d7,d0          must test here - could be done
	 bge.s   sub2           no rounding necessary
normloop add.l   d1,d1          this is for post normalizing < 8 times
	 addx.l  d0,d0          for any additional shifting
	 subq.w  #1,d5          note: this code can be improved
	 cmp.l   d7,d0
	 blt.s   normloop
	 bra.s   sub2           no rounding necessary
sub1     cmp.l   #$80000000,d4  rounding for subtract
	 bcs.s   sub2           same sequence as add
	 bhi.s   sub3
	    btst    #0,d1
	    beq.s   sub2
sub3     addq.l  #1,d1          round up
	 bcc.s   sub2
	    addq.l  #1,d0
	    btst    #21,d0         mantissa overflow?
	    beq.s   sub2
	       asr.l   #1,d0
	       addq    #1,d5          increment exponent (can't overflow)
sub2     tst.w   d5             test for exponent underflow
	 ble     err_underflow
	    lsl.w   #5,d5          exponent in top so can place in sign
	    add.w   d6,d6          get sign
	    roxr.w  #1,d5          into exponent
	    swap    d5
	    clr.w   d5             for the or
	    bclr    #20,d0         hide hidden one
	    or.l    d5,d0          exponent into mantissa
	    rts

shifted_ bclr    #20,d0         more than 55 shifts to prenormalize
	 swap    d6             so reconstruct larger operand and
	 clr.w   d6             return in d0-d1
	 or.l    d6,d0
	 rts

long_sh  beq.s   ls1            branch if exactly 32 shifts
	 cmp.w   #55,d4         if shift count is too large then
	 bgt.s   shifted_       don't bother
	    sub.w   #32,d4
	    lsr.l   d4,d7
	    ror.l   d4,d2
	    ror.l   d4,d3
	    move.l  d3,d4
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4
	    beq.s   ls1
	       or.w    #1,d3
ls1      move.l  d3,d4
	 move.l  d2,d3
	 moveq   #0,d2
	 bra     do_it

zerores  tst.l   d1
	 bne.s   longnorm       if result was zero after subtract, done
	 tst.l   d4             check guard bit
	 bmi.s   longnorm
	    rts

longnorm add.l   d4,d4          result nearly zero, shift 21 or more
	 addx.l  d1,d1
	 bcs.s   norm21         exact shift by 21
	 swap    d1             test for shift of 16
	 tst.w   d1
	 bne.s   test8          test for shift of 8
	    sub.w   #16,d5         adjust exponent (d1 correct)
	    move.l  d1,d7          check which byte first one in
	    swap    d7
	    and.w   #$ff00,d7
	    bne.s   lnloop         less than 8 shifts left
	       lsl.l   #8,d1          else adjust
	       subq.w  #8,d5
	       bra.s   lnloop
test8    move.w  d1,d7          check lower bytes
	 swap    d1             d1 in correct order
	 and.w   #$ff00,d7
	 bne.s   lnloop         less than 8 shifts left
	    lsl.l   #8,d1          else adjust
	    subq.w  #8,d5
lnloop   subq.w  #1,d5          less than 8 shifts left
	 add.l   d1,d1
	 bcc.s   lnloop
norm21   sub.w   #21,d5         adjust exponent
	 swap    d1             rotate left 20 or more places
	 rol.l   #4,d1          copy over the boundary
	 move.l  d1,d0
	 and.l   #$000fffff,d0  save high 20 bits
	 and.l   #$fff00000,d1  save low 12 bits
	 bra     sub2           hidden 1 is already gone
	 page
*******************************************************************************
*
*       Procedure  : rellnt
*
*       Description: Convert a real into a 32 bit integer (round).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellnt   move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover
	 beq.s   check32        -2,147,483,648.5 = (c1e00000,00100000)
	 tst.w   d6
	 bge.s   in32con        continue with conversion
	    moveq   #0,d0          else return a zero
	    rts
*
*  Finish the conversion.
*
in32con  and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1          place top bits (except hidden one) in d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 32
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 bcc.s   chksign        branch if rounded correctly
	    addq.l  #1,d1          round to the nearest
	    bpl.s   chksign        no overflow
	       tst.w   d7             overflow - check for negative result
	       bpl     err_intover    error if positive 2^31
chksign  tst.w   d7             check the sign
	 bpl.s   done3
	    neg.l   d1             else convert to negative
done3    move.l  d1,d0          place result in correct register
	 rts
*
*  Boundary condition checks.
*
check32  tst.w   d0             check sign first
	 bpl     err_intover    remember, shifted right by 16
	    and.w   #$000f,d0      mantissa of 2^31-.5 = ([1]00000 00100000)
	    bne     err_intover    definitely WAY too large
	       lsr.l   #5,d1          else shift till get LSb
	       bne     err_intover    if non-zero, less than -2^31 - 0.5
		  bcs     err_intover    branch if equal to -2^31 - 0.5
		     move.l  #$80000000,d0  else return -2^31
		     rts
	 page
*******************************************************************************
*
*       Procedure  : rellntt
*
*       Description: Convert a real into a 32 bit integer (truncation).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellntt  move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover    too big if don't branch
	 beq.s   silkcheck
skip     tst.w   d6             for small numbers
	 bgt.s   in32cont       branch if will convert
	    moveq   #0,d0          else return 0
	    rts
*
*  Place top bits (except for hidden bit) all in d1.
*
in32cont and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
*
*  Finish the conversion.
*
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 31
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 tst.w   d7             check the sign
	 bpl.s   done32
	    neg.l   d1             else convert to negative
done32   move.l  d1,d0          place result in correct register
	 rts
*
silkcheck tst.w  d0             check the sign first
	 bpl     err_intover
	    and.w   #$000f,d0
	    bne     err_intover if MS bite non-zero, WAY TOO LARGE
	    lsr.l   #5,d1       shift fractional portion out
	    bne     err_intover
	       move.l   #$80000000,d0
	       rts
	 page
*******************************************************************************
*
*       Procedure  : lntrel
*
*       Description: Convert a 32 bit integer into a real number.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : d0         - integer to be converted
*
*       Registers  : d4-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

maxlnt   move.l  #$c1e00000,d0  return -2^31
	 moveq   #0,d1
	 rts
*
*  Main body of lntrel.
*
lntrel   moveq   #0,d7          will hold sign of result and exponent
	 moveq   #0,d1          bottom part of mantissa
	 tst.l   d0             check if non-zero
	 bne.s   nonzero        branch if non-zero
	    moveq   #0,d0          else returna zero result
	    move.l  d0,d1
	    rts                    and return
nonzero  bpl.s   ifposit        branch if positive
	    neg.l   d0             else convert to positive
	    bvs.s   maxlnt         branch if had -2^31
	    move.w  #$8000,d7      else set sign bit in result
*
*  Determine if a 16 bit integer hiding in 32 bits.
*
ifposit  swap    d0             check for a 16 bit integer
	 tst.w   d0
	 beq.s   int16          branch if a 16 bit integer
	    move.w  #1023+20,d4    place in the bias
	    move.w  d0,d5          test if have to left shift
	    and.w   #$fff0,d5
	    bne.s   highpart       branch if first one in top of word
	       move.l  #$00100000,d6  mask for the test for normalization
	       swap    d0             else restore number
loop4          add.l   d0,d0          at least 1 and most 4 shifts
	       subq.w  #1,d4
	       cmp.l   d6,d0
	       blt.s   loop4          until normalized
		  bra.s   shdone
highpart    move.w  d0,d5          see if at least 8 right shifts
	    and.w   #$0ff0,d5
	    bne.s   finrit         if non-zero, then at most 7 more shifts
	       swap    d0             restore mantissa
	       addq.l  #8,d4          adjust exponent
	       move.b  d0,d1
	       ror.l   #8,d1          d1 is correct
	       lsr.l   #8,d0          d0 is correct
	       bra.s   insmask
finrit      swap    d0             restore mantissa
insmask     move.l  #$00200000,d6  mask for the test for normalization
	    cmp.l   d6,d0
	    blt.s   shdone         if <, d0 correctly lined up
loop_7         lsr.l   #1,d0
	       roxr.l  #1,d1
	       addq.l  #1,d4
	       cmp.l   d6,d0          continue until normalized
	       bge.s   loop_7
		  bra.s   shdone
*
*  Have a 16 bit integer to convert, so do it fast.
*
int16    swap    d0             restore the integer
	 move.w  #1023+15,d4    place in the bias
	 move.l  #$00100000,d6  mask for the test for normalization
	 lsl.l   #5,d0          shift by at least 5
	 cmp.l   d6,d0          see if done
	 bge.s   shdone
*
*   At most 15 shifts left.
*
	 move.l  d0,d5          check for shift by 8
	 and.l   #$001fe000,d5
	 bne.s   chk7           branch if 7 or less shifts left
	    lsl.l   #8,d0          else shift by 8
	    subq.w  #8,d4          adjust exponent, and finish the shift
chk7     cmp.l   d6,d0          check implied one
	 bge.s   shdone
lp_7        add.l   d0,d0          else shift left
	    subq.w  #1,d4
	    cmp.l   d6,d0
	    blt.s   lp_7           continue until normalized
*
*  Splice result together.
*
shdone   subq.w  #1,d4          hidden bit will add back
	 lsl.w   #4,d4          place in correct locations
	 or.w    d4,d7          place exponent in with sign
	 swap    d7             in correct order
	 add.l   d7,d0          add in exponent and sign
	 rts
	 page
*******************************************************************************
*
*       Procedure  : rndnear
*
*       Description: Round a real number to the nearest whole real number.
*                    If the real is too large to be rounded, the same
*                    number is returned.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d5-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

rndnear  move.l  d0,d6          extract the exponent
	 swap    d6             place in low word
	 and.w   #$7ff0,d6      get rid of sign bit
	 lsr.w   #4,d6          in low 11 bits
	 sub.w   #1022,d6       unbiased exponent plus one
*
*  Check if number is too small or large.
*
	 bgt.s   checknxt       branch if check for exponent too large
	 blt.s   rnd_zero       branch if so small that return a zero
	    moveq   #0,d1          else return + or - 1.0
	    tst.l   d0             determine sign
	    bmi.s   retmin
	       move.l  #$3ff00000,d0
	       rts
retmin      move.l  #$bff00000,d0
	    rts
rnd_zero moveq   #0,d0
	 move.l  d0,d1
	 rts
checknxt cmp.w   #53,d6
	 blt.s   nearcon        continue the round; 1 <= exp <= 52
	    rts                    else return with same number
*
*  Compute index for the addition of 0.5.
*
nearcon  neg.w   d6             map into correct range
	 add.w   #53,d6         1 <= d6 <= 52  (so can add in a 1)
	 move.w  d6,d5          save for later clear of mantissa bits
	 subq.w  #1,d6          number of left shifts for the mask
	 moveq   #1,d7          mask for the add
*
*  Add 0.5 (in magnitude) to the number to be rounded.
*
	 cmp.w   #32,d6         see if add to d0 or d1
	 bge.s   add0           branch if add to d0
	    lsl.l   d6,d7          shift over correct number of places
	    add.l   d7,d1
	    bcc.s   finnr          no need to check for overflow
	       addq.l  #1,d0          propagate carry
	       bra.s   finnr          if overflow, exponent adjusted!
add0    sub.w   #32,d6          get the correct mask
	lsl.l   d6,d7
	add.l   d7,d0           do add - oveflow goes into mantissa
*
*   Clear the bottom (d5) bits of (d0,d1).
*
finnr    moveq  #-1,d7          mask for the clear
	 cmp.w  #32,d5
	 blt.s  cleard1         branch of only have to clear bits in d1
	    moveq  #0,d1           else clear all of d1; maybe some of d0
	    sub.w  #32,d5          adjust count
	    bne.s  clearcon        branch if more to clear
	       rts                    else return
clearcon    lsl.l  d5,d7           get mask
	    and.l  d7,d0
	    rts
cleard1  lsl.l  d5,d7
	 and.l  d7,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : adx
*
*       Description: Augment a real number's exponent. This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    1.1  11/03/83  For:
*                            o Removing the test for 0.
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - amount to be augmented
*
*       Registers  : d6         - scratch
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

adx      swap    d0             put exponent into lower part
	 move.w  d0,d6          extract old exponent
	 and.w   #$800f,d0      first, remove old exponent in the result
	 and.w   #$7ff0,d6
	 asl.w   #4,d7          faster if don't have to shift back
	 add.w   d7,d6          new exponent computed
	 and.w   #$7ff0,d6      large exp and negative augment;negative sign
	 or.w    d6,d0          place in new exponent
	 swap    d0             restore correct order
	 rts
	 page
*******************************************************************************
*
*       Procedure  : intxp
*
*       Description: Extract the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*
*       Result     :  The result exponent is returned in d7.
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

intxp    move.l  d0,d7          don't destroy the original number
	 swap    d7             place exponent into low word
	 and.w   #$7ff0,d7
	 lsr.w   #4,d7
	 sub.w   #1022,d7       mantissa in range [0.5,1) (ignore hidden bit)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : setxp
*
*       Description: Set the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - unbiased value of the new exponent.
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

setxp    swap    d0
	 and.w   #$800f,d0      remove the exponent
	 add.w   #1022,d7       hidden bit becomes part of exponent
	 lsl.w   #4,d7          always positive after bias add, so do lsl
	 or.w    d7,d0          place in new exponent
	 swap    d0             re-align
	 rts
	 page
*******************************************************************************
*
*       Procedure  : compare
*
*       Description: Compare operand 1 with operand 2. Both operands are
*                    64 bit floating point reals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For -0 as valid input
*
*       Parameters : (d0,d1)    - operand 1
*                    (d2,d3)    - operand 2
*
*       Result     : Returned in the CCR (EQ,NE,GT,LT,GE,LE).
*
*       Misc       : The operands are not destroyed, and no other registers
*                    are used.
*
*******************************************************************************

compare  tst.l   d0             test first for sign of the first operand
	 bpl.s   rcomp2
	 tst.l   d2             test sign of second operand
	 bpl.s   rcomp2
*
	 cmp.l   d0,d2          both negative so do test backward
	 bne.s   cmpend         CCR set here
	 cmp.l   d1,d3          first part equal, check second part
	 beq.s   cmpend         EQ flag set
	 bhi.s   grt            unsigned compare
lst         move    #8,CCR         XNZVC = 01000
	    rts
*
rcomp2   cmp.l   d2,d0          at least one positive, ordinary test
	 bne.s   checkm0        must check for 0 compared with -0
	 cmp.l   d3,d1          both must be positive
	 beq.s   cmpend
	 bls.s   lst            branch if LT
grt         move    #0,CCR         XNZVC = 00000
cmpend   rts
*
* Check for the operands being 0 and -0.
*
checkm0  tst.l   d0
	 bpl.s   d2minus        branch if second operand is negative
	    cmp.l   #minuszero,d0  else (d0,d1) is negative
	    bne.s   finm0       reset condition code
	    tst.l   d2
	    bne.s   finm0       must check all of it
	       rts                 had (d0,d1) = -0 and (d2,d3) = 0
d2minus  cmp.l   #minuszero,d2  (d2,d3) is negative
	 bne.s   finm0       reset condition code
	 tst.l   d0
	 bne.s   finm0       must check all of it
	    rts              had (d2,d3) = -0 and (d0,d1) = 0
finm0   cmp.l   d2,d0        else reset condition code
	rts
	page
*******************************************************************************
*
*       Procedures : soft_horner / soft_hornera
*
*       Description: Evaluate a polynomial. "soft_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the software
*                    versions of the elementary function evaluations. These
*                    procedures call software floating point routines.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : (a4,a5)    - real number to be evaluated
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : d2,d3      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : radd, rmul
*
*       Miscel     : These procedures used to be know as "horner" and
*                    "hornera" respectively. For hardware floating
*                    point, 2 different procedures are needed: one
*                    for the software math and one for the hardware math.
*
*******************************************************************************

soft_horner move.w  d0,-(sp)    save the degree of the polynomial
	 move.l  (a6)+,d0       initialize result to first coeff.
	 move.l  (a6)+,d1
horloop     move.l  a4,d2          get w
	    move.l  a5,d3
	    bsr     rmul           previous result * w
	    move.l  (a6)+,d2       get next coefficient
	    move.l  (a6)+,d3
	    bsr     radd           add to previous result
	    subq.w  #1,(sp)
	    bne.s   horloop
hordone  addq.l  #2,sp          remove the degree count
	 rts

soft_hornera  move.w  d0,-(sp)  save the degree of the polynomial
	 move.l  a4,d0          initialize result to w
	 move.l  a5,d1
horloopa move.l  (a6)+,d2       get next coefficient; (d0,d1) ok
	 move.l  (a6)+,d3
	 bsr     radd           do the addition; (d0,d1) has result
	 subq.w  #1,(sp)
	 beq.s   hordone
	    move.l  a4,d2          get w; (d0,d1) correct
	    move.l  a5,d3
	    bsr     rmul           (d0,d1) has result
	    bra.s   horloopa
	 page
*******************************************************************************
*
*       Procedures : flpt_horner / flpt_hornera
*
*       Description: Evaluate a polynomial. "flpt_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the
*                    elementary function evaluation.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : (a4,a5)    - real number to be evaluated (w)
*                    a0         - address of the floating point hardware
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : f0-f5      - scratch floating point registers
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned in (f1,f0).
*
*       Error(s)   : All arguments are defined to be in a restricted range,
*                    so error conditions cannot arise.
*
*       Miscel     : The caller must save and restore the contents of f0-f5.
*                    (a4,a5) is left unchanged.
*
*******************************************************************************

flpt_horner move.l (a6)+,movf_m_f1(a0)  first coefficient result in (f1,f0)
	 move.l  (a6)+,movf_m_f0(a0)
	 movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
fhorloop    tst.w   mull_f4_f0(a0)         w * previous result
	    movem.l bogus4(a0),d4-d5       bogus reads and get error flag
	    move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	    move.l  (a6)+,movf_m_f2(a0)
	    tst.w   addl_f2_f0(a0)         add coefficient to previous result
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    subq.w  #1,d0                  see if done
	    bne.s   fhorloop
fhordone rts


flpt_hornera  movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
	 tst.w   movl_f4_f0(a0)         w is also first partial result
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag

fhorlopa move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	 move.l  (a6)+,movf_m_f2(a0)
	 tst.w   addl_f2_f0(a0)         previous result + coefficient
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	 subq.w  #1,d0                  see if done
	 beq.s   fhordone
	    tst.w  mull_f4_f0(a0)          else result*w
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    bra.s   fhorlopa
	 page
*******************************************************************************
*
*       Procedure  : flpt_error
*
*       Description: Determine the type of error that has just happened in the
*                    16081 FPU and generate the appropriate Pascal Workstation
*                    ESCAPECODE.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*
*       Registers  : d0         - the 16081 FPU status register
*                    a0         - address of the floating point card
*
*       Result     : An ESCAPE is generated.
*
*       References : flpt_cardaddr, err_overflow, err_underflow,
*                    err_divzero, err_miscel
*
*       Miscel     : A 'miscellaneous floating point hardware error' escape
*                    is generated for things other than underflow, overflow,
*                    and divide-by-zero.
*
*******************************************************************************

flpt_error  equ  *                         the floating point error handler
	moveq   #flpt_extracttrap,d0       extract the TT field
	and.l   sfsr_m_m+flpt_cardaddr,d0  the floating point status register
	cmpi.w  #flpt_under,d0
	beq     err_underflow
	cmpi.w  #flpt_over,d0
	beq     err_overflow
	cmpi.w  #flpt_divzero,d0
	beq     err_divzero
	bra     err_miscel              miscellaneous floating point error
	page
*******************************************************************************
*
*       Procedure  : flpt_reset
*
*       Description: Reset the floating point card, and initialize the 16081
*                    FPU with a rounding mode of round-to-even and set the
*                    underflow enable trap.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*                  : 3.2  02/19/87 DRAGON support       SFB
*
*       Registers  : d0,d1           - scratch
*
*       Parameters : None
*
*       References : flpt_cardaddr
*
*******************************************************************************

flpt_reset equ *
	lea     flpt_cardaddr,a0                point to the card
	cmpi.b  #flpt_card_id,flpt_id(a0)       see if it has correct ID SFB
	beq     is_float_card                   if so, continue SFB
	move.w  #-12,SYSGLOBALS-2(a5)           else escapecode:=buserror SFB
	trap    #10                             and escape(escapecode) SFB
is_float_card equ *                             SFB
	move.b  #1,flpt_id(a0)                  enable the card
	move.l  #flpt_initmask,lfsr_m_m(a0)     UEN; RM to nearest
	rts
	page
*******************************************************************************
*
*       Procedure  : relbcd
*
*       Description: Convert a real number into a decimal string.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*
*       Parameters : (d0,d1)    - real argument to be converted
*                    a0         - address of the result
*                    d7         - number of digits wanted
*
*       Registers  : (d2,d3)    - value from table
*                    d4         - estimator
*                    d5         - index into table
*                    d6         - scratch
*                    d7         - number of digits to return
*                    a1         - table addresses/ local storage
*
*       Result     : The result is returned through (a0).
*
*       Error(s)   : Invalid IEEE real numbers
*
*       References : tb_pwtt, tb_auxpt, tb_bin, rmul, err_illnumbr
*
*******************************************************************************

*
*  Real to bcd convert begins here. Determine sign of result.
*
relbcd  cmp.l   #minuszero,d0  check for a -0
	bne.s   relb_1         branch if not possible
	   tst.l    d1            must be a zero here!
	   bne      err_illnumbr
	      move.w  #1,(a0)+       store negative signed result
	      clr.w   (a0)+          and return a zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts
relb_1  tst.l   d0             check for zero
	bne.s   bcd_nzer       non-zero, but could still be illegal
	   tst.l   d1
	   bne     err_illnumbr
	      clr.l   (a0)+          return zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts                    fix this up if unpacked
bcd_nzer bmi.s   bcd_neg
	    clr.w   (a0)+          store positive sign result
	    bra.s   rbcd_1
bcd_neg  move.w  #1,(a0)+       store negative signed result
	 bclr    #31,d0         and clear sign
rbcd_1   move.l  d0,d4          scratch register
	 swap    d4             get exponent
	 and.w   #$7ff0,d4      mask off fraction and sign
*
*  Check for valid exponent.
*
	 lsr.w   #4,d4          right justify
	 beq     err_illnumbr   exponent too small?
	 sub.w   #1023,d4       remove bias
	 cmp.w   #1023,d4       exponent too large?
	 bgt     err_illnumbr
*
*  Compute the estimator E = TRUNC(log10(2) * exponent). Computation is done
*  with a fixed point multiply.
*
	 move.w  #$4d10,d5      log10(2) = 0.4d104... (hex)
	 tst.w   d4             check the sign of the base 2 exponent
	 bge.s   mul1           d5 as correct estimator
	    addq.w   #1,d5         negative exponents require 0.4d11      bug69
mul1     muls    d5,d4
	 swap    d4             remove fractional part of the result
	 addq.w  #1,d4          1 larger for the algorithm
*
	 move.w  d4,d5          copy into d5 for table indexing
	 add.w   #64,d5         add 64 for biasing to positive
	 bmi.s   rbcd_3         test for  -64 <= E <= +64
	    cmp.w   #128,d5
	    ble.s   rbcd_2         branch if only one multiply necessary
*
*  Map the number to be converted into the range (10^-64,10^64) using
*  an additional floating multiply.
*
rbcd_3   move.w  d4,d5
	 asr.w   #6,d5          estimator div 64
	 bpl.s   div_fix1       branch if no fixup necessary
	    addq.w  #1,d5          to keep mod and div correct
div_fix1 neg.w   d5             form address of reciprocal
	 addq.w  #4,d5          bias to the positive
	 asl.w   #3,d5          * 8 (bytes per real)
	 lea     tb_auxpt,a1    address of 10^(N*64) table
	 move.l  0(a1,d5.w),d2  get real from table
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          save estimator
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
	 move.w  a1,d4          restore estimator
	 move.w  d4,d5          calculate index for next operation
	 asr.w   #6,d5          estmator div 64
	 bpl.s   div_fix2
	    addq.w  #1,d5          to keep mod consistent with the div
div_fix2 asl.w   #6,d5          calculating estimator mod 64
	 neg.w   d5
	 add.w   d4,d5
	 add.w   #64,d5         bias to positive
*
*  Number is in appropriate range. Use estimator as an index to see
*  if the number is in the correct decade. If they are in the same decade,
*  modify the offset to point to the next larger decade so the map will work.
*
rbcd_2   asl.w   #3,d5          convert logical index to physical
	 lea     tb_pwtt,a1     address of table
	 move.l  0(a1,d5.w),d2  get high order entry
	 cmp.l   d2,d0          compare high order parts
	 blt.s   adjes          branch if table entry will work in the map
	 bgt.s   not_adj        branch if must retrieve the next table entry
	    move.l  4(a1,d5.w),d3  tops are equal; compare low order parts
	    cmp.l   d3,d1          must be unsigned compare!
	    bcs.s   adjes          branch if low (if carry is set, must be low)
not_adj        addq.w  #8,d5          adjust index to next entry
	       bra.s   bcmul          so number will map into correct range
*
*  Map the number into the range [.1,1). If the number to be converted is a
*  power of ten, final real result may be 1 or 2 bits less than .1 because of
*  the rounded table entry and the inexact real multiply. This condition is
*  checked for and the correct BCD number is returned.
*
*  If the number to be converted is a power of ten, the map may also produce a
*  value of 1. This condition is also checked for.
*
adjes    subq.w  #1,d4          adjust exponent estimator (reach only if lt ! )
bcmul    sub.w  #512,d5         find complement table entry
	 neg.w   d5
	 add.w   #512,d5
	 move.l  0(a1,d5.w),d2  fetch value for conversion
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          estimator here to stay in a1 !!
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
*
*  Test for the result being less than 0.1
*
	 addq.w  #1,a1          adjust the exponent
	 cmp.l   #$3fb99999,d0  top part of 0.1
	 bgt.s   real_c1        branch if (d0,d1) > .1
	    cmp.l   #$9999999a,d1  tops are = ; must check the bottom parts
	    bcc.s   real_c1        cc implies greater than or equal to
	       move.l  #$10000000,(a0)+ else return bcd value of .1
	       clr.l   (a0)+          return 16 digits (faster than checking d7)
	       move.w  a1,(a0)        place exp into the bcd buffer
	       rts
*
*  Check for the converted number being exactly one.
*
real_c1  cmp.l   #$3ff00000,d0  check for (d0,d1) = 1 = (3ff00000 00000000)
	 bne.s   real_c2        branch if ok
	    move.l  #$10000000,(a0)+ else return bcd value of 1
	    clr.l   (a0)+          return 16 digits (faster than checking d7)
	    addq.w  #1,a1          boundary condition, so another adjust
	    move.w  a1,(a0)        place into the bcd buffer
	    rts
*
*  Fix up result so that implied decimal point is after bit #23 in d0. Hence bit
*  numbers 24/31 will contain the 2 decimal digits after each multiply by 100.
*
real_c2  move.l  d0,d6          extract exponent into d6
	 swap    d6
	 lsr.w   #4,d6
	 sub.w   #1023-4,d6     compute the number of left shifts
	 swap    d0
	 and.w   #$f,d0
	 or.w    #$10,d0        put in hiden one
	 swap    d0
	 tst.b   d6
	 beq.s   finish
lpten       add.l   d1,d1          loop to shift (at most 4 shifts)
	    addx.l  d0,d0
	    subq.b  #1,d6
	    bne.s   lpten
*
*  Extract the correct number of digits (as specified by d7). One extra digit
*  is returned for the purposes of rounding.
*
finish   move.w  a1,8(a0)       place exponent in memory first
	 lea     tb_bin,a1      address of binary to double bcd table
	 bgt.s   fin_1          check for improper number of digits
maxnum      moveq   #15,d7         boundary condition
	    bra.s   lp16m          get all the digits
fin_1    cmp.w   #16,d7         check if wants all the digits
	 bge.s   maxnum         branch if set counter to maximum amount
*
	 ror.b   #1,d7          determine if odd or even number wanted
	 bcs.s   oddnum         branch if odd number wanted
	    rol.b   #1,d7          even number wanted - adjust counter
	    addq.w  #1,d7
	    bra.s   lp16m
oddnum   rol.b   #1,d7          restore odd number of digits
*
lp16m    move.l  d0,d2          multiply by 100 by shift and add
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 move.l  d0,d2
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 swap    d0             extract top 8 bits for conversion
	 move.w  d0,d3
	 lsr.w   #8,d3
	 and.w   #$00ff,d0      remove top 8 bits from conversion product
	 swap    d0
	 move.b  0(a1,d3.w),(a0)+ store in result area
	 subq.w  #2,d7          and loop (2 digits per loop)
	 bpl.s   lp16m          until gotten correct number of digits
	 rts
	 page
*******************************************************************************
*
*       Procedure  : bcdrel
*
*       Description: Convert a bcd number into a real number.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : a0         - address of the bcd number
*
*       Registers  : a1         - address of tables
*                    d2-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Decimal strings too large or too small.
*
*       References : rmul, err_impvalue
*                    tb_pwt, tb_pwt4, tb_pwt8, tb_auxpt, tb_bcd
*
*******************************************************************************

*
*  Only eight digits to convert so do it fast.
*
bcd8     mulu    #10000,d0
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d0          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d0          last add for fraction
	 addq.l  #4,a0          point at bcd exponent
	 moveq   #0,d1          shift result right 6 places
	 move.w  d0,d1          across d0,d1 pair
	 lsr.l   #6,d0
	 ror.l   #6,d1
	 clr.w   d1
	 move.l  d0,d6          form index for normalizing
	 swap d6
	 and.w   #$1e,d6        look at bits 20, 19, 18, and 17
	 move.w  pn_tb_4(d6.w),d6 lookup shift value
	 move.w  #1023+26-1,d7  exponent value if normalized
	 sub.w   d6,d7          subtract # of shifts required
	 neg.w   d6             computed goto for normalizing
	 addq    #4,d6
	 asl.w   #2,d6
	 jmp     shiftr8(d6.w)
shiftr8  add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 4
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 3
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 2
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 1
	 asl.w   #4,d7          shift exponent into position
	 swap    d7
	 add.l   d7,d0          add to fraction, removing hidden 1
	 lea     tb_pwt8,a1     address of table used for 8 digit convert
	 bra     fractsgn       determine sign and finish conversion
*
*  Table for number of normalization shifts versus value.
*  It must be in this location for short mode addressing.
*
pn_tb_4  dc.w    4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0

*******************************************************************************
*
*  Only four digits (8 at most) to convert so do it extremely fast.
*
bcd4     clr.w   d0
	 move.b  (a0)+,d0       get first two digits
	 move.b  0(a1,d0.w),d0  lookup binary value
	 mulu    #100,d0        weight by 100
	 move.b  (a0)+,d7       get second two digits
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.w   d7,d0
	 tst.w   (a0)           four more digits?
	 bne     bcd8           branch only if 4 more digits
	    addq.l  #6,a0          point at exponent
	    moveq   #0,d1          if four digits then low order real =0
	    asl.l   #7,d0          shift by at least 7 to post normalize
	    move.l  d0,d6          form an index
	    swap    d6             for post normalization
	    and.w   #$1e,d6        look at bits 20,19,18, and 17
	    move.w  pn_tb_4(d6.w),d6 lookup shift value
	    asl.l   d6,d0          normalize real
	    move.w  #1023+13-1,d7  form exponent
	    sub.w   d6,d7          subtract amount normalized
	    asl.w   #4,d7          align into position
	    swap    d7
	    add.l   d7,d0          merge into fraction
	    lea     tb_pwt4,a1     address of table for 4 digit convert
	    bra     fractsgn

*******************************************************************************
*
*  BCD to real conversion begins here.
*
bcdrel   addq.l  #2,a0          skip over sign
*
*  Convert first eight bcd digits to binary and store in d2.
*
	 tst.b   (a0)           check for zero (remember, must be normalized!)
	 bne.s   continue       continue if non-zero
	    moveq   #0,d0          else return a value of 0
	    move.l  d0,d1
	    rts
continue lea     tb_bcd,a1      address of 2 digit bcd to binary table
	 moveq   #0,d3
	 moveq   #0,d7
	 moveq   #0,d2
	 tst.l   4(a0)          check for 8 or less digits
	 beq.s   bcd4
	 move.b  (a0)+,d2       fetch first bcd digit pair
	 move.b  0(a1,d2.w),d2  lookup its binary value
	 mulu    #62500,d2      multiply by 1,000,000
	 asl.l   #4,d2          (62,500*16)
	 move.b  (a0)+,d7       fetch second pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d2          add to sum
*
*  Convert bottom eight bcd digits and store in d3.
*
	 move.b  (a0)+,d3       fetch fifth bcd digit pair
	 move.b  0(a1,d3.w),d3  lookup its binary value
	 mulu    #62500,d3      multiply by 1,000,000
	 asl.l   #4,d3          (62,500*16)
	 move.b  (a0)+,d7       fetch sixth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch seventh pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch eighth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d3          add to sum
*
*  Multiply high order part by 1,000,000 and add low order part
*  1,000,000=$5f5e100. Result=(((hi * 5f5e) * $1000) + (hi * $100)) + lo.
*
	 moveq   #0,d4
	 move.w  d2,d1
	 mulu    #$5f5e,d1      hi.word(lower) * 5f5e
	 move.l  d2,d0
	 swap    d0
	 mulu    #$5f5e,d0      hi.word(upper) * 5f5e
	 swap    d1
	 move.w  d1,d4
	 clr.w   d1
	 add.l   d4,d0
	 move.w  d0,d4
	 lsr.l   #4,d0          multiply by $1000 by shifting
	 lsr.l   #4,d1
	 ror.l   #4,d4
	 clr.w   d4
	 or.l    d4,d1
	 move.l  d2,d4
	 clr.w   d4
	 swap    d4
	 lsr.w   #8,d4          multiply hi by $100 by shifting
	 lsl.l   #8,d2
	 add.l   d2,d1          add to previous result
	 addx.l  d4,d0
	 add.l   d3,d1          add in conversion from lower 8 digits
	 bcc.s   bcdr_nz
	    addq.l  #1,d0
*
*  Use jump table for post normalization and exponent location.
*
bcdr_nz  move.l  d0,d6
	 swap    d6             get upper 16 bits of fraction
	 and.w   #$3e,d6        mask off all but top 5 bits (17-21)
	 move.w  eval_exp(d6.w),d7 look up exponent
	 jmp     pn_table(d6.w)
*
*  Exponent value table for converted bcd integer.
*  1023 (bias) + 52 (size of integer) - #postnorm shifts
*  -1 (gets rid of hidden one) all times 16 to bit align.
*
eval_exp dc.w    17120
	 dc.w    17136
	 dc.w    17152
	 dc.w    17152
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17184,17184,17184,17184
	 dc.w    17184,17184,17184,17184
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
pn_table bra.s   pn_4
	 bra.s   pn_3
	 bra.s   pn_2
	 bra.s   pn_2
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 nop                    must be there; can't branch to next instruction!
*
pn_m1    lsr.l   #1,d0          16 digit bcd number was too large
	 roxr.l  #1,d1          and so overflowed requiring a shift
	 bra.s   pn_done        to the right and dumping of one bit
*
pn_4     add.l   d1,d1
	 addx.l  d0,d0
pn_3     add.l   d1,d1
	 addx.l  d0,d0
pn_2     add.l   d1,d1
	 addx.l  d0,d0
pn_1     add.l   d1,d1
	 addx.l  d0,d0
pn_0     equ     *
pn_done  swap    d7             insert exponent
	 add.l   d7,d0          automatically removes hidden one
	 lea     tb_pwt,a1      address of primary powers of ten table
*
*  Check sign of bcd number.
*
fractsgn tst.w   -10(a0)        test bcd sign
	 beq.s   firfl
	    bset    #31,d0         set sign bit if negative
*
*  Fetch exponent, and test for proper range.
*
firfl    move.w  (a0),d3        get binary exponent
	 cmp.w   #-309,d3
	 blt     err_impvalue   number too small
	 cmp.w   #309,d3
	 bgt     err_impvalue   number too large
*
*  Check for one or two multiplies.
*
	 move.w  d3,d6
	 add.w   #64,d6         bias to the positive
	 bmi.s   bcdr_3         E<-64?
	 cmp.w   #128,d6        E>64?
	 bgt.s   bcdr_3         must do 2 multiplies, return here later
bcdr_4      asl.w   #3,d6          convert logical to physical index
	    move.l  0(a1,d6.w),d2  lookup values
	    move.l  4(a1,d6.w),d3
	       move.l  sysglobals-10(a5),-(sp) TRY, could get over or underflow
	       pea     improper       address for the possible ESCAPE
	       move.l  sp,sysglobals-10(a5)
	       bsr     rmul           do the operation
	       addq.l  #4,sp          remove ESCAPE address
	       move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	    rts
*
*  Exponent > abs(64).
*
bcdr_3   move.w  d3,-(sp)       save exponent for later
	 asr.w   #6,d3          div 64
	 bpl.s   divfix1        this is Paul Beiser's patented DIV
	    addq.w  #1,d3
divfix1  addq.w  #4,d3          bias to the positive
	 asl.w   #3,d3          change logical to physical index
	 lea     tb_auxpt,a0       address of secondary table
	 move.l  0(a0,d3.w),d2
	 move.l  4(a0,d3.w),d3  fetch value
	 bsr     rmul           do the operation
	 move.w  (sp)+,d6       restore exponent
	 move.w  d6,d3          find exponent mod 64
	 asr.w   #6,d3
	 bpl.s   divfix2        thank you Paul
	    addq.w  #1,d3
divfix2  asl.w   #6,d3
	 sub.w   d3,d6
	 add.w   #64,d6         bias to the positive
	 bra     bcdr_4         one more multiply to do
*
*  Either real multiply generated an ESCAPE or error detected earlier.
*  Generate the ESCAPE with the correct error code.
*
improper move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 bra     err_impvalue               improper value error
	 page
*******************************************************************************
*
*       Procedure  : flpt_sin / flpt_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a1         - flag for either sin/cos
*                    a0         - address of the floating point card
*                    -(sp)      - sign of the result
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : flpt_horner, compare, cff_sin, flpt_cardaddr, rellnt
*                    err_trigerr
*
*******************************************************************************

flpt_sin move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 suba.w  a1,a1                  set flag for in the sin routine
	 move.l  d1,movf_m_f0(a0)       (f1,f0) <- x
	 move.l  d0,movf_m_f1(a0)
	 bmi.s   f@@step2neg             branch if set sgn flag to negative
	    move.w  #1,-(sp)               set sgn flag to positive
	    bra.s   f@@sincs9
f@@step2neg move.w  #-1,-(sp)            sgn flag negative
	 cmp.l    #minuszero,d0         check for a -0
	 bne.s    stx@@3                 branch if not a -0
	    move.w  #1,(sp)                else change sign to +
stx@@3    tst.w   absl_f0_f0(a0)         make (f1,f0) positive
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
f@@sincs9 tst.w   movl_f0_f2(a0)         (f2,f3) <- abs(x) = y
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 bra.s   f@@sincos               (f1,f0) <- abs(x)
*
*  Entry point for the cosine routine.
*
flpt_cos move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 moveq   #1,d3                  can't move immediate to A register
	 movea.w d3,a1                  set flag for in the cos routine
	 move.l  d1,movf_m_f0(a0)       (f0,f1) <- x
	 move.l  d0,movf_m_f1(a0)
	 bne.s   f@@cos_1                if non-zero continue
f@@cosret1   move.l  #$3ff00000,d0          else return 1 as the result
	    moveq   #0,d1
	    bra     f@@done                 (d0,d1) <- 1;
f@@cos_1  cmp.l   #minuszero,d0          check for a -0
	 beq.s   f@@cosret1
	 move.w  #1,-(sp)               set sgn flag to one
	 tst.w   absl_f0_f0(a0)         (f1,f0) <- abs(x)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ff921fb,movf_m_f3(a0)    pi/2
	 move.l  #$54442d18,movf_m_f2(a0)
	 tst.w   addl_f0_f2(a0)         (f2,f3) <- y = abs(x) + pi/2
	 movem.l bogus4(a0),d4-d5
*
*  Common point for both the sine and cosine routines.
*  (f1,f0) <- abs(x), (f3,f2) <- y
*
f@@sincos move.l  movf_f3_m(a0),d0       get y
	 move.l  movf_f2_m(a0),d1
	 move.l  #$41b1c583,d2          check argument not too large
	 move.l  #$1a000000,d3          ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr             branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,movf_m_f5(a0)  compute y * 1/pi
	 move.l  #$6dc9c883,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f5,f4) <- y*1/pi
	 movem.l bogus4(a0),d4-d5
	 btst    #q,status(a0)          see if had underflow
	 beq     f@@sin34                continue if no underflow
	    move.l  #0,movf_m_f5(a0)       else set result to 0
	    move.l  #0,movf_m_f4(a0)       and continue
f@@sin34  move.l  movf_f5_m(a0),d0       get the result
	 move.l  movf_f4_m(a0),d1
	 bsr     rellnt                 convert to a 32 bit integer
	 move.w  d0,d7                  scratch register
	 lsr.w   #1,d7                  determine if even or odd
	 bcc.s   f@@step8                branch if even
	    neg.w   (sp)                   sgn <- -sgn
f@@step8  move.l  d0,movil_m_f4(a0)      (f5,f4) <- xn (converted d0 to real)
	 movem.l bogus4(a0),d4-d5
*
*  See if adjustment necessary to xn. At this stage,
*  (f1,f0) <- abs(x), (f3,f2) <- y, and (f5,f4) <- xn.
*
	 move.w  a1,d6                  for the check
	 beq.s   f@@step10               branch if sin wanted
	    move.l  #$bfe00000,movf_m_f7(a0)  else adjust xn
	    move.l  #0,movf_m_f6(a0)          by -1/2
	    tst.w   addl_f6_f4(a0)         (f5,f4) <- xn = xn - 0.5
	    movem.l bogus4(a0),d4-d5
*
*  Compute the reduced argument f.
*
f@@step10 move.l  #$c0092200,movf_m_f7(a0)  get constant -c1
	 move.l  #0,movf_m_f6(a0)       (f7,f6) <- -c1
	 tst.w   mull_f4_f6(a0)         (f7,f6) <- -xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- abs(x) - xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ee2aeef,movf_m_f7(a0) (f7,f6) <- c2
	 move.l  #$4b9ee59e,movf_m_f6(a0)
	 tst.w   mull_f6_f4(a0)         (f5,f4) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f1,f0) <- f = (abs(x) - xn*c1) + xn*c2
	 movem.l bogus4(a0),d4-d5
*
*  Check size of reduced argument. If too small, return f as result else
*  compute g and continue. At this point, (f1,f0) <- f.
*
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  d0,d6                  save the top part of f
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   f@@step12               branch if f not too small
	    move.l  d6,d0                  else return f as the answer
	    bra.s   f@@sign_tst             check for the correct sign
f@@step12 tst.w   movl_f0_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         g <- f*f
	 movem.l bogus4(a0),d4-d5
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result. At
*  this point, (f1,f0) <- f and (f3,f2) <- g.
*
	 movea.l movf_f3_m(a0),a4       number to be evaluated g
	 movea.l movf_f2_m(a0),a5
	 lea     cff_sin,a6             point to coefficients
	 moveq   #7,d0                  degree of polynomial
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- f (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 bsr     flpt_horner            compute p(g); result in (f1,f0)
	 movem.l a4-a5,movf_m_f3(a0)    restore g
	 tst.w   mull_f0_f2(a0)         (f3,f2) <- g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f2(a0)         (f3,f2) <- f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f6(a0)         (f6,f7) <- f + f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f7_m(a0),d0       (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
*
f@@sign_tst tst.w (sp)+          retrieve sgn
	 bpl.s   f@@done         branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
f@@done   movem.l (sp)+,a5-a6     restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_sin / soft_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : radd, rmul, soft_horner, err_trigerr
*                    compare, lntrel, rellnt, cff_sin, sysglobals
*
*******************************************************************************

soft_sin move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bmi.s   step2neg       branch if set sgn flag to negative
	    move.w  #1,-(sp)       set sgn flag to positive
	    movea.l d0,a0          (a0,a1) <- x
	    movea.l d1,a1
	    bra.s   sincos         common point for both routines
step2neg move.w  #-1,-(sp)      sgn flag negative
	 cmp.l    #minuszero,d0 check for a -0
	 bne.s    sty@@3         branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sty@@3    bclr    #31,d0
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 bra.s   sincos
*
*  Entry point for the cosine routine.
*
soft_cos move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bne.s   cos_1          if non-zero continue
cosret1     move.l  #$3ff00000,d0 else return 1 as the result
	    moveq   #0,d1
	    bra     done          (d0,d1) <- 1;
cos_1    cmp.l   #minuszero,d0  check for -0
	 beq.s   cosret1
	 move.w  #1,-(sp)       set sgn flag to one
	 bclr    #31,d0         abs(x)
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 move.l  #$3ff921fb,d2  pi/2
	 move.l  #$54442d18,d3
	 bsr     radd           y = abs(x) + pi/2
*
*  Common point for both the sine and cosine routines.
*
sincos   movea.l d0,a2          (a2,a3) <- y
	 movea.l d1,a3
	 move.l  #$41b1c583,d2  check argument not too large
	 move.l  #$1a000000,d3  ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr    branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,d2  compute y * 1/pi
	 move.l  #$6dc9c883,d3
	    move.l  sysglobals-10(a5),-(sp)
	    pea     recover        in case of underflow
	    move.l  sp,sysglobals-10(a5)     new try block
	    bsr     rmul
	    addq.l  #4,sp          remove error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 bsr     rellnt         round result to a 32 bit integer
	 move.w  d0,d7          scratch register
	 lsr.w   #1,d7          determine if even or odd
	 bcc.s   step8          branch if even
	    neg.w   (sp)           sgn <- -sgn
step8    bsr     lntrel         (d0,d1) <- xn
	 movea.l a2,a4          (a4,a5) <- y
	 movea.l a3,a5
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  See if adjustment necessary to xn.
*
	 move.l  a0,d0          retrieve abs(x)
	 move.l  a1,d1
	 move.l  a4,d2          retrieve y
	 move.l  a5,d3
	 bsr     compare        check abs(x) = y
	 beq.s   step10a        branch if sin wanted
	    move.l  a2,d0          else adjust xn
	    move.l  a3,d1
	    move.l  #$bfe00000,d2  -1/2
	    moveq   #0,d3
	    bsr     radd           xn <- xn - 0.5
	    movea.l d0,a2          (a2,a3) <- xn
	    movea.l d1,a3
	    bra.s   step10
step10a  move.l  a2,d0          load up (d0,d1) with xn
	 move.l  a3,d1
*
*  Compute the reduced argument f.
*
step10   move.l  #$c0092200,d2  get constant -c1
	 moveq   #0,d3          (d0,d1) already has xn
	 bsr     rmul           -xn*c1
	 move.l  a0,d2          get abs(x)
	 move.l  a1,d3
	 bsr     radd           abs(x) - xn*c1
	 movea.l d0,a0          save in (a0,a1)
	 movea.l d1,a1          abs(x) no longer needed
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3ee2aeef,d2  c2
	 move.l  #$4b9ee59e,d3
	 bsr     rmul           xn*c2
	 move.l  a0,d2          retrieve intermediate result
	 move.l  a1,d3
	 bsr     radd           (abs(x) - xn*c1) + xn*c2
	 movea.l d0,a0          (a0,a1) <- f
	 movea.l d1,a1
*
*  Check size of reduced argument. If too small, return
*  f as result else compute g and continue.
*
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   step12         branch if f not too small
	    move.l  a0,d0          else return f as the answer
	    bra.s   sign_tst       still must check for the correct sign
step12   move.l  a0,d0          restore top part of f
	 move.l  d0,d2
	 move.l  d1,d3
	 bsr     rmul           g <- f*f
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result.
*
	 movea.l d0,a4          number to be evaluated
	 movea.l d1,a5
	 lea     cff_sin,a6     point to coefficients
	 moveq   #7,d0          degree of polynomial
	 bsr     soft_horner    compute p(g)
	 move.l  a4,d2          retrieve g
	 move.l  a5,d3
	 bsr     rmul           g*p(g)
	 move.l  a0,d2          retrieve f
	 move.l  a1,d3
	 bsr     rmul           f*g*p(g)
	 move.l  a0,d2          retrieve f again
	 move.l  a1,d3
	 bsr     radd           f + f*g*p(g)
*
sign_tst tst.w   (sp)+          retrieve sgn
	 bpl.s   done           branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
done     movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
*
*  Argument reduction caused an underflow error, so the sine routine
*  must have been called. Therefore, return the original argument as the
*  result.
*
recover  move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 move.l  a0,d0          get original argument
	 move.l  a1,d1
	 bra.s   sign_tst       determine the sign of original argument
	 page
*******************************************************************************
*
*       Procedure  : flpt_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : flpt_horner, rndnear, rellnt, adx, cff_expp, cff_expq
*                    compare, flpt_cardaddr, err_overflow, err_underflow
*
*******************************************************************************

flpt_exp move.l  4(sp),d0               get the operand
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow          underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6                  save top part of operand for later
	 bclr    #31,d0                 get the absolute value of the operand
	 move.l  #$3c900000,d2          threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   f@@exp_11               branch if operand in range
	    move.l  #$3ff00000,d0          else return answer of 1.0
	    moveq   #0,d1
	    bra     f@@donee1               place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
f@@exp_11 move.l  d6,d0                  restore top part of operand
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- x
	 move.l  #$3ff71547,movf_m_f3(a0)   (f2,f3) <- 1/ln(2)
	 move.l  #$652b82fe,movf_m_f2(a0)
	 tst.w   mull_f0_f2(a0)         (f2,f3) <- x * 1/ln(2)
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 move.l movf_f3_m(a0),d0        retrieve x * 1/ln(2)
	 move.l movf_f2_m(a0),d1
	 bsr     rndnear                (d0,d1) <- xn (conversion to int later)
	 movem.l d0-d1,movf_m_f3(a0)    (f2,f3) <- xn
*
*  Determine g. Have (f0,f1) <- x and (f2,f3) <- xn.
*
	 move.l  #$bfe63000,movf_m_f5(a0)  -0.543 octal = c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- x + xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3f2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- (x + xn*c1) + xn*c2 = g
	 movem.l bogus4(a0),d4-d5
*
*  Have (f2,f3) <- xn and (f0,f1) <- g.
*  Save xn in (a2,a3) and compute z, p(z), and g*p(z), and q(z).
*
	 movea.l movf_f2_m(a0),a3       xn is not needed till much later
	 movea.l movf_f3_m(a0),a2
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- g (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f0_f0(a0)         (f0,f1) <- g*g = z
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f0_m(a0),a5       (a4,a5) <- z
	 movea.l movf_f1_m(a0),a4
	 lea     cff_expp,a6            point to coefficients
	 moveq   #2,d0                  degree of p
	 bsr     flpt_horner            compute p(z); result in (f0,f1)
	 tst.w   mull_f0_f6(a0)         (f6,f7) <- g * p(z)
	 movem.l bogus4(a0),d4-d5
	 lea     cff_expq,a6            point to coefficients
	 moveq   #3,d0                  degree of q
	 bsr     flpt_horner            do the evaluation; (a4,a5) still has z
*
*  Have (f0,f1) <- q(z) and (f6,f7) <- g*p(z). Compute r(g).
*
	 tst.w   subl_f6_f0(a0)         (f0,f1) <- q(z) - g*p(z)
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f6(a0)         (f6,f7) <- g*p(z) / (q(z) - g*p(g))
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f1(a0) (f0,f1) <- 1/2
	 move.l  #0,movf_m_f0(a0)
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- r(g)
	 movem.l bogus4(a0),d4-d5
*
*  Compute integer value of xn, and finish computation.
*
	 move.l  a3,d1                  retrieve xn
	 move.l  a2,d0
	 bsr     rellnt                 32 bit integer (already been rounded)
	 addq.l  #1,d0                  part of step 9 in the algorithm
	 move.l  d0,d7                  augment with r to form result
	 move.l  movf_f1_m(a0),d0       retrieve r(g) from the chip
	 move.l  movf_f0_m(a0),d1
	 bsr     adx                    r(g) and n form the result
*
*  Place result on the stack.
*
f@@donee1 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : radd, rmul, rdvd, soft_horner,
*                    compare, rndnear, rellnt, adx, cff_expp, cff_expq
*                    err_overflow, err_underflow
*
*******************************************************************************

soft_exp move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6          save top part of operand for later
	 bclr    #31,d0         get the absolute value of the operand
	 move.l  #$3c900000,d2  threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   exp_11         branch if operand in range
	    move.l  #$3ff00000,d0  else return answer of 1.0
	    moveq   #0,d1
	    bra     donee1         place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
exp_11   move.l  d6,d0          restore top part of operand and continue
	 movea.l d0,a0          (a0,a1) <- x
	 movea.l d1,a1
	 move.l  #$3ff71547,d2  1/ln(2)
	 move.l  #$652b82fe,d3
	 bsr     rmul           (d0,d1) <- x * 1/ln(2)
	 bsr     rndnear        (d0,d1) <- xn (conversion to integer later)
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  Determine g.
*
	 move.l  #$bfe63000,d2  -0.543 octal = c1
	 moveq   #0,d3
	 bsr     rmul           xn*c1
	 move.l  a0,d2          (d2,d3) <- x
	 move.l  a1,d3          (a0,a1) is now freed
	 bsr     radd           x + xn*c1
	 movea.l d0,a0          (a0,a1) <- x + xn*c1
	 movea.l d1,a1
	 move.l  a2,d0          (d0,d1) <- xn
	 move.l  a3,d1
	 move.l  #$3f2bd010,d2  get c2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           (d0,d1) <- xn*c2
	 move.l  a0,d2          get previous intermediate result
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <- (x + xn*c1) + xn*c2
*
*  Compute z, p(z), and g*p(z), and q(z).
*
	 movea.l d0,a0          save away g
	 movea.l d1,a1
	 move.l  d0,d2          compute z = g*g
	 move.l  d1,d3
	 bsr     rmul           (d0,d1) <- z
	 movem.l d0-d1,-(sp)    save z away
*
	 movea.l d0,a4          compute p(z)
	 movea.l d1,a5
	 lea     cff_expp,a6    point to coefficients
	 moveq   #2,d0          degree of p
	 bsr     soft_horner    do the evaluation
	 move.l  a0,d2          restore g
	 move.l  a1,d3
	 bsr     rmul           g*p(z)
	 movea.l d0,a0          (a0,a1) <- g*p(z)
	 movea.l d1,a1
*
	 movem.l (sp)+,a4-a5    restore z
	 lea     cff_expq,a6    point to coefficients
	 moveq   #3,d0          degree of q
	 bsr     soft_horner    do the evaluation
*
*  Compute r(g).
*
	 move.l a0,d2           (d2,d3) <- g*p(z)
	 move.l a1,d3
	 bsr    rsbt            (d0,d1) <- q(z) - g*p(z)
	 move.l d0,d2           to be used as divisor
	 move.l d1,d3
	 move.l a0,d0           (d0,d1) <- g*p(z)
	 move.l a1,d1
	 bsr    rdvd            (d0,d1) <- g*p(z) / (q(z)-g*p(z))
	 move.l #$3fe00000,d2   add 1/2
	 moveq  #0,d3
	 bsr    radd            (d0,d1) <- r(g)
*
*  Compute integer value of xn, and finish computation.
*
	 movea.l d0,a0          save r(g)
	 movea.l d1,a1
	 move.l  a2,d0          retrieve xn
	 move.l  a3,d1
	 bsr     rellnt         32 bit integer (already been rounded)
	 addq.l  #1,d0          part of step 9 in the algorithm
	 move.l  d0,d7          augment with r to form result
	 move.l  a0,d0          (d0,d1) <- r(g)
	 move.l  a1,d1
	 bsr     adx            r and n form the result
*
*  Place result on the stack.
*
donee1   movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - exponent of the argument
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : cff_expp, cff_expq, flpt_horner, flpt_hornera,
*                    flpt_cardaddr, intxp, setxp, err_logerr
*
*******************************************************************************

flpt_ln  move.l  4(sp),d0
	 ble     err_logerr             branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 bsr     intxp                  extract exponent; operand in (d0,d1)
	 movea.w d7,a1                  place exponent temporarily into a1
	 clr.w   d7                     map number into range [0.5,1)
	 bsr     setxp                  compute value of f
	 move.w  a1,d7                  save exponent in d7
	 movea.l d0,a2                  save f in (a2,a3)
	 movea.l d1,a3
	 move.l  #$bfe00000,d2          combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 movem.l d0-d3,movf_m_f3(a0)    (f0,f1) <- -0.5;  (f2,f3) <- f
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- f - 0.5 = znum
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,d0          (d0,d1) <-  0.5
	 moveq   #0,d1
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a2          upper part of constant sqrt(1/2)
	 bgt.s   f@@stepp10
	 blt.s   f@@step9
	    cmpa.l  #$667f3bcd,a3
	    bhi.s   f@@stepp10
f@@step9        movem.l d0-d1,movf_m_f3(a0) (f2,f3) <- 0.5
	       tst.w   movl_f2_f4(a0)      (f4,f5) <- 0.5
	       movem.l bogus4(a0),d4-d5    wait for the chip to finish
	       tst.w   mull_f0_f2(a0)      (f2,f3) <- znum * 0.5
	       movem.l bogus4(a0),d4-d5
	       tst.w   addl_f4_f2(a0)      (f2,f3) <- znum * 0.5 + 0.5
	       movem.l bogus4(a0),d4-d5
	       subq.w  #1,d7               don't forget to adjust exponent!
	       bra.s   f@@step11            (f2,f3) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
f@@stepp10 movem.l d0-d1,movf_m_f3(a0)   first, subtract 0.5 from znum
	 tst.w   subl_f2_f0(a0)         (f0,f1) <- znum - 0.5
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 movem.l a2-a3,movf_m_f5(a0)    (f4,f5) <- f
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- f * 0.5
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f2(a0)         (f2,f3) <- 0.5 + f * 0.5
	 movem.l bogus4(a0),d4-d5
*
*   Step 11. Have (f0,f1) <- znum and (f2,f3) <- zden. First compute z and w.
*
f@@step11 tst.w   divl_f2_f0(a0)         (f0,f1) <- znum / zden = z
	 movem.l bogus4(a0),d4-d5
	 tst.w   movl_f0_f2(a0)         (f2,f3) <- z
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         (f2,f3) <- z * z = w
	 movem.l bogus4(a0),d4-d5
*
*  Evaluate A(w) and store the result in (a2,a3).
*
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- z  (untouched by horner(a))
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f3_m(a0),a4       (a4,a5) <- w
	 movea.l movf_f2_m(a0),a5
	 lea     cff_loga,a6            address of the coefficients
	 moveq   #2,d0                  degree of the polynomial
	 bsr     flpt_horner            do the polynomial evaluation
	 movea.l movf_f1_m(a0),a2       (a2,a3) <- A(w)
	 movea.l movf_f0_m(a0),a3
*
*  Evaluate B(w), with the result in (f0,f1).
*
	 lea     cff_logb,a6            address of the coefficients
	 moveq   #3,d0                  degree of the polynomial
	 bsr     flpt_hornera           remember, (a4,a5) still has w!
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)). Remember that (f6,f7) <- z,
*  (a4,a5) <- w, (a2,a3) <- A(w), and (f0,f1) <- B(w).
*
	 movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- A(w)
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 movem.l a4-a5,movf_m_f1(a0)    (f0,f1) <- w
	 tst.w   mull_f2_f0(a0)         (f0,f1) <- w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f0(a0)         (f0,f1) <- z*w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- z + z*w*A(w)*B(w) = R(z)
	 movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
	 ext.l   d7                     extend the exponent of the argument
	 move.l  d7,movil_m_f2(a0)      (f2,f3) <- xn
	 movem.l bogus4(a0),d4-d5
	 move.l  #$bf2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn * c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- xn * c2 + R(z)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe63000,movf_m_f5(a0) (f4,f5) <- c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f2(a0)         (f2,f3) <- xn * c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- xn*c2+R(z) + xn*c1
	 movem.l bogus4(a0),d4-d5
*
*  Place result on the stack and return.
*
	 move.l  movf_f1_m(a0),d0       retrieve the result
	 move.l  movf_f0_m(a0),d1
	 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)               get the result
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : radd, rmul, rdvd,
*                    soft_horner,soft_hornera, err_logerr
*                    intrel, intxp, setxp, adx, cff_loga, cff_logb
*
*******************************************************************************

soft_ln  move.l  4(sp),d0
	 ble     err_logerr     branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bsr     intxp          extract the exponent; operand in (d0,d1)
	 move.w  d7,-(sp)       place exponent into memory
	 clr.w   d7             map number into range [0.5,1)
	 bsr     setxp          compute value of f
	 movea.l d0,a0          save f in (a0,a1)
	 movea.l d1,a1
	 move.l  #$bfe00000,d2  combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 bsr     radd           znum <-- (d0,d1)
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a0  upper part of constant sqrt(1/2)
	 bgt.s   stepp10
	 blt.s   step9
	    cmpa.l  #$667f3bcd,a1
	    bhi.s   stepp10
step9          movea.l d0,a2          save away znum in (a2,a3)
	       movea.l d1,a3
	       moveq   #-1,d7         zden <-- znum * 0.5 + 0.5
	       bsr     adx            znum * 0.5
	       move.l  #$3fe00000,d2  add the 0.5
	       moveq   #0,d3
	       bsr     radd
	       subq.w  #1,(sp)        don't forget to adjust exponent!
	       bra.s   step11         (d0,d1) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
stepp10  move.l  #$bfe00000,d2  subtract 0.5
	 moveq   #0,d3
	 bsr     radd           znum correct, so now compute zden.
	 movea.l d0,a2          first, save znum away
	 movea.l d1,a3
	 moveq   #-1,d7         compute zden <-- f * 0.5 + 0.5
	 move.l  a0,d0
	 move.l  a1,d1
	 bsr     adx            f * 0.5
	 move.l  #$3fe00000,d2  add 0.5
	 moveq   #0,d3
	 bsr     radd           (d0,d1) contains zden; (a2,a3) has znum
*
*  Step 11. First compute z and w.
*
step11   move.l  d0,d2          place zden in correct registers for divide
	 move.l  d1,d3
	 move.l  a2,d0          z <-- znum / zden
	 move.l  a3,d1
	 bsr     rdvd
	 movea.l d0,a0          (a0,a1) <-- z
	 movea.l d1,a1
	 move.l  d0,d2          w <-- z * z
	 move.l  d1,d3
	 bsr     rmul
	 movea.l d0,a2          (a2,a3) <-- w
	 movea.l d1,a3
*
*  Evaluate A(w) and store the result on the stack.
*
	 movea.l d0,a4          place w in correct registers
	 movea.l d1,a5
	 lea     cff_loga,a6    address of the coefficients
	 moveq   #2,d0          degree of the polynomial
	 bsr     soft_horner    do the polynomial evaluation
	 movem.l d0-d1,-(sp)
*
*  Evaluate B(w) and leave result in (d0,d1).
*
	 movea.l a2,a4          place w in correct registers
	 movea.l a3,a5
	 lea     cff_logb,a6    address of the coefficients
	 moveq   #3,d0          degree of the polynomial
	 bsr     soft_hornera   do the polynomial evaluation
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)).
*
	 move.l  d0,d2          place B(w) in correct registers for divide
	 move.l  d1,d3
	 movem.l (sp)+,d0-d1    retrieve A(w)
	 bsr     rdvd           (d0,d1) <-- A(w)/B(w)
	 move.l  a2,d2          get w in (d2,d3)
	 move.l  a3,d3
	 bsr     rmul           (d0,d1) <-- w * A(w)/B(w)
	 move.l  a0,d2          place z in (d2,d3)
	 move.l  a1,d3
	 bsr     rmul           (d0,d1) <-- z * (w * A(w)/B(w))
	 move.l  a0,d2          (a0,a1) still has z
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <-- z + z * (w * A(w)/B(w))
	 movea.l d0,a0          (a0,a1) <-- R(z)
	 movea.l d1,a1
*
*  Finish the computation.
*
	 move.w  (sp)+,d0       get integer exponent
	 ext.l   d0
	 bsr     lntrel         convert exponent into a real
	 movea.l d0,a2          (a2,a3) <-- xn
	 movea.l d1,a3
	 move.l  #$bf2bd010,d2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           xn * c2
	 move.l  a0,d2          get R(z)
	 move.l  a1,d3
	 bsr     radd           xn * c2 + R(z)
	 movem.l d0-d1,-(sp)    save intermediate result
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3fe63000,d2
	 moveq   #0,d3
	 bsr     rmul           xn * c1
	 movem.l (sp)+,d2-d3    restore intermediate result
	 bsr     radd           (xn * c2 + R(z)) + (xn * c1)
*
*  Place result on the stack and return.
*
	 movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_sqrt
*
*       Description: Compute the square root of the numeric item on top
*                    of the stack. This algorithm is taken from the book
*                    "Software Manual for the Elementary Functions" by
*                    William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                  : 2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - original exponent of argument
*                    (f6,f7)    - f
*                    (f0,f1)    - partial results
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : intxp, setxp, adx, flpt_cardaddr, err_sqrterr
*
*******************************************************************************

flpt_sqrt move.l 8(sp),d1
	 move.l  4(sp),d0
	 bmi     errmaybe               branch if negative
	 bne.s   f@@sqrok                if non-zero, have positive number
	    rts                            else result = operand = 0
*
*  Continue with the square root.
*
f@@sqrok  lea     flpt_cardaddr,a0       point to the start of the hardware
	 bsr     intxp                  extract exponent
	 move.w  d7,d6                  save exponent
	 clr.w   d7                     new unbiased exponent
	 bsr     setxp                  (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movem.l d0-d1,movf_m_f7(a0)    f will be in (f7,f6) throughout
	 move.l  #$3fe2e297,movf_m_f1(a0) constant .59016
	 move.l  #$396d0918,movf_m_f0(a0) the rest of it
	 tst.w   mull_f6_f0(a0)         (f1,f0) <- .59016 * f
	 movem.l bogus4(a0),d4-d5       wait until the chip has finished
	 move.l  #$3fdab535,movf_m_f3(a0) constant .41731
	 move.l  #$0092ccf7,movf_m_f2(a0) the rest of it
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0
	 movem.l bogus4(a0),d4-d5
*
*  Compute z = (y0 + f/y0).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y0
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0 + f/y0 = z
	 movem.l bogus4(a0),d4-d5
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/z
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fd00000,movf_m_f5(a0) (f5,f4) <- .25
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f0(a0)         (f1,f0) <- .25*z
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/z + .25*z = y2
	 movem.l bogus4(a0),d4-d5
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/y2 + y2
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f3(a0) (f3,f2) <- .5
	 move.l  #0,movf_m_f2(a0)
	 tst.w   mull_f2_f0(a0)         (f1,f0) <- .5 * (y2 + f/y2)
	 movem.l bogus4(a0),d4-d5
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  d6,d7                  save the original exponent
	 asr.w   #1,d7                  the original exponent
	 bcc.s   f@@evenexp              branch if the exponent was even
	    move.l  #$3fe6a09e,movf_m_f3(a0) (f3,f2) <- sqrt(1/2)
	    move.l  #$667f3bcd,movf_m_f2(a0)
	    tst.w   mull_f2_f0(a0)         (f1,f0) <- (f1,f0) * sqrt(1/2)
	    movem.l bogus4(a0),d4-d5
	    addq.w  #1,d6                  (n+1) / 2 --> m
f@@evenexp asr.w  #1,d6                  adjust the old exponent
	 move.l  movf_f1_m(a0),d0       retrieve the last partial result
	 move.l  movf_f0_m(a0),d1
	 move.w  d6,d7                  place here for the adx
	 bsr     adx                    put in the result exponent
*
* Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
*
*  Negative number, so check for sqrt(-0).
*
errmaybe cmp.l   #minuszero,d0          first, check for a -0
	 bne     err_sqrterr
	    rts                            else return with -0 as the result
	 page
*******************************************************************************
*
*       Procedure  : soft_sqrt
*
*       Description: Compute the square root of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : radd, rmul, rdvd, intxp, setxp, adx, err_sqrterr
*
*******************************************************************************

soft_sqrt move.l 8(sp),d1
	 move.l 4(sp),d0
	 bmi.s   errmaybe       branch if negative
	 bne.s   sqrok          if non-zero, have positive number
	    rts                    else result = operand = 0
*
*  Continue with the square root.
*
sqrok    bsr     intxp          extract exponent
	 movea.w d7,a4          save exponent
	 clr.w   d7             new unbiased exponent
	 bsr     setxp          (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movea.l d0,a0          (a0,a1) <-- f
	 movea.l d1,a1
	 move.l  #$3fe2e297,d2  constant 0.59016
	 move.l  #$396d0918,d3
	 bsr     rmul           (d0,d1) contains first term
	 move.l  #$3fdab535,d2  constant 0.41731
	 move.l  #$0092ccf7,d3
	 bsr     radd           (d0,d1) has initial guess for y
	 movea.l d0,a2          (a2,a3) <-- y
	 movea.l d1,a3
*
*  Compute z = (y0 + f/y0).
*
	 move.l  d0,d2          (d2,d3) <-- y0
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <-- f
	 move.l  a1,d1
	 bsr     rdvd           f/y0
	 move.l  a2,d2          (d2,d3) <-- y0
	 move.l  a3,d3
	 bsr     radd           (d0,d1) <-- z = y0 + f/y0
	 movea.l d0,a2          (a2,a3) <- z
	 movea.l d1,a3
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 move.l  d0,d2          (d2,d3) <- z
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <- f
	 move.l  a1,d1
	 bsr     rdvd           f/z
	 move.l  d0,d2          (d2,d3) <- f/z
	 move.l  d1,d3
	 move.l  a2,d0          (d0,d1) <- z
	 move.l  a3,d1
	 moveq   #-2,d7         'adx' does not affect (d2,d3) = f/z
	 bsr     adx            .25*x
	 bsr     radd           y2 <-- .25*x + f/z
	 movea.l d0,a2          (a2,a3) <- y2
	 movea.l d1,a3
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 move.l  d0,d2          place y2 in divisor registers
	 move.l  d1,d3
	 move.l  a0,d0          load up the value of f; y is in (d0,d1)
	 move.l  a1,d1
	 bsr     rdvd           f/y computed; result in (d0,d1)
	 move.l  a2,d2          get y2
	 move.l  a3,d3
	 bsr     radd           y2 + f/y2 computed; result in (d0,d1)
	 moveq   #-1,d7
	 bsr     adx            y = y3 <- 0.5 * (y2 + f/y2)
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  a4,d7          get the initial exponent guess
	 asr.w   #1,d7          see if even or odd
	 bcc.s   evenexp        branch if even exponent
	    move.l  #$3fe6a09e,d2  else adjust mantissa accordingly
	    move.l  #$667f3bcd,d3  constant sqrt(1/2)
	    bsr     rmul           y <- y * sqrt(1/2)
	    move.w  a4,d7          get old exponent
	    addq.w  #1,d7          adjust it
	    asr.w   #1,d7          (n + 1) / 2  --> m
evenexp  bsr     adx            d7 has result exponent; (d0,d1) the rest
*
*  Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - n
*                    d6         - sign of the argument
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large returns an error.
*
*       References : flpt_horner, flpt_hornera, compare, cff_atnp, cff_atnq,
*                    flpt_cardaddr
*
*******************************************************************************

flpt_arctan move.l 4(sp),d0             get the argument
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       must save all the fp registers
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 move.l  d0,d6                  save the sign
	 cmp.l   #minuszero,d6          check if a -0
	 bne.s   act@@1                  branch if not a -0
	    moveq   #0,d6                  set the sign to +
act@@1    bclr    #31,d0                 f <- abs(x)
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- f
*
*  Adjust f if > 1. Note that underflow is possible if x is real large.
*  If underflowed, then the argument was real large, so return pi/2 as
*  the angle.
*
	 move.l  #$3ff00000,d2          floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   f@@invertf              branch if have to invert f
	    moveq   #0,d7                  else set n to 0
	    bra.s   f@@step7                and continue with the computation
f@@invertf movem.l d2-d3,movf_m_f3(a0)   (f2,f3) <- 1
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- 1/f
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 btst    #q,status(a0)          see if had an underflow
	 beq     f@@arc34                branch if no underflow
	    move.l  #$3ff921fb,d0          top part of pi/2
	    move.l  #$54442d18,d1          rest of result of pi/2
	    tst.l   d6                     check sign of original operand
	    bpl     f@@donee                pos arguement yields positive result
	       bset   #31,d0                  if negative, result is negative
	       bra     f@@donee                place result on stack and return
f@@arc34  tst.w   movl_f2_f0(a0)         no error, so (f0,f1) <- f = 1/f
	 movem.l bogus4(a0),d4-d5
	 moveq   #2,d7                  n <- 2
*
*  Adjust f if > 2 - sqrt(3).
*
f@@step7  move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  #$3fd12614,d2          2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   f@@steep10              branch if no more adjusting of f or n
	    addq.w  #1,d7                  step 8; first adjust n
	    move.l  #$3ffbb67a,movf_m_f3(a0) (f2,f3) <- sqrt(3)
	    move.l  #$e8584caa,movf_m_f2(a0)
	    tst.w   addl_f0_f2(a0)         (f2,f3) <- f + sqrt(3)
	    movem.l bogus4(a0),d4-d5
	    move.l  #$3fe76cf5,movf_m_f5(a0) (f4,f5) <-  sqrt(3) - 1 = a
	    move.l  #$d0b09955,movf_m_f4(a0)
	    tst.w   mull_f0_f4(a0)         (f4,f5) <- a*f
	    movem.l bogus4(a0),d4-d5
	    move.l  #$bfe00000,movf_m_f7(a0) (f6,f7) <-  -1/2
	    move.l  #0,movf_m_f6(a0)
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- a*f - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- (a*f - 1/2) - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f4_f0(a0)         (f0,f1) <- ((a*f - 1/2) - 1/2) + f
	    movem.l bogus4(a0),d4-d5
	    tst.w   divl_f2_f0(a0)         (f0,f1) <- (f0,f1)/denominator = f
	    movem.l bogus4(a0),d4-d5
*
*  Evaluate the polynomials if required. (f0,f1) <- f.
*
f@@steep10  tst.w movl_f0_f6(a0)         result must be in (f6,f7) for later
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare                is abs(f) < eps?
	 blt     f@@step15
	    tst.w   movl_f0_f2(a0)         (f2,f3) <- f
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f2_f2(a0)         (f2,f3) <- f*f = g
	    movem.l bogus4(a0),d4-d5
	    movea.l movf_f3_m(a0),a4       (a4,a5) <- g
	    movea.l movf_f2_m(a0),a5
	    moveq   #3,d0                  degree of the polynomial
	    lea     cff_atnp,a6            point to the coefficients
	    tst.w   movl_f0_f6(a0)         (f6,f7)<- f (untouched by horner(a))
	    movem.l bogus4(a0),d4-d5
	    bsr     flpt_horner            compute pg; result in (f0,f1)
	    movem.l a4-a5,movf_m_f3(a0)    (f2,f3) <- g
	    tst.w   mull_f0_f2(a0)         (f2,f3) <- g * p(g)
	    movem.l bogus4(a0),d4-d5
	    moveq   #4,d0                  degree for the next polynomial
	    lea     cff_atnq,a6
	    movea.l movf_f3_m(a0),a2       (a2,a3) <- g * p(g)
	    movea.l movf_f2_m(a0),a3
	    bsr     flpt_hornera           compute q(g); result in (f0,f1)
	    movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- g * p(g)
	    tst.w   divl_f0_f2(a0)         (f2,f3) <- g * p(g) / q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f6_f2(a0)         (f2,f3) <- f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f2_f6(a0)         result= (f6,f7) <- f + f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
f@@step15 tst.w   d7                     check n
	 beq.s   f@@checksgn             fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   f@@val23                branch if adjustment to result
	       move.l  #$3fe0c152,movf_m_f3(a0)  (f2,f3) <- a(1) = pi/6
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/6
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val23     tst.w  negl_f6_f6(a0)       else result <- -result
	    movem.l bogus4(a0),d4-d5
	    cmp.w   #2,d7               check n for either a 2 or 3
	    beq.s   f@@val2              branch if equal to 2
	       move.l  #$3ff0c152,movf_m_f3(a0)  (f2,f3) <- a(3) = pi/3
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/3
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val2      move.l  #$3ff921fb,movf_m_f3(a0)  (f2,f3) <- a(2) = pi/2
	    move.l  #$54442d18,movf_m_f2(a0)
	    tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/2
	    movem.l bogus4(a0),d4-d5
*
f@@checksgn move.l movf_f7_m(a0),d0      (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
	 tst.l   d6                     check sign of original argument
	 bpl.s   f@@donee
	    bchg    #31,d0                 negate sign of result
*
*  Place result on the stack and return.
*
f@@donee  movem.l  (sp)+,a5-a6           restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : None
*
*       References : radd, rmul, rdvd, soft_horner, soft_hornera, compare,
*                    cff_atnp, cff_atnq
*
*******************************************************************************

soft_arctan move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)    save dedicated registers
	 swap    d0             save the sign
	 move.w  d0,-(sp)
	 swap    d0             restore correct order of the operand
	 cmpi.l  #minuszero,d0  check for a -0
	 bne.s   sftat@@1        branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sftat@@1  bclr    #31,d0         f <- abs(x)
*
*  Adjust f if > 1. Underflow is possible here if f is real large.
*
	 move.l  #$3ff00000,d2  floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   invertf        branch if have to invert f
	    clr.w   -(sp)          else set n to 0
	    bra.s   step7          and continue with the computation
invertf  exg     d0,d2          place 1 as the dividend, and
	 exg     d1,d3          f as the divisor
	    move.l  sysglobals-10(a5),-(sp)  TRY, could get real underflow
	    pea     recoverr       address for the RECOVER
	    move.l  sp,sysglobals-10(a5)     new TRY block
	    bsr     rdvd           reciprocate the argument
	    addq.l  #4,sp          pop off the error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 move.w  #2,-(sp)       n <- 2
*
*  Save value of n. Adjust f if > 2 - sqrt(3).
*
step7    move.l  #$3fd12614,d2  2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   steep10         branch if no more adjusting of f or n required
	    addq.w  #1,(sp)        step 8; first adjust n
	    movea.l d0,a0          (a0,a1) <- f
	    movea.l d1,a1
	    move.l  #$3ffbb67a,d2  sqrt(3)
	    move.l  #$e8584caa,d3
	    bsr     radd           f + sqrt(3)
	    movea.l d0,a2          save denominator for now
	    movea.l d1,a3
	    move.l  #$3fe76cf5,d0  a = sqrt(3) - 1
	    move.l  #$d0b09955,d1
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           a * f
	    move.l  #$bfe00000,d2  -1/2
	    movea.l d2,a4          save for next radd
	    moveq   #0,d3
	    bsr     radd           a * f - 1/2
	    move.l  a4,d2          -1/2
	    moveq   #0,d3
	    bsr     radd           (a * f - 1/2) - 1/2
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           ( (a * f - 1/2) - 1/2) + f
	    move.l  a2,d2          restore f + sqrt(3)
	    move.l  a3,d3
	    bsr     rdvd           new f
*
*  Evaluate the polynomials if required.
*
steep10  movea.l d0,a0          save the sign of f
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare        is abs(f) < eps?
	 blt.s   step12a
	    move.l  a0,d0          restore sign of f
	    movea.l d1,a1          (a0,a1) <- f
	    move.l  d0,d2
	    move.l  d1,d3
	    bsr     rmul           g <- f * f
	    movea.l d0,a4          (a4,a5) <- g
	    movea.l d1,a5
	    moveq   #3,d0          degree of the polynomial
	    lea     cff_atnp,a6    point to the coefficients
	    bsr     soft_horner
	    move.l  a4,d2          get g
	    move.l  a5,d3
	    bsr     rmul           g * p(g)
	    movea.l d0,a2          (a2,a3) <- g * p(g)
	    movea.l d1,a3
	    moveq   #4,d0          degree for the next polynomial
	    lea     cff_atnq,a6
	    bsr     soft_hornera   q(g)
	    move.l  d0,d2          divisor
	    move.l  d1,d3
	    move.l  a2,d0          dividend
	    move.l  a3,d1
	    bsr     rdvd           g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           f * g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           result <- f + f*g*p(g)/q(g)
	    bra.s   step15
step12a  move.l  a0,d0          f is the result
*
*  Finish the computation.
*
step15   move.w  (sp)+,d7       retrieve n
	 beq.s   checksgn       fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   val23          branch if adjustment to result necesary
	       move.l  #$3fe0c152,d2  a(1) = pi/6
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val23       bchg   #31,d0          else result <- -result
	    cmp.w   #2,d7          check n for either a 2 or 3
	    beq.s   val2           branch if equal to 2
	       move.l  #$3ff0c152,d2  a(3) = pi/3
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val2        move.l  #$3ff921fb,d2  a(2) = pi/2
	    move.l  #$54442d18,d3
	    bsr     radd
*
checksgn tst.w   (sp)+          check sign of original argument
	 bpl.s   donee
	    bchg    #31,d0         negate sign of result
*
*  Place result on the stack and return.
*
donee    movem.l  (sp)+,a5-a6   restore dedicated registers
	 move.l   d0,4(sp)
	 move.l   d1,8(sp)
	 rts
*
*  Argument was too large. Return pi/2 as the result.
*
recoverr move.l  (sp)+,sysglobals-10(a5)  restore TRY block
	 move.l  #$3ff921fb,d0  else underflowed, so get top part of pi/2
	 move.l  #$54442d18,d1  rest of result of pi/2
	 tst.w   (sp)+          check sign of original operand
	 bpl     donee          positive argument yields positive result
	    bset   #31,d0          if negative, result is negative
	    bra     donee          place result on stack and return
	page
*******************************************************************************
*
*       Procedures : Assorted
*
*       Description: The rest of the procedures are a collection of
*                    utility interface routines for the compiler.
*                    See the text of the procedures for information
*                    concerning them.
*
*       Author     : Brad Ritter
*
*       Revisions  : 1.0  06/01/81
*
*******************************************************************************

asm_bcdround equ *
	movea.l (sp)+,a0        return address
	movea.l (sp)+,a1        address of string
	move.w  (sp)+,d0        number of digits
	movea.l (sp)+,a2        address of bcd_strtype
	addq.l  #3,a1           point to s[3]
	movea.l a1,a3           save address of s[3]
	addq.l  #2,a2           point to first bcd digit
*
*  Move the digits to s[3..17]
*
	moveq   #8,d1           count
bcdr1   move.b  (a2)+,d3
	move.b  d3,d4
	andi.b  #$F,d4
	andi.b  #$F0,d3
	lsr.b   #4,d3
	move.b  d3,(a1)+
	move.b  d4,(a1)+
	subq.b  #1,d1
	bgt.s   bcdr1
*
*  Round to proper number of digits
*
	lea     0(a3,d0.w),a1   address off digit to round
	addq.b  #5,(a1)
bcdr2   cmpi.b  #10,(a1)
	blt.s   bcdr5
	subi.b  #10,(a1)
	cmpa.l  a1,a3
	beq.s   bcdr3           all done but final carry
	subq.l  #1,a1
	addq.b  #1,(a1)
	bra.s   bcdr2
*
bcdr3   move.b  #49,(a3)+       '1'
	subq.b  #1,d0
bcdr4   move.b  #48,(a3)+       '0'
	subi.b  #1,d0
	bge.s   bcdr4           add 1 extra 0
*
*  Increment exponent by 1
*
	addq.w  #1,(a2)
	jmp     (a0)
*
*  Convert to characters
*
bcdr5   addi.b  #48,(a3)+
	subi.b  #1,d0
	bgt.s   bcdr5
	jmp     (a0)


asm_pack movea.l (sp)+,a0       return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a1        destination
	movea.l (sp)+,a2        source
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   pack
	movea.l d5,a1
	move.w  #8,d4

pack    cmpi.w  #2,d2           unpacksize = word ?
	bne.s   pack1
	move.w  (a2)+,d3
	bra.s   pack3

pack1   cmpi.w  #1,d2           unpacksize = byte ?
	bne.s   pack2
	move.b  (a2)+,d3
	bra.s   pack3

pack2   move.l  (a2)+,d3        unpacksize = long

pack3   move.w  d4,d5           bit index
	subi.w  #32,d5
	add.w   d1,d5
	neg.w   d5              #32 - offset - width

	cmpi.w  #16,d1          fieldwidth = 16 ?
	bne.s   pack4
	move.l  #65535,d6
	bra.s   pack8

pack4   cmpi.w  #8,d1           fieldwidth = 8 ?
	bne.s   pack5
	move.l  #255,d6
	bra.s   pack8

pack5   cmpi.w  #4,d1           fieldwidth = 4 ?
	bne.s   pack6
	moveq   #15,d6
	bra.s   pack8

pack6   cmpi.w  #2,d1           fieldwidth = 2 ?
	bne.s   pack7
	move.l  #3,d6
	bra.s   pack8

pack7   moveq   #1,d6           fieldwidth = 1

pack8   lsl.l   d5,d6           position mask
	lsl.l   d5,d3           position source
	and.l   d6,d3           mask off source
	not.l   d6
	and.l   d6,(a1)         clr dest field
	or.l    d3,(a1)         store source in dest
	add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   pack9
	subi.w  #16,d4
	addq.l  #2,a1
pack9   subq.l  #1,d0
	bne.s   pack
	jmp     (a0)

asm_unpack movea.l (sp)+,a0     return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a2        source
	movea.l (sp)+,a1        destination
	move.b  (sp)+,d3        signed fields ?
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   unpack
	movea.l d5,a1
	move.w  #8,d4

unpack  move.l  (a2),d5
	lsl.l   d4,d5           left justify field
	move.w  d1,d6
	subi.w  #32,d6
	neg.w   d6              32 - fieldwidth
	tst.b   d3
	bne.s   unpack1
	lsr.l   d6,d5           right justify unsigned
	bra.s   unpack2
unpack1 asr.l   d6,d5           right justify signed

unpack2 add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   unpack3
	subi.w  #16,d4
	addq.l  #2,a2

unpack3 cmpi.w  #2,d2           unpacksize = 2 ?
	bne.s   unpack4
	move.w  d5,(a1)+
	bra.s   unpack6

unpack4 cmpi.w  #1,d2           unpacksize =1 ?
	bne.s   unpack5
	move.b  d5,(a1)+
	bra.s   unpack6

unpack5 move.l  d5,(a1)+

unpack6 subq.l  #1,d0
	bne.s   unpack
	jmp     (a0)

asm_hex movea.l 4(sp),a0        address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
h@@x1    clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   h@@x2
	subq.b  #1,d2
	bgt.s   h@@x1
	bra.s   error           {sb}
h@@x5    clr.l   d1
	move.b  (a0)+,d1
h@@x2    subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #9,d1
	ble.s   h@@x3
	subi.w  #17,d1          ord('A') = 65   {sb}
	blt.s   error
	cmpi.w  #5,d1           {sb}
	ble.s   h@@x6            {sb}
	subi.w  #32,d1          ord('a') = 97
	blt.s   error
	cmpi.w  #5,d1           {sb}
	bgt.s   error
h@@x6    addi.w  #10,d1          {sb}
h@@x3    move.l  d0,d3
	andi.l  #$F0000000,d3
	bne.s   error
	asl.l   #4,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   h@@x5
h@@x4    move.l  d0,4(sp)
	rts

tstblk  addi.w #48,d1
tstblk0 cmpi.b #32,d1           test for trailing blanks
	bne.s  error
	subq.b #1,d2
	ble.s  h@@x4
	move.b (a0)+,d1
	bra.s  tstblk0

error   move.w  #-8,sysglobals-2(a5)
	trap    #10             value range error

asm_octal movea.l 4(sp),a0      address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
oct@@l1  clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   oct@@l2
	subq.b  #1,d2
	bgt.s   oct@@l1
	bra.s   error           {sb}
oct@@l5  clr.l   d1
	move.b  (a0)+,d1
oct@@l2  subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #7,d1
	bgt.s   error
	move.l  d0,d3
	andi.l  #$E0000000,d3
	bne.s   error
	asl.l   #3,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   oct@@l5
oct@@l4  move.l  d0,4(sp)
	rts

asm_binary movea.l 4(sp),a0     address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
bin@@ry1 clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   bin@@ry2
	subq.b  #1,d2
	bgt.s   bin@@ry1
	bra.s   error           {sb}
bin@@ry5 clr.l   d1
	move.b  (a0)+,d1
bin@@ry2 subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #1,d1
	bgt.s   error
	asl.l   #1,d0
	bcs.s   error
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   bin@@ry5
bin@@ry4 move.l  d0,4(sp)
	rts

asm_addsetrange equ *
*************************************************
*       d3, d4, a4 are not used by addelement   *
*************************************************
	movea.l (sp)+,a4        return address
	move.w  (sp)+,d3        hivalue
	move.w  (sp)+,d4        lovalue
	cmp.w   d3,d4
	ble.s   e@@add
	move.l  (sp)+,(sp)
e@@end   jmp     (a4)
e@@add   ext.l   d4
	move.l  d4,-(sp)
	jsr     asm_adelement
	addq.w  #1,d4
	cmp.w   d3,d4
	bgt     e@@end
	move.l  (sp),-(sp)
	bra.s   e@@add

***********************************************************************

retfalse clr.b  -(sp)           false
	jmp     (a0)
rettrue move.b  #1,-(sp)        true
	jmp     (a0)

***********************************************************************

asm_eq  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	beq     rettrue
	bra     retfalse

asm_ne  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bne     rettrue
	bra     retfalse

asm_lt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	blt     rettrue
	bra     retfalse

asm_le  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	ble     rettrue
	bra     retfalse

asm_gt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bgt     rettrue
	bra     retfalse

asm_ge  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bge     rettrue
	bra     retfalse
	page
****************************************************************************
*
*  Code for all the math errors.
*
err_intover  trap    #4
err_divzero  move.w  #esc_flpt_divzer,sysglobals-2(a5)
	     trap    #10
err_overflow move.w  #esc_flpt_over,sysglobals-2(a5)
	     trap    #10
err_underflow move.w #esc_flpt_under,sysglobals-2(a5)
	     trap    #10
err_trigerr  move.w  #esc_flpt_sincos,sysglobals-2(a5)
	     trap    #10
err_logerr   move.w  #esc_flpt_natlog,sysglobals-2(a5)
	     trap    #10
err_sqrterr  move.w  #esc_flpt_sqrt,sysglobals-2(a5)
	     trap    #10
err_illnumbr move.w  #esc_flpt_relbcd,sysglobals-2(a5)
	     trap    #10
err_impvalue move.w  #esc_flpt_bcdrel,sysglobals-2(a5)
	     trap    #10
err_miscel   move.w  #esc_flpt_misc,sysglobals-2(a5)
	     trap    #10
	     end

@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 5113
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 5113
*
*  FILE:        allreals
*
*  This file contains the math routines for the Pascal Workstation.
*  Major modifications for the 98635A card (hardware floating point) were
*  done by Paul Beiser   March 25, 1984.
*
	sprint
	nosyms
	refa    sysglobals
	refa    asm_adelement,fltpthdw
	lmode   asm_adelement,fltpthdw
	rorg    0

****************************************************************************
*
*  The following are the addresses of the coefficients used in the evaluation
*  of transcendental functions.
*
cff_loga        equ     $3c26           LOG coefficients
cff_logb        equ     $3c3e
cff_expp        equ     $3c56           EXP coefficients
cff_expq        equ     $3c6e
cff_sin         equ     $3c8e           SIN/COS coefficients
cff_atnp        equ     $3d66           ATN coefficients
cff_atnq        equ     $3d86
*
*  The following are address of tables used in the BCD <-> real conversions
*  and in the evaluation of x^y.
*
tb_pwt          equ     $3658           BCD <-> real tables
tb_pwt8         equ     $3698
tb_pwt4         equ     $36b8
tb_pwtt         equ     $36d8
tb_auxpt        equ     $3ae0
tb_bcd          equ     $3b28
tb_bin          equ     $3bc2
*
*  Pascal Workstation Escapecodes
*
esc_flpt_divzer equ     -5              divide by zero
esc_flpt_over   equ     -6              overflow
esc_flpt_under  equ     -7              underflow
esc_flpt_sincos equ     -15             bad argument - sine/cosine
esc_flpt_natlog equ     -16             bad argument - natural log
esc_flpt_sqrt   equ     -17             bad argument - square root
esc_flpt_relbcd equ     -18             bad argument - real/BCD conversion
esc_flpt_bcdrel equ     -19             bad argument - BCD/real conversion
esc_flpt_misc   equ     -29             misc floating point error


****************************************************************************
*
* The following are some constants that relate to the floating point card.
*
status          equ     $21             offset of the FPU protocol status byte
q               equ     3               bit postion for the q bit in <status>
bogus4          equ     $18             offset to do 4 bogus word reads
bogus4s         equ     $16             offset for 6 word reads: 4 bogus and 2
*                                         to get the status word at <status>
minuszero       equ     $80000000       top 32 bits of the real value -0

flpt_cardaddr   equ     $5c0000         address of floating pt card
flpt_id         equ     $1              offset of the ID byte/write reset
flpt_initmask   equ     $00000008       UEN flag set; RM to nearest
flpt_extracttrap equ    $00000007       mask for extracting the exception type
flpt_card_id    equ     $0a             float card ID byte SFB
*
*  Values returned by the 16081 FPU if an error occurred.
*
flpt_under      equ     1               floating point underflow
flpt_over       equ     2               floating point overflow
flpt_divzero    equ     3               floating point divide-by-zero
flpt_illegal    equ     4               illegal floating point instruction
flpt_invalid    equ     5               invalid floating point operation
flpt_inexact    equ     6               inexact floating point result
flpt_notdoc     equ     7               not furnished by National
*
*  Offsets from "flpt_cardaddr" for the operations to the floating point card.
*
addl_f0_f0      equ     $4000
addl_f0_f2      equ     $4002
addl_f0_f4      equ     $4004
addl_f0_f6      equ     $4006
addl_f2_f0      equ     $4008
addl_f2_f2      equ     $400a
addl_f2_f4      equ     $400c
addl_f2_f6      equ     $400e
addl_f4_f0      equ     $4010
addl_f4_f2      equ     $4012
addl_f4_f4      equ     $4014
addl_f4_f6      equ     $4016
addl_f6_f0      equ     $4018
addl_f6_f2      equ     $401a
addl_f6_f4      equ     $401c
addl_f6_f6      equ     $401e
subl_f0_f0      equ     $4020
subl_f0_f2      equ     $4022
subl_f0_f4      equ     $4024
subl_f0_f6      equ     $4026
subl_f2_f0      equ     $4028
subl_f2_f2      equ     $402a
subl_f2_f4      equ     $402c
subl_f2_f6      equ     $402e
subl_f4_f0      equ     $4030
subl_f4_f2      equ     $4032
subl_f4_f4      equ     $4034
subl_f4_f6      equ     $4036
subl_f6_f0      equ     $4038
subl_f6_f2      equ     $403a
subl_f6_f4      equ     $403c
subl_f6_f6      equ     $403e
mull_f0_f0      equ     $4040
mull_f0_f2      equ     $4042
mull_f0_f4      equ     $4044
mull_f0_f6      equ     $4046
mull_f2_f0      equ     $4048
mull_f2_f2      equ     $404a
mull_f2_f4      equ     $404c
mull_f2_f6      equ     $404e
mull_f4_f0      equ     $4050
mull_f4_f2      equ     $4052
mull_f4_f4      equ     $4054
mull_f4_f6      equ     $4056
mull_f6_f0      equ     $4058
mull_f6_f2      equ     $405a
mull_f6_f4      equ     $405c
mull_f6_f6      equ     $405e
divl_f0_f0      equ     $4060
divl_f0_f2      equ     $4062
divl_f0_f4      equ     $4064
divl_f0_f6      equ     $4066
divl_f2_f0      equ     $4068
divl_f2_f2      equ     $406a
divl_f2_f4      equ     $406c
divl_f2_f6      equ     $406e
divl_f4_f0      equ     $4070
divl_f4_f2      equ     $4072
divl_f4_f4      equ     $4074
divl_f4_f6      equ     $4076
divl_f6_f0      equ     $4078
divl_f6_f2      equ     $407a
divl_f6_f4      equ     $407c
divl_f6_f6      equ     $407e
negl_f0_f0      equ     $4080
negl_f0_f2      equ     $4082
negl_f0_f4      equ     $4084
negl_f0_f6      equ     $4086
negl_f2_f0      equ     $4088
negl_f2_f2      equ     $408a
negl_f2_f4      equ     $408c
negl_f2_f6      equ     $408e
negl_f4_f0      equ     $4090
negl_f4_f2      equ     $4092
negl_f4_f4      equ     $4094
negl_f4_f6      equ     $4096
negl_f6_f0      equ     $4098
negl_f6_f2      equ     $409a
negl_f6_f4      equ     $409c
negl_f6_f6      equ     $409e
absl_f0_f0      equ     $40a0
absl_f0_f2      equ     $40a2
absl_f0_f4      equ     $40a4
absl_f0_f6      equ     $40a6
absl_f2_f0      equ     $40a8
absl_f2_f2      equ     $40aa
absl_f2_f4      equ     $40ac
absl_f2_f6      equ     $40ae
absl_f4_f0      equ     $40b0
absl_f4_f2      equ     $40b2
absl_f4_f4      equ     $40b4
absl_f4_f6      equ     $40b6
absl_f6_f0      equ     $40b8
absl_f6_f2      equ     $40ba
absl_f6_f4      equ     $40bc
absl_f6_f6      equ     $40be
addf_f0_f0      equ     $40c0
addf_f0_f1      equ     $40c2
addf_f0_f2      equ     $40c4
addf_f0_f3      equ     $40c6
addf_f0_f4      equ     $40c8
addf_f0_f5      equ     $40ca
addf_f0_f6      equ     $40cc
addf_f0_f7      equ     $40ce
addf_f1_f0      equ     $40d0
addf_f1_f1      equ     $40d2
addf_f1_f2      equ     $40d4
addf_f1_f3      equ     $40d6
addf_f1_f4      equ     $40d8
addf_f1_f5      equ     $40da
addf_f1_f6      equ     $40dc
addf_f1_f7      equ     $40de
addf_f2_f0      equ     $40e0
addf_f2_f1      equ     $40e2
addf_f2_f2      equ     $40e4
addf_f2_f3      equ     $40e6
addf_f2_f4      equ     $40e8
addf_f2_f5      equ     $40ea
addf_f2_f6      equ     $40ec
addf_f2_f7      equ     $40ee
addf_f3_f0      equ     $40f0
addf_f3_f1      equ     $40f2
addf_f3_f2      equ     $40f4
addf_f3_f3      equ     $40f6
addf_f3_f4      equ     $40f8
addf_f3_f5      equ     $40fa
addf_f3_f6      equ     $40fc
addf_f3_f7      equ     $40fe
addf_f4_f0      equ     $4100
addf_f4_f1      equ     $4102
addf_f4_f2      equ     $4104
addf_f4_f3      equ     $4106
addf_f4_f4      equ     $4108
addf_f4_f5      equ     $410a
addf_f4_f6      equ     $410c
addf_f4_f7      equ     $410e
addf_f5_f0      equ     $4110
addf_f5_f1      equ     $4112
addf_f5_f2      equ     $4114
addf_f5_f3      equ     $4116
addf_f5_f4      equ     $4118
addf_f5_f5      equ     $411a
addf_f5_f6      equ     $411c
addf_f5_f7      equ     $411e
addf_f6_f0      equ     $4120
addf_f6_f1      equ     $4122
addf_f6_f2      equ     $4124
addf_f6_f3      equ     $4126
addf_f6_f4      equ     $4128
addf_f6_f5      equ     $412a
addf_f6_f6      equ     $412c
addf_f6_f7      equ     $412e
addf_f7_f0      equ     $4130
addf_f7_f1      equ     $4132
addf_f7_f2      equ     $4134
addf_f7_f3      equ     $4136
addf_f7_f4      equ     $4138
addf_f7_f5      equ     $413a
addf_f7_f6      equ     $413c
addf_f7_f7      equ     $413e
subf_f0_f0      equ     $4140
subf_f0_f1      equ     $4142
subf_f0_f2      equ     $4144
subf_f0_f3      equ     $4146
subf_f0_f4      equ     $4148
subf_f0_f5      equ     $414a
subf_f0_f6      equ     $414c
subf_f0_f7      equ     $414e
subf_f1_f0      equ     $4150
subf_f1_f1      equ     $4152
subf_f1_f2      equ     $4154
subf_f1_f3      equ     $4156
subf_f1_f4      equ     $4158
subf_f1_f5      equ     $415a
subf_f1_f6      equ     $415c
subf_f1_f7      equ     $415e
subf_f2_f0      equ     $4160
subf_f2_f1      equ     $4162
subf_f2_f2      equ     $4164
subf_f2_f3      equ     $4166
subf_f2_f4      equ     $4168
subf_f2_f5      equ     $416a
subf_f2_f6      equ     $416c
subf_f2_f7      equ     $416e
subf_f3_f0      equ     $4170
subf_f3_f1      equ     $4172
subf_f3_f2      equ     $4174
subf_f3_f3      equ     $4176
subf_f3_f4      equ     $4178
subf_f3_f5      equ     $417a
subf_f3_f6      equ     $417c
subf_f3_f7      equ     $417e
subf_f4_f0      equ     $4180
subf_f4_f1      equ     $4182
subf_f4_f2      equ     $4184
subf_f4_f3      equ     $4186
subf_f4_f4      equ     $4188
subf_f4_f5      equ     $418a
subf_f4_f6      equ     $418c
subf_f4_f7      equ     $418e
subf_f5_f0      equ     $4190
subf_f5_f1      equ     $4192
subf_f5_f2      equ     $4194
subf_f5_f3      equ     $4196
subf_f5_f4      equ     $4198
subf_f5_f5      equ     $419a
subf_f5_f6      equ     $419c
subf_f5_f7      equ     $419e
subf_f6_f0      equ     $41a0
subf_f6_f1      equ     $41a2
subf_f6_f2      equ     $41a4
subf_f6_f3      equ     $41a6
subf_f6_f4      equ     $41a8
subf_f6_f5      equ     $41aa
subf_f6_f6      equ     $41ac
subf_f6_f7      equ     $41ae
subf_f7_f0      equ     $41b0
subf_f7_f1      equ     $41b2
subf_f7_f2      equ     $41b4
subf_f7_f3      equ     $41b6
subf_f7_f4      equ     $41b8
subf_f7_f5      equ     $41ba
subf_f7_f6      equ     $41bc
subf_f7_f7      equ     $41be
mulf_f0_f0      equ     $41c0
mulf_f0_f1      equ     $41c2
mulf_f0_f2      equ     $41c4
mulf_f0_f3      equ     $41c6
mulf_f0_f4      equ     $41c8
mulf_f0_f5      equ     $41ca
mulf_f0_f6      equ     $41cc
mulf_f0_f7      equ     $41ce
mulf_f1_f0      equ     $41d0
mulf_f1_f1      equ     $41d2
mulf_f1_f2      equ     $41d4
mulf_f1_f3      equ     $41d6
mulf_f1_f4      equ     $41d8
mulf_f1_f5      equ     $41da
mulf_f1_f6      equ     $41dc
mulf_f1_f7      equ     $41de
mulf_f2_f0      equ     $41e0
mulf_f2_f1      equ     $41e2
mulf_f2_f2      equ     $41e4
mulf_f2_f3      equ     $41e6
mulf_f2_f4      equ     $41e8
mulf_f2_f5      equ     $41ea
mulf_f2_f6      equ     $41ec
mulf_f2_f7      equ     $41ee
mulf_f3_f0      equ     $41f0
mulf_f3_f1      equ     $41f2
mulf_f3_f2      equ     $41f4
mulf_f3_f3      equ     $41f6
mulf_f3_f4      equ     $41f8
mulf_f3_f5      equ     $41fa
mulf_f3_f6      equ     $41fc
mulf_f3_f7      equ     $41fe
mulf_f4_f0      equ     $4200
mulf_f4_f1      equ     $4202
mulf_f4_f2      equ     $4204
mulf_f4_f3      equ     $4206
mulf_f4_f4      equ     $4208
mulf_f4_f5      equ     $420a
mulf_f4_f6      equ     $420c
mulf_f4_f7      equ     $420e
mulf_f5_f0      equ     $4210
mulf_f5_f1      equ     $4212
mulf_f5_f2      equ     $4214
mulf_f5_f3      equ     $4216
mulf_f5_f4      equ     $4218
mulf_f5_f5      equ     $421a
mulf_f5_f6      equ     $421c
mulf_f5_f7      equ     $421e
mulf_f6_f0      equ     $4220
mulf_f6_f1      equ     $4222
mulf_f6_f2      equ     $4224
mulf_f6_f3      equ     $4226
mulf_f6_f4      equ     $4228
mulf_f6_f5      equ     $422a
mulf_f6_f6      equ     $422c
mulf_f6_f7      equ     $422e
mulf_f7_f0      equ     $4230
mulf_f7_f1      equ     $4232
mulf_f7_f2      equ     $4234
mulf_f7_f3      equ     $4236
mulf_f7_f4      equ     $4238
mulf_f7_f5      equ     $423a
mulf_f7_f6      equ     $423c
mulf_f7_f7      equ     $423e
divf_f0_f0      equ     $4240
divf_f0_f1      equ     $4242
divf_f0_f2      equ     $4244
divf_f0_f3      equ     $4246
divf_f0_f4      equ     $4248
divf_f0_f5      equ     $424a
divf_f0_f6      equ     $424c
divf_f0_f7      equ     $424e
divf_f1_f0      equ     $4250
divf_f1_f1      equ     $4252
divf_f1_f2      equ     $4254
divf_f1_f3      equ     $4256
divf_f1_f4      equ     $4258
divf_f1_f5      equ     $425a
divf_f1_f6      equ     $425c
divf_f1_f7      equ     $425e
divf_f2_f0      equ     $4260
divf_f2_f1      equ     $4262
divf_f2_f2      equ     $4264
divf_f2_f3      equ     $4266
divf_f2_f4      equ     $4268
divf_f2_f5      equ     $426a
divf_f2_f6      equ     $426c
divf_f2_f7      equ     $426e
divf_f3_f0      equ     $4270
divf_f3_f1      equ     $4272
divf_f3_f2      equ     $4274
divf_f3_f3      equ     $4276
divf_f3_f4      equ     $4278
divf_f3_f5      equ     $427a
divf_f3_f6      equ     $427c
divf_f3_f7      equ     $427e
divf_f4_f0      equ     $4280
divf_f4_f1      equ     $4282
divf_f4_f2      equ     $4284
divf_f4_f3      equ     $4286
divf_f4_f4      equ     $4288
divf_f4_f5      equ     $428a
divf_f4_f6      equ     $428c
divf_f4_f7      equ     $428e
divf_f5_f0      equ     $4290
divf_f5_f1      equ     $4292
divf_f5_f2      equ     $4294
divf_f5_f3      equ     $4296
divf_f5_f4      equ     $4298
divf_f5_f5      equ     $429a
divf_f5_f6      equ     $429c
divf_f5_f7      equ     $429e
divf_f6_f0      equ     $42a0
divf_f6_f1      equ     $42a2
divf_f6_f2      equ     $42a4
divf_f6_f3      equ     $42a6
divf_f6_f4      equ     $42a8
divf_f6_f5      equ     $42aa
divf_f6_f6      equ     $42ac
divf_f6_f7      equ     $42ae
divf_f7_f0      equ     $42b0
divf_f7_f1      equ     $42b2
divf_f7_f2      equ     $42b4
divf_f7_f3      equ     $42b6
divf_f7_f4      equ     $42b8
divf_f7_f5      equ     $42ba
divf_f7_f6      equ     $42bc
divf_f7_f7      equ     $42be
negf_f0_f0      equ     $42c0
negf_f0_f1      equ     $42c2
negf_f0_f2      equ     $42c4
negf_f0_f3      equ     $42c6
negf_f0_f4      equ     $42c8
negf_f0_f5      equ     $42ca
negf_f0_f6      equ     $42cc
negf_f0_f7      equ     $42ce
negf_f1_f0      equ     $42d0
negf_f1_f1      equ     $42d2
negf_f1_f2      equ     $42d4
negf_f1_f3      equ     $42d6
negf_f1_f4      equ     $42d8
negf_f1_f5      equ     $42da
negf_f1_f6      equ     $42dc
negf_f1_f7      equ     $42de
negf_f2_f0      equ     $42e0
negf_f2_f1      equ     $42e2
negf_f2_f2      equ     $42e4
negf_f2_f3      equ     $42e6
negf_f2_f4      equ     $42e8
negf_f2_f5      equ     $42ea
negf_f2_f6      equ     $42ec
negf_f2_f7      equ     $42ee
negf_f3_f0      equ     $42f0
negf_f3_f1      equ     $42f2
negf_f3_f2      equ     $42f4
negf_f3_f3      equ     $42f6
negf_f3_f4      equ     $42f8
negf_f3_f5      equ     $42fa
negf_f3_f6      equ     $42fc
negf_f3_f7      equ     $42fe
negf_f4_f0      equ     $4300
negf_f4_f1      equ     $4302
negf_f4_f2      equ     $4304
negf_f4_f3      equ     $4306
negf_f4_f4      equ     $4308
negf_f4_f5      equ     $430a
negf_f4_f6      equ     $430c
negf_f4_f7      equ     $430e
negf_f5_f0      equ     $4310
negf_f5_f1      equ     $4312
negf_f5_f2      equ     $4314
negf_f5_f3      equ     $4316
negf_f5_f4      equ     $4318
negf_f5_f5      equ     $431a
negf_f5_f6      equ     $431c
negf_f5_f7      equ     $431e
negf_f6_f0      equ     $4320
negf_f6_f1      equ     $4322
negf_f6_f2      equ     $4324
negf_f6_f3      equ     $4326
negf_f6_f4      equ     $4328
negf_f6_f5      equ     $432a
negf_f6_f6      equ     $432c
negf_f6_f7      equ     $432e
negf_f7_f0      equ     $4330
negf_f7_f1      equ     $4332
negf_f7_f2      equ     $4334
negf_f7_f3      equ     $4336
negf_f7_f4      equ     $4338
negf_f7_f5      equ     $433a
negf_f7_f6      equ     $433c
negf_f7_f7      equ     $433e
absf_f0_f0      equ     $4340
absf_f0_f1      equ     $4342
absf_f0_f2      equ     $4344
absf_f0_f3      equ     $4346
absf_f0_f4      equ     $4348
absf_f0_f5      equ     $434a
absf_f0_f6      equ     $434c
absf_f0_f7      equ     $434e
absf_f1_f0      equ     $4350
absf_f1_f1      equ     $4352
absf_f1_f2      equ     $4354
absf_f1_f3      equ     $4356
absf_f1_f4      equ     $4358
absf_f1_f5      equ     $435a
absf_f1_f6      equ     $435c
absf_f1_f7      equ     $435e
absf_f2_f0      equ     $4360
absf_f2_f1      equ     $4362
absf_f2_f2      equ     $4364
absf_f2_f3      equ     $4366
absf_f2_f4      equ     $4368
absf_f2_f5      equ     $436a
absf_f2_f6      equ     $436c
absf_f2_f7      equ     $436e
absf_f3_f0      equ     $4370
absf_f3_f1      equ     $4372
absf_f3_f2      equ     $4374
absf_f3_f3      equ     $4376
absf_f3_f4      equ     $4378
absf_f3_f5      equ     $437a
absf_f3_f6      equ     $437c
absf_f3_f7      equ     $437e
absf_f4_f0      equ     $4380
absf_f4_f1      equ     $4382
absf_f4_f2      equ     $4384
absf_f4_f3      equ     $4386
absf_f4_f4      equ     $4388
absf_f4_f5      equ     $438a
absf_f4_f6      equ     $438c
absf_f4_f7      equ     $438e
absf_f5_f0      equ     $4390
absf_f5_f1      equ     $4392
absf_f5_f2      equ     $4394
absf_f5_f3      equ     $4396
absf_f5_f4      equ     $4398
absf_f5_f5      equ     $439a
absf_f5_f6      equ     $439c
absf_f5_f7      equ     $439e
absf_f6_f0      equ     $43a0
absf_f6_f1      equ     $43a2
absf_f6_f2      equ     $43a4
absf_f6_f3      equ     $43a6
absf_f6_f4      equ     $43a8
absf_f6_f5      equ     $43aa
absf_f6_f6      equ     $43ac
absf_f6_f7      equ     $43ae
absf_f7_f0      equ     $43b0
absf_f7_f1      equ     $43b2
absf_f7_f2      equ     $43b4
absf_f7_f3      equ     $43b6
absf_f7_f4      equ     $43b8
absf_f7_f5      equ     $43ba
absf_f7_f6      equ     $43bc
absf_f7_f7      equ     $43be
movfl_f0_f0     equ     $43c0
movfl_f0_f2     equ     $43c2
movfl_f0_f4     equ     $43c4
movfl_f0_f6     equ     $43c6
movfl_f1_f0     equ     $43c8
movfl_f1_f2     equ     $43ca
movfl_f1_f4     equ     $43cc
movfl_f1_f6     equ     $43ce
movfl_f2_f0     equ     $43d0
movfl_f2_f2     equ     $43d2
movfl_f2_f4     equ     $43d4
movfl_f2_f6     equ     $43d6
movfl_f3_f0     equ     $43d8
movfl_f3_f2     equ     $43da
movfl_f3_f4     equ     $43dc
movfl_f3_f6     equ     $43de
movfl_f4_f0     equ     $43e0
movfl_f4_f2     equ     $43e2
movfl_f4_f4     equ     $43e4
movfl_f4_f6     equ     $43e6
movfl_f5_f0     equ     $43e8
movfl_f5_f2     equ     $43ea
movfl_f5_f4     equ     $43ec
movfl_f5_f6     equ     $43ee
movfl_f6_f0     equ     $43f0
movfl_f6_f2     equ     $43f2
movfl_f6_f4     equ     $43f4
movfl_f6_f6     equ     $43f6
movfl_f7_f0     equ     $43f8
movfl_f7_f2     equ     $43fa
movfl_f7_f4     equ     $43fc
movfl_f7_f6     equ     $43fe
movlf_f0_f0     equ     $4400
movlf_f0_f1     equ     $4402
movlf_f0_f2     equ     $4404
movlf_f0_f3     equ     $4406
movlf_f0_f4     equ     $4408
movlf_f0_f5     equ     $440a
movlf_f0_f6     equ     $440c
movlf_f0_f7     equ     $440e
movlf_f2_f0     equ     $4410
movlf_f2_f1     equ     $4412
movlf_f2_f2     equ     $4414
movlf_f2_f3     equ     $4416
movlf_f2_f4     equ     $4418
movlf_f2_f5     equ     $441a
movlf_f2_f6     equ     $441c
movlf_f2_f7     equ     $441e
movlf_f4_f0     equ     $4420
movlf_f4_f1     equ     $4422
movlf_f4_f2     equ     $4424
movlf_f4_f3     equ     $4426
movlf_f4_f4     equ     $4428
movlf_f4_f5     equ     $442a
movlf_f4_f6     equ     $442c
movlf_f4_f7     equ     $442e
movlf_f6_f0     equ     $4430
movlf_f6_f1     equ     $4432
movlf_f6_f2     equ     $4434
movlf_f6_f3     equ     $4436
movlf_f6_f4     equ     $4438
movlf_f6_f5     equ     $443a
movlf_f6_f6     equ     $443c
movlf_f6_f7     equ     $443e
movl_f0_f0      equ     $4440
movl_f0_f2      equ     $4442
movl_f0_f4      equ     $4444
movl_f0_f6      equ     $4446
movl_f2_f0      equ     $4448
movl_f2_f2      equ     $444a
movl_f2_f4      equ     $444c
movl_f2_f6      equ     $444e
movl_f4_f0      equ     $4450
movl_f4_f2      equ     $4452
movl_f4_f4      equ     $4454
movl_f4_f6      equ     $4456
movl_f6_f0      equ     $4458
movl_f6_f2      equ     $445a
movl_f6_f4      equ     $445c
movl_f6_f6      equ     $445e
movf_f0_f0      equ     $4460
movf_f0_f1      equ     $4462
movf_f0_f2      equ     $4464
movf_f0_f3      equ     $4466
movf_f0_f4      equ     $4468
movf_f0_f5      equ     $446a
movf_f0_f6      equ     $446c
movf_f0_f7      equ     $446e
movf_f1_f0      equ     $4470
movf_f1_f1      equ     $4472
movf_f1_f2      equ     $4474
movf_f1_f3      equ     $4476
movf_f1_f4      equ     $4478
movf_f1_f5      equ     $447a
movf_f1_f6      equ     $447c
movf_f1_f7      equ     $447e
movf_f2_f0      equ     $4480
movf_f2_f1      equ     $4482
movf_f2_f2      equ     $4484
movf_f2_f3      equ     $4486
movf_f2_f4      equ     $4488
movf_f2_f5      equ     $448a
movf_f2_f6      equ     $448c
movf_f2_f7      equ     $448e
movf_f3_f0      equ     $4490
movf_f3_f1      equ     $4492
movf_f3_f2      equ     $4494
movf_f3_f3      equ     $4496
movf_f3_f4      equ     $4498
movf_f3_f5      equ     $449a
movf_f3_f6      equ     $449c
movf_f3_f7      equ     $449e
movf_f4_f0      equ     $44a0
movf_f4_f1      equ     $44a2
movf_f4_f2      equ     $44a4
movf_f4_f3      equ     $44a6
movf_f4_f4      equ     $44a8
movf_f4_f5      equ     $44aa
movf_f4_f6      equ     $44ac
movf_f4_f7      equ     $44ae
movf_f5_f0      equ     $44b0
movf_f5_f1      equ     $44b2
movf_f5_f2      equ     $44b4
movf_f5_f3      equ     $44b6
movf_f5_f4      equ     $44b8
movf_f5_f5      equ     $44ba
movf_f5_f6      equ     $44bc
movf_f5_f7      equ     $44be
movf_f6_f0      equ     $44c0
movf_f6_f1      equ     $44c2
movf_f6_f2      equ     $44c4
movf_f6_f3      equ     $44c6
movf_f6_f4      equ     $44c8
movf_f6_f5      equ     $44ca
movf_f6_f6      equ     $44cc
movf_f6_f7      equ     $44ce
movf_f7_f0      equ     $44d0
movf_f7_f1      equ     $44d2
movf_f7_f2      equ     $44d4
movf_f7_f3      equ     $44d6
movf_f7_f4      equ     $44d8
movf_f7_f5      equ     $44da
movf_f7_f6      equ     $44dc
movf_f7_f7      equ     $44de

movf_m_f7       equ     $44e0
movf_m_f6       equ     $44e4
movf_m_f5       equ     $44e8
movf_m_f4       equ     $44ec
movf_m_f3       equ     $44f0
movf_m_f2       equ     $44f4
movf_m_f1       equ     $44f8
movf_m_f0       equ     $44fc
movif_m_f7      equ     $4500
movif_m_f6      equ     $4504
movif_m_f5      equ     $4508
movif_m_f4      equ     $450c
movif_m_f3      equ     $4510
movif_m_f2      equ     $4514
movif_m_f1      equ     $4518
movif_m_f0      equ     $451c
movil_m_f6      equ     $4520
movil_m_f4      equ     $4524
movil_m_f2      equ     $4528
movil_m_f0      equ     $452c
movfl_m_f6      equ     $4530
movfl_m_f4      equ     $4534
movfl_m_f2      equ     $4538
movfl_m_f0      equ     $453c
lfsr_m_m        equ     $4540

movf_f7_m       equ     $4550
movf_f6_m       equ     $4554
movf_f5_m       equ     $4558
movf_f4_m       equ     $455c
movf_f3_m       equ     $4560
movf_f2_m       equ     $4564
movf_f1_m       equ     $4568
movf_f0_m       equ     $456c
movlf_f6_m      equ     $4570
movlf_f4_m      equ     $4574
movlf_f2_m      equ     $4578
movlf_f0_m      equ     $457c
sfsr_m_m        equ     $4580
	     page
	def     asm_rmul,asm_rdiv,asm_rsub,asm_radd
	def     asm_round,asm_trunc,asm_float
	def     asm_bcd_real,asm_real_bcd,asm_bcdround
	def     asm_pack,asm_unpack
	def     asm_hex,asm_octal,asm_binary
	def     asm_eq,asm_ne,asm_lt,asm_le,asm_gt,asm_ge
	def     asm_sin,asm_cos,asm_arctan,asm_sqrt,asm_exp,asm_ln
	def     asm_addsetrange
	def     asm_flpt_error,asm_flpt_reset

asm_flpt_error  bra     flpt_error
asm_flpt_reset  bra     flpt_reset

*******************************************************************************
*
*       Procedures : asm_radd / asm_rsub / asm_rmul / asm_rdiv
*
*       Description: These are the compiler interface routines for
*                    doing real +, -, *, and /.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand2
*
*       Registers  : a0         - return address
*                    a1         - address of the card
*                    d0-d3      - the operands
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : radd, rsbt, rmul, rdvd, flpt_cardaddr, flpt_error
*
*******************************************************************************

asm_radd  movea.l (sp)+,a0              get the return address
	movem.l (sp)+,d0-d3             get the operands
	tst.b   fltpthdw                is fp hardware there
	beq.s   s@@1                     branch if not
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   addl_f0_f2(a1)          f2 + f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@1     bsr     radd                   do the operation in software
	move.l  d1,-(sp)                return the result
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rsub  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@3
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   subl_f0_f2(a1)          f2 - f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@3     bsr     rsbt
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rmul  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@5
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   mull_f0_f2(a1)          f2 * f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@5     bsr     rmul
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rdiv  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@7
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   divl_f0_f2(a1)          f2 / f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@7     bsr     rdvd
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_sin / asm_cos / asm_arctan / asm_sqrt
*                    asm_exp / asm_ln
*
*       Description: These are the compiler interface routines for
*                    the transendentals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand
*
*       Result     : The result is returned on the stack by the
*                    called routine.
*
*       Error(s)   : Generated in the called routines.
*
*       References : See text.
*
*******************************************************************************

asm_sin tst.b   fltpthdw                is hardware there?
	beq     soft_sin                software transcendental
	bra     flpt_sin

asm_cos tst.b   fltpthdw
	beq     soft_cos
	bra     flpt_cos

asm_arctan tst.b   fltpthdw
	beq     soft_arctan
	bra     flpt_arctan

asm_sqrt tst.b  fltpthdw
	beq     soft_sqrt
	bra     flpt_sqrt

asm_exp tst.b   fltpthdw
	beq     soft_exp
	bra     flpt_exp

asm_ln  tst.b   fltpthdw
	beq     soft_ln
	bra     flpt_ln
	page
*******************************************************************************
*
*       Procedures : asm_float / asm_round / asm_trunc
*
*       Description: These are the compiler interface routines for
*                    converting integers to reals and reals to integers.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand (if present)
*
*       Registers  : a0         - return address
*                    d0-d1      - the operand(s)
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : lntrel, rellnt, rellntt
*
*       Miscel     : The floating point card is not used for any of these
*                    conversions mainly because our hardware does not support
*                    conversions from reals to integers and, in the other
*                    direction, floating point registers would have to be
*                    saved and restored, making the hardware versions not
*                    much faster than the software versions.
*
*******************************************************************************

asm_float movea.l (sp)+,a0              return address
	move.l  (sp)+,d0                operand to convert
	bsr     lntrel
	move.l  d1,-(sp)                place result on stack
	move.l  d0,-(sp)
	jmp     (a0)

asm_round movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellnt
	move.l  d0,(sp)
	jmp     (a0)

asm_trunc movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellntt
	move.l  d0,(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_bcd_real / asm_real_bcd
*
*       Description: These are the compiler interface routines for
*                    converting between reals and decimals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : asm_bcd_real
*                       4(sp)   - address of the result real
*                       8(sp)   - address of the bcd number to convert
*                    asm_real_bcd
*                       4(sp)   - address of the result bcd number
*                       8(sp)   - address of the real to convert
*
*       Registers  : See the text of the code.
*
*       Result     : See "Parameters".
*
*       Error(s)   : Generated in the called routines.
*
*       References : relbcd, bcdrel
*
*       Miscel     : Both bcdrel and relbcd still do software multiplies.
*
*******************************************************************************

asm_bcd_real movea.l 8(sp),a0           address of the bcd to convert
	bsr     bcdrel                  return real in (d0,d1)
	movea.l (sp)+,a0                return address
	movea.l (sp)+,a1                address of the result real
	move.l  d0,(a1)+
	move.l  d1,(a1)
	addq.l  #4,sp
	jmp     (a0)

asm_real_bcd moveq  #16,d7      16 digits requested
	movea.l (sp)+,a1        return address
	movea.l (sp)+,a0        address of result bcd number
	movea.l (sp),a2         address of number to convert
	move.l  (a2)+,d0
	move.l  (a2),d1
	move.l  a1,(sp)
	bsr     relbcd
	rts
	page
*******************************************************************************
*
*       Procedure  : rmul
*
*       Description: Do a software 64 bit real multiply.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Registers  : d4,d5,d6   - partial products
*                    d7         - sticky bit information
*                    a0         - result exponent
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

retzero moveq   #0,d0           return zero
	move.l  d0,d1
	rts
*
*  Shortness is defined as < 17 bits of mantissa.
*
short2  tst.l   d3              test opnd2lo for zero
	bne.s   ts2
	   move.l  d0,d6           test both operandhi for
	   or.l    d2,d6           shortness
	   swap    d6
	   and.w   #$1f,d6
	   beq     shxsh           short times a short
	      move.l  d2,d6           test opnd2hi for shortness
	      swap    d6
	      and.w   #$1f,d6
	      bne.s   ts2
		 exg     d0,d2
		 exg     d1,d3            short opnd in d0-d1
		 bra     longxsh          long times a short
*
*  If here then opnd2 is definitely not short.
*
ts2     move.l  d0,d6
	swap    d6              test opnd1hi for shortness
	and.w   #$1f,d6
	bne.s   phase1
	   bra     longxsh
short1  move.l  d2,d6           test opnd2hi
	swap    d6              for shortness
	and.w   #$1f,d6
	bne.s   ph1a
	   exg     d0,d2
	   exg     d1,d3
	   bra     longxsh

*******************************************************************************
*
*  64 bit real multiply begins here.
*
rmul      cmp.l   #minuszero,d0 check first operand for -0
	  beq.s   retzero       return +0 as the answer
	  cmp.l   #minuszero,d2 check second operand for -0
	  beq.s   retzero       return +0 as the answer
	  move.l  #$80007ff0,d5 mask for exponent evaluation
	  move.l  d0,d7         high order opnd1 -> d7
	  beq.s   retzero       branch if zero operand
	  swap    d0            duplicate high order word into
	  move.w  d0,d7         low order word of d7
	  move.l  d2,d6         do the same for opnd2 into d6
	  beq.s   retzero       branch if zero operand
	  move.l  a0,-(sp)      a0 must not be altered by this routine
	  swap    d2
	  move.w  d2,d6
	  and.l   d5,d6         use mask to put sign in high order
	  and.l   d5,d7         and exponent in low order word
	  add.l   d6,d7         form result sign and exponent at once
	  moveq   #$f,d6        mask for removing exponent
	  and.w   d6,d0         extract mantissas
	  and.w   d6,d2
	  moveq   #$10,d6       mask for inserting hidden one
	  or.w    d6,d2         put in hidden one
	  or.w    d6,d0
	  movea.l d7,a0         store result exponent in a0
	  moveq   #0,d7         use d7 for sticky bit
	  tst.l   d1            can we do a faster multiply?
	  beq     short2
*
*                                     B3    B2   B1   B0
*                          X          A3    A2   A1   A0
*                               ---------------------------
*                                               [A0 X B0] (1)
*                                          [A0 X B1]      (2.1)
*                                          [A1 X B0]      (2.2)
*                                     [A1 X B1]           (3.1)
*                                     [A2 X B0]           (3.2)
*                                     [A0 X B2]           (3.3)
*                                [A3 X B0]                (4.1)
*                                [A2 X B1]                (4.2)
*                                [A0 X B3]                (4.3)
*                                [A1 X B2]                (4.4)
*                           [A3 X B1]                     (5.1)
*                           [A1 X B3]                     (5.2)
*                           [A2 x B2]                     (5.3)
*                      [A2 X B3]                          (6.1)
*                      [A3 X B2]                          (6.2)
*                 [A3 X B3]                               (7)
*-------------------------------------------------------------
*                 PP7  PP6  PP5  PP4  PP3  PP2  PP1  PP0
*
* Keep PP4 thru PP7; use PP0 thru PP3 for stickiness.

*
*                       Phase 1
*                        (1)
*
phase1   move.l  d3,d5          check for shortness
	 beq.s   short1
ph1a     mulu    d1,d5          A0*B0
	 or.w    d5,d7          keep track of lost bits for stickiness
	 clr.w   d5             discard bits 0-15
	 swap    d5
*
*                       Phase 2
*
*                       (2.1)
*
	 move.l  d3,d6
	 swap    d6
	 mulu    d1,d6          A0*B1
	 add.l   d6,d5
*
*                       (2.2)
*
	 clr.w   d4
	 move.l  d1,d6
	 swap    d6
	 mulu    d3,d6          A1*B0
	 add.l   d6,d5
	 addx.w  d4,d4
	 or.w    d5,d7
	 move.w  d4,d5
	 swap    d5
*
*                       Phase 3
*                       (3.1)
*
*
	 move.l  d3,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B1
	 swap    d1
	 add.l   d6,d5
*
*                       (3.2)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B0
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (3.3)
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d1,d6          A0*B2
	 add.l   d6,d5
	 or.w    d5,d7
	 move.w  d4,d5
	 negx.w  d5
	 neg.w   d5
	 swap    d5
*
*                       Phase 4
*                       (4.1)
*
	 move.w  d0,d6
	 mulu    d3,d6          A3*B0
	 add.l   d6,d5
*
*                       (4.2)
*
	 swap    d3
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B1
	 swap    d3
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (4.3)
*
	 move.w  d2,d6
	 mulu    d1,d6          A0*B3
	 add.l   d6,d5
	 negx.w  d4
	 neg     d4
*
*                       (4.4)
*
	 move.l  d2,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B2
	 swap    d1
	 add.l   d6,d5
	 negx.w  d4
	 neg.w   d4
	 swap    d4
	 swap    d5
	 move.w  d5,d4
*
*                       Phase 5
*                       (5.1)
*
*
	 clr.w   d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A3*B1
	 add.l   d6,d4
*
*                       (5.2)
*
*
	 move.l  d1,d6
	 swap    d6
	 mulu    d2,d6          A1*B3
	 add.l   d6,d4
*
*                       (5.3)
*
*
	 move.l  d2,d6
	 swap    d6
	 swap    d0
	 mulu    d0,d6          A2*B2
	 swap    d0
	 add.l   d6,d4
	 addx.w  d5,d5
	 move.w  d5,d6
	 move.w  d4,d5
	 move.w  d6,d4
	 swap    d5
	 swap    d4
*
*                       Phase 6
*
*                       (6.1)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d2,d6          A2*B3
	 add.l   d6,d4
*
*                       (6.2)
*
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A3*B2
	 add.l   d6,d4
*
*                       Phase 7
*
*                       (7)
*
	 move.w  d0,d6
	 mulu    d2,d6          A3*B3
	 swap    d6
	 add.l   d6,d4
*
*  Post normalization after multiplication
*
p_norm   btst    #25,d4
	 bne.s   m_norm_1
*
*  Shift whole mantissa 4 places right. This avoids 1 shift left.
*
	 suba.w  #$10,a0        adjust exponent
	 move.l  d4,d0
	 lsr.l   #4,d0
	 and.l   #$f,d4
	 ror.l   #4,d4
	 move.l  d5,d1
	 lsr.l   #4,d1
	 or.l    d4,d1
	 add.l   d5,d5          put round and stcky bits in place
	 bra.s   mround
*
*  Now shift whole mantissa right 5 places.
*
m_norm_1 move.l  d4,d0
	 lsr.l   #5,d0
	 and.l   #$1f,d4
	 ror.l   #5,d4
	 move.l  d5,d1
	 lsr.l   #5,d1
	 or.l    d4,d1
*
*  Result in (d0,d1). Now round.
*
mround   btst    #4,d5          test round bit
	 beq.s   roundun        if clear then no rounding to do
	 and.b   #$f,d5         get bits lost during last alignment
	 or.b    d5,d7          factor into sticky bit
mul_rnd2 tst.w   d7             test mr. sticky
	 bne.s   round_up       if sticky and round then round up
	    btst    #0,d1          test lsb of result
	    beq.s   roundun        else round to even
round_up addq.l  #1,d1
	 bcc.s   rm_4
	    addq.l  #1,d0
rm_4     btst    #21,d0
	 beq.s   roundun        test for mantissa overflow
	    lsr.l   #1,d0          d1 must already be zero
	    adda.w  #$10,a0
*
*  Extract result sign for later 'or' with the exponent.
*
roundun  move.l  a0,d6          get sign
	 swap    d6             place in bottom word
*
*  Complete exponent calculation with tests for overflow and underflow.
*
	 move.l  a0,d7          exponent with the sign
	 bpl.s   no_clear       branch if top portion already cleared
	    swap    d7             else clear the sign bit
	    clr.w   d7
	    swap    d7
no_clear movea.l  (sp)+,a0      restore original value of a0
	 sub.l   #$4000-$10,d7  remove extra bias minus hidden one
	 bmi     err_underflow  exponent underflow?
	 cmp.w   #$7fd0,d7      hidden bit add on later
	 bhi     err_overflow   or overflow?
*
*  Merge exponent and mantissa.
*
	 or.w    d6,d7          place sign with the exponent
	 swap    d7             place exponent into top portion
	 add.l   d7,d0          aha, hidden bit finally adds back!
	 rts

********************************************************************************
*
*  Shorter precision multiply when possible.
*
shxsh    swap    d0             align 16 bits of mantissa into d0
	 swap    d2             same for d2
	 lsr.l   #5,d0
	 lsr.l   #5,d2
	 mulu    d2,d0          A0*B0 only one multiply required here
	 swap    d0             rotate and mask result into correct bits
	 move.l  d0,d1
	 clr.w   d1
	 lsl.l   #5,d1
	 rol.l   #5,d0
	 and.l   #$001fffff,d0
	 btst    #20,d0         test for post-normalize
	 bne.s   roundun        note: no rounding possible, too few bits
	    add.l   d1,d1          shift mantissa left one position
	    addx.l  d0,d0
	    suba.w  #$10,a0        compensate exponent
	    bra     roundun
*
*  Long times shorter.
*
longxsh  swap    d0             align 16 bits of mantissa into d0
	 lsr.l   #5,d0
	 move.w  d3,d5
	 mulu    d0,d5          A0 * B0
	 or.w    d5,d7          keep PP0 in d7 for rounding
	 clr.w   d5
	 swap    d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A0 * B1
	 add.l   d6,d5
	 move.w  d5,d4
	 clr.w   d5
	 swap    d5
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A0 * B2
	 add.l   d6,d5
	 swap    d4
	 move.w  d5,d4
	 swap    d4
	 clr.w   d5
	 swap    d5
	 move.w  d2,d6
	 mulu    d0,d6          A0 * B3
	 add.l   d6,d5
	 move.l  d5,d0
	 move.l  d4,d1
	 btst    #20,d0         test for post-normalize
	 bne.s   lxs2
	    add.w   d7,d7          shift entire fraction left
	    addx.l  d1,d1
	    addx.l  d0,d0
	    suba.w  #$10,a0        fix exponent
lxs2     add.w   d7,d7          round bit into carry, leaving stickyness in d7
	 bcc     roundun
	    bra     mul_rnd2       possible rounding to do
	 page
*******************************************************************************
*
*       Procedure  : rdvd
*
*       Description: Do a software 64 bit real divide.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand (dividend)
*                    (d2,d3)    - second operand (divisor)
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow, real underflow, and divide-by-zero.
*
*       References : err_underflow, err_overflow, err_divzero
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************
*
*
*  This routine called 4 times will produce up to 64 quotient bits
*  d0-d1 is 64 bit dividend
*  d2-d3 is 64 bit divisor      (should be normalized (bit 31 = 1))
*  d4-d5 is 64 bit quotient
*
dv00     swap    d4             shift quotient left 16 bits
	 swap    d5
	 move.w  d5,d4
*
	 tst.l   d0             1st 32 dividend bits  /  1st 16 divisor bits
	 beq.s   dv7
dv0         swap    d2
	    divu    d2,d0
	    bvc.s   normal         branch if no overflow
*
*  Had an overflow on the divide. Our quotient must be $ffff or $fffe, and the
*  fixup for the new dividend is derived as follows.
*
*  DVD := Shl16(d0,d1) - Quotient * (d2,d3)
*      := Shl16(d0,d1) - (2^16-c) * (d2,d3);  c = 1 or 2
*      := Shl16(d0,d1) - Shl16(d2,d3) + c(d2,d3)
*      := Shl16( (d0,d1) - (d2,d3) ) + c(d2,d3)
*
	    swap    d2                restore correct order of divisor
	    move.w  #$ffff,d5         new quotient
	    sub.l   d3,d1             (d0,d1) - (d2,d3)
	    subx.l  d2,d0
	    swap    d0                shift left by 16
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   dv6               fixup up dividend (add back at least once)
*
*  Normal divide - no overflow. Go through standard routine.
*
normal   swap    d2
dv7      move.w  d0,d5          16 bits shifted into quotient register
	 swap    d1             shift dividend left 16 bits
	 move.w  d1,d0          except for remainder in d0 upper
	 clr.w   d1
	 tst.w   d5             finish low order part of division:
	 beq.s   dv1
	 moveq   #0,d7          d7 is used for borrow bit out of dividend
	 move.w  d2,d6          dividend - (quotient * 2nd 16 divisor bits)
	 beq.s   dv2
	    mulu    d5,d6
	    sub.l   d6,d0
	    bcc.s   dv2
	    subq    #1,d7
*
dv2      move.w  d3,d6          dividend - (quotient * 4th 16 divisor bits)
	 beq.s   dv3
	    mulu    d5,d6
	    sub.l   d6,d1
	    bcc.s   dv3
	       subq.l  #1,d0
	       bcc.s   dv3
		  subq    #1,d7
*
dv3      swap    d3             dividend - (quotient * 3rd 16 divisor bits)
	 move.w  d3,d6
	 beq.s   dv4
	    mulu    d5,d6
	    swap    d1
	    sub.w   d6,d1
	    swap    d1
	    swap    d6
	    subx.w  d6,d0
	    bcc.s   dv4
	       sub.l   #$10000,d0
	       bcc.s   dv4
		  subq    #1,d7
dv4      swap    d3
	 tst.w   d7             restore dividend and quotient if it didn't go
	 bpl.s   dv1
*
dv5         subq.l  #1,d5          decrement quotient
	    bcc.s   dv6
	       subq.l  #1,d4          propagate the borrow in the quotient
dv6         add.l   d3,d1          add divisor back to dividend
	    addx.l  d2,d0
	    bcc.s   dv5            repeat till dividend >= 0
*                               (at most twice more if bit 31 of divisor is 1)
dv1     rts

*******************************************************************************
*
*  Main body of the real divide.
*
rdvd     tst.l   d2             check for zero
	 beq     err_divzero     branch if divisor is a zero
	 cmp.l   #minuszero,d2   check for -0
	 beq     err_divzero     branch if divisor is a zero
*
*  Check for a zero dividend.
*
dvndzer  tst.l   d0
	 bne.s   checkn
divret0     moveq   #0,d0          else return a zero result
	    move.l  d0,d1
	    rts
checkn   cmp.l   #minuszero,d0  check for -0
	 beq.s   divret0
*
*  Prepare mantissas for divide, and save exponents for later.
*
procdvd  moveq   #$000f,d6      masks for the mantissa preparation
	 moveq   #$0010,d7
	 swap    d2             get the mantissas
	 move.w  d2,-(sp)       push the divisor exponent
	 and.w   d6,d2
	 or.w    d7,d2
	 swap    d2
	 swap    d0             same for next operand
	 move.w  d0,-(sp)       push the dividend exponent
	 and.w   d6,d0
	 or.w    d7,d0
	 swap    d0             mantissas ready for divide; compute exp
*
*  Divide of the mantissas with the remainder in (d0,d1)
*  and a 55 bit result to enable proper rounding. The result
*  is generated in (d4,d5).
*
	add.l   d1,d1           preshift dividend so quotient lines up right
	addx.l  d0,d0

	moveq   #11,d7          normalize divisor so that bit 31 = 1
	lsl.l   d7,d2
	rol.l   d7,d3
	move.l  d3,d6
	and.w   #$f800,d3
	and.w   #$07ff,d6
	or.w    d6,d2

	bsr     dv0             inner loop of divide
	bsr     dv00
	bsr     dv00
	bsr     dv00
	move.l  d4,d2           place here so sticky bit can be set
	move.l  d5,d3
*
*  Compute the new exponent and sign.
*
	 moveq   #0,d7          contain the exponent and sign of result
	 move.l  d7,d5          exponent calculation registers
	 move.l  d7,d6
	 move.w  (sp)+,d5       get dividend exponent
	 move.w  (sp)+,d6       get divisor exponent
	 eor.w   d5,d6          compute sign of result
	 bpl.s   possign
	     move.w  #$8000,d7     negative sign
possign  eor.w   d5,d6          restore exponents - nice trick
	 move.w  #$7ff0,d4      masks for the exponents
	 and.w   d4,d5          mask out exponents
	 and.w   d4,d6
	 sub.l   d6,d5          dividend exponent - divisor exponent
	 add.l   #$3ff0-$10,d5  bias - hidden bit (hidden bit adds later)
*
*  Normalize mantissa if necessary and compute sticky bit.
*
possitv  btst    #22,d2         check leading bit for normalize
	 bne.s   shftd          branch if already a one
	    add.l   d3,d3          else make it a leading one
	    addx.l  d2,d2
	    sub.l   #$10,d5        adjust exponent
shftd    or.l    d0,d1          set sticky bit with remainder
	 beq.s   rnd            if zero, sticky bit set correctly
	    or.b    #1,d3          else set sticky bit
*
*  Do the round and check for overflow and underflow.
*
rnd      btst    #1,d3          check round bit
	 beq.s   rend           branch if nothing to round
	 addq.l  #$2,d3         add 1 in the round bit
	 bcc.s   rndcon         branch if nothing to propagate
	    addq.l  #1,d2          else propagate the carry
rndcon   move.b  d3,d0          get the sticky bit
	 lsr.b   #1,d0          place into carry
	 bcs.s   norml          branch if number not halfway between
	    and.b   #$f8,d3        all zero so clear lsb (round to even)
norml    btst    #23,d2         check for overflow
	 beq.s   rend           if a zero then no overflow
	    lsr.l   #1,d2          only bit set is #24 because of overflow
	    add.l   #$10,d5        adjust exponent accordingly
rend     tst.l   d5             check for underflow
	 bmi     err_underflow  underflow error handler
	 cmp.w   #$7fd0,d5      check for overflow (remember, hidden bit! )
	 bhi     err_overflow   overflow error handler
*
*  Splice result together.
*
	 lsr.l   #1,d2          throw away round and sticky bits
	 roxr.l  #1,d3
	 lsr.l   #1,d2
	 roxr.l  #1,d3
	 or.w    d5,d7          place exponent with sign
	 swap    d7
	 add.l   d7,d2          ah!, hidden bit finally adds back!!
	 move.l  d2,d0          place in the correct registers
	 move.l  d3,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : radd / rsbt
*
*       Description: Do a software 64 bit real addition/subtraction.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

first_z  move.l  d7,d0          if subtracting from zero then the
	 move.l  d3,d1          result is operand2 with the sign
	 rts                    complemented previously
*
*  This is the subtract front end. The second operand is subtracted
*  by complementing its sign.
*
rsbt     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s   rsbt1
	    rts                    (d0,d1) is the result
rsbt1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   subnonz        zero value?
	    rts                    else (d0,d1) is the result
subnonz  bchg    #31,d7         complement sign bit for subtract
	 bne.s   second_p       test if plus or minus

second_m cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sec11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sec11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        -(d2,d3) is the result
	 bmi.s   same_sig       if signs are different then set

difsigns move.w  #-1,d6         subtract flag
	 bra.s   add1

prenorm  moveq   #0,d4          no prenormalization to do
	 bra.s   do_it          so clear overflow (g,r,s)
*
*  This is the add front end.
*
radd     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s    radd1
	    rts                    (d0,d1) is the result
radd1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   add_11         test for zero
	    rts                    else (d0,d1) is the result
add_11   bmi.s   second_m       test sign
second_p cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sss11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sss11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        also test it for zero
	 bmi.s   difsigns       and check its sign
same_sig clr.w   d6             clear subtract flag

*******************************************************************************
*
*  Common to both the add and subtract.
*
add1     moveq   #$000f,d4      masks for mantissa extraction
	 moveq   #$0010,d5
	 swap    d0             clear out exponent of operand1
	 and.w   d4,d0          and put in hidden one bit
	 or.w    d5,d0
	 swap    d0
	 swap    d2             do the same for operand2
	 and.w   d4,d2
	 or.w    d5,d2
	 swap    d2
	 swap    d6             note: sign flag goes into high part
	 swap    d7
	 move.w  #$7ff0,d4      take difference of exponents
	 move.w  d4,d5
	 and.w   d6,d4
	 and.w   d7,d5
	 sub.w   d5,d4
	 beq.s   prenorm        skip prenormalization
	 asr.w   #4,d4          faster to shift difference
	 bpl.s   add2           larger operand in d0-d1?
	 neg.w   d4             otherwise swap
	 move.w  d7,d6          use larger exponent
	 exg     d0,d2
	 exg     d1,d3
add2     moveq   #-1,d7         all ones mask in d7
	 cmp.w   #32,d4         use move.l for >= 32
	 bge     long_sh
	    lsr.l   d4,d7          rotate mask and merge to shift
	    ror.l   d4,d2          a 64 bit value by N positions
	    ror.l   d4,d3          without looping
	    move.l  d3,d4          dump spillover into d3
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4

do_it    move.w  d6,d5          get result exponent
	 tst.l   d6
	 bmi.s   sub_it         remember subtract flag?
*
*  Add 2 numbers with the same signs.
*
add_it   and.w   #$7ff0,d5      mask out exponent
	 move.l  #$00200000,d7  mask for mantissa overflow test
	 add.l   d3,d1          this is it, sports fans
	 addx.l  d2,d0
	 cmp.l   d7,d0          test for mantissa overflow
	 blt.s   add3
	    add.w   #16,d5         exponent in bits 15/5
	    lsr.l   #1,d0          everything right and increment
	    roxr.l  #1,d1          the exponent
	    roxr.l  #1,d4
	    bcc.s   add3           don't forget to catch the
	       or.w    #1,d4          sticky bit
add3     cmp.l   #$80000000,d4  test for rounding
	 bcs.s   add5           if lower then no rounding to do
	 bhi.s   add4           if higher then round up
	    btst    #0,d1          otherwise test mr. sticky
	    beq.s   add5
add4     addq.l  #1,d1          here we are at the roundup
	 bcc.s   add5
	    addq.l  #1,d0
	    cmp.l   d7,d0          a word to the wise: test for
	    blt.s   add5           mantissa overflow when you
	       lsr.l   #1,d0          round up during an add
	       add.w   #16,d5         exponent in bits 15/5
add5     cmp.w   #$7fe0,d5      check for exponent overflow
	 bhi     err_overflow
	 tst.w    d6            get sign of the result
	 bpl.s   add6           positive result
	    add.w   #$8000,d5      copy sign bit
add6     swap    d5
	 clr.w   d5             for the or
	 bclr    #20,d0         hide hidden one
	 or.l    d5,d0          exponent into mantissa
	 rts
*
*  Add two numbers with differing signs.
*
sub_it   lsr.w   #4,d5          align in correct location
	 and.w   #$07ff,d5      get rid of the sign bit
	 neg.l   d4             zero minus overlow
	 subx.l  d3,d1          subtract low order
	 subx.l  d2,d0          subtract high order
	 tst.l   d0             test for top 21 bits all zero
	 beq     zerores        at least 21 left shifts necessary
	 bpl.s   sign_un        did we do it the right way?
	    add.w   #$8000,d6      flip sign of result
	    neg.l   d1             Note: this path only taken if path
	    negx.l  d0                   thru prenormalized was taken
	    tst.l   d0             check for top 21 bits being zero
	    beq     zerores        at least 21 left shifts necessary
sign_un  move.l  #$00100000,d7  post normalization mask
	 cmp.l   d7,d0          test for post normalization
	 bge.s   sub1
	 add.l   d4,d4          shift everything left one
	 addx.l  d1,d1          shift along guard bit first
	 addx.l  d0,d0          time only
	 subq.w  #1,d5          decrement exponent
	 cmp.l   d7,d0          normalized yet?
	 bge.s   sub1
	 move.l  d0,d4          test for shift by 16
	 and.l   #$001fffe0,d4  test high 16 bits
	 bne.s   norm8lop       if not 16 , check by 8
	    sub.w   #16,d5         adjust exponent
	    swap    d0
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   normlopp       less than 5 shifts left (maybe 0)
norm8lop move.l  d0,d4          test for shift by 8
	 and.l   #$001fe000,d4  check 8 high bits
	 bne.s   normloop       at least one shift still necesarry!
	    sub.w   #8,d5          adjust exponent
	    lsl.l   #8,d0
	    rol.l   #8,d1
	    move.b  d1,d0          d0 correct
	    clr.b   d1             d1 correct
normlopp cmp.l   d7,d0          must test here - could be done
	 bge.s   sub2           no rounding necessary
normloop add.l   d1,d1          this is for post normalizing < 8 times
	 addx.l  d0,d0          for any additional shifting
	 subq.w  #1,d5          note: this code can be improved
	 cmp.l   d7,d0
	 blt.s   normloop
	 bra.s   sub2           no rounding necessary
sub1     cmp.l   #$80000000,d4  rounding for subtract
	 bcs.s   sub2           same sequence as add
	 bhi.s   sub3
	    btst    #0,d1
	    beq.s   sub2
sub3     addq.l  #1,d1          round up
	 bcc.s   sub2
	    addq.l  #1,d0
	    btst    #21,d0         mantissa overflow?
	    beq.s   sub2
	       asr.l   #1,d0
	       addq    #1,d5          increment exponent (can't overflow)
sub2     tst.w   d5             test for exponent underflow
	 ble     err_underflow
	    lsl.w   #5,d5          exponent in top so can place in sign
	    add.w   d6,d6          get sign
	    roxr.w  #1,d5          into exponent
	    swap    d5
	    clr.w   d5             for the or
	    bclr    #20,d0         hide hidden one
	    or.l    d5,d0          exponent into mantissa
	    rts

shifted_ bclr    #20,d0         more than 55 shifts to prenormalize
	 swap    d6             so reconstruct larger operand and
	 clr.w   d6             return in d0-d1
	 or.l    d6,d0
	 rts

long_sh  beq.s   ls1            branch if exactly 32 shifts
	 cmp.w   #55,d4         if shift count is too large then
	 bgt.s   shifted_       don't bother
	    sub.w   #32,d4
	    lsr.l   d4,d7
	    ror.l   d4,d2
	    ror.l   d4,d3
	    move.l  d3,d4
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4
	    beq.s   ls1
	       or.w    #1,d3
ls1      move.l  d3,d4
	 move.l  d2,d3
	 moveq   #0,d2
	 bra     do_it

zerores  tst.l   d1
	 bne.s   longnorm       if result was zero after subtract, done
	 tst.l   d4             check guard bit
	 bmi.s   longnorm
	    rts

longnorm add.l   d4,d4          result nearly zero, shift 21 or more
	 addx.l  d1,d1
	 bcs.s   norm21         exact shift by 21
	 swap    d1             test for shift of 16
	 tst.w   d1
	 bne.s   test8          test for shift of 8
	    sub.w   #16,d5         adjust exponent (d1 correct)
	    move.l  d1,d7          check which byte first one in
	    swap    d7
	    and.w   #$ff00,d7
	    bne.s   lnloop         less than 8 shifts left
	       lsl.l   #8,d1          else adjust
	       subq.w  #8,d5
	       bra.s   lnloop
test8    move.w  d1,d7          check lower bytes
	 swap    d1             d1 in correct order
	 and.w   #$ff00,d7
	 bne.s   lnloop         less than 8 shifts left
	    lsl.l   #8,d1          else adjust
	    subq.w  #8,d5
lnloop   subq.w  #1,d5          less than 8 shifts left
	 add.l   d1,d1
	 bcc.s   lnloop
norm21   sub.w   #21,d5         adjust exponent
	 swap    d1             rotate left 20 or more places
	 rol.l   #4,d1          copy over the boundary
	 move.l  d1,d0
	 and.l   #$000fffff,d0  save high 20 bits
	 and.l   #$fff00000,d1  save low 12 bits
	 bra     sub2           hidden 1 is already gone
	 page
*******************************************************************************
*
*       Procedure  : rellnt
*
*       Description: Convert a real into a 32 bit integer (round).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellnt   move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover
	 beq.s   check32        -2,147,483,648.5 = (c1e00000,00100000)
	 tst.w   d6
	 bge.s   in32con        continue with conversion
	    moveq   #0,d0          else return a zero
	    rts
*
*  Finish the conversion.
*
in32con  and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1          place top bits (except hidden one) in d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 32
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 bcc.s   chksign        branch if rounded correctly
	    addq.l  #1,d1          round to the nearest
	    bpl.s   chksign        no overflow
	       tst.w   d7             overflow - check for negative result
	       bpl     err_intover    error if positive 2^31
chksign  tst.w   d7             check the sign
	 bpl.s   done3
	    neg.l   d1             else convert to negative
done3    move.l  d1,d0          place result in correct register
	 rts
*
*  Boundary condition checks.
*
check32  tst.w   d0             check sign first
	 bpl     err_intover    remember, shifted right by 16
	    and.w   #$000f,d0      mantissa of 2^31-.5 = ([1]00000 00100000)
	    bne     err_intover    definitely WAY too large
	       lsr.l   #5,d1          else shift till get LSb
	       bne     err_intover    if non-zero, less than -2^31 - 0.5
		  bcs     err_intover    branch if equal to -2^31 - 0.5
		     move.l  #$80000000,d0  else return -2^31
		     rts
	 page
*******************************************************************************
*
*       Procedure  : rellntt
*
*       Description: Convert a real into a 32 bit integer (truncation).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellntt  move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover    too big if don't branch
	 beq.s   silkcheck
skip     tst.w   d6             for small numbers
	 bgt.s   in32cont       branch if will convert
	    moveq   #0,d0          else return 0
	    rts
*
*  Place top bits (except for hidden bit) all in d1.
*
in32cont and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
*
*  Finish the conversion.
*
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 31
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 tst.w   d7             check the sign
	 bpl.s   done32
	    neg.l   d1             else convert to negative
done32   move.l  d1,d0          place result in correct register
	 rts
*
silkcheck tst.w  d0             check the sign first
	 bpl     err_intover
	    and.w   #$000f,d0
	    bne     err_intover if MS bite non-zero, WAY TOO LARGE
	    lsr.l   #5,d1       shift fractional portion out
	    bne     err_intover
	       move.l   #$80000000,d0
	       rts
	 page
*******************************************************************************
*
*       Procedure  : lntrel
*
*       Description: Convert a 32 bit integer into a real number.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : d0         - integer to be converted
*
*       Registers  : d4-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

maxlnt   move.l  #$c1e00000,d0  return -2^31
	 moveq   #0,d1
	 rts
*
*  Main body of lntrel.
*
lntrel   moveq   #0,d7          will hold sign of result and exponent
	 moveq   #0,d1          bottom part of mantissa
	 tst.l   d0             check if non-zero
	 bne.s   nonzero        branch if non-zero
	    moveq   #0,d0          else returna zero result
	    move.l  d0,d1
	    rts                    and return
nonzero  bpl.s   ifposit        branch if positive
	    neg.l   d0             else convert to positive
	    bvs.s   maxlnt         branch if had -2^31
	    move.w  #$8000,d7      else set sign bit in result
*
*  Determine if a 16 bit integer hiding in 32 bits.
*
ifposit  swap    d0             check for a 16 bit integer
	 tst.w   d0
	 beq.s   int16          branch if a 16 bit integer
	    move.w  #1023+20,d4    place in the bias
	    move.w  d0,d5          test if have to left shift
	    and.w   #$fff0,d5
	    bne.s   highpart       branch if first one in top of word
	       move.l  #$00100000,d6  mask for the test for normalization
	       swap    d0             else restore number
loop4          add.l   d0,d0          at least 1 and most 4 shifts
	       subq.w  #1,d4
	       cmp.l   d6,d0
	       blt.s   loop4          until normalized
		  bra.s   shdone
highpart    move.w  d0,d5          see if at least 8 right shifts
	    and.w   #$0ff0,d5
	    bne.s   finrit         if non-zero, then at most 7 more shifts
	       swap    d0             restore mantissa
	       addq.l  #8,d4          adjust exponent
	       move.b  d0,d1
	       ror.l   #8,d1          d1 is correct
	       lsr.l   #8,d0          d0 is correct
	       bra.s   insmask
finrit      swap    d0             restore mantissa
insmask     move.l  #$00200000,d6  mask for the test for normalization
	    cmp.l   d6,d0
	    blt.s   shdone         if <, d0 correctly lined up
loop_7         lsr.l   #1,d0
	       roxr.l  #1,d1
	       addq.l  #1,d4
	       cmp.l   d6,d0          continue until normalized
	       bge.s   loop_7
		  bra.s   shdone
*
*  Have a 16 bit integer to convert, so do it fast.
*
int16    swap    d0             restore the integer
	 move.w  #1023+15,d4    place in the bias
	 move.l  #$00100000,d6  mask for the test for normalization
	 lsl.l   #5,d0          shift by at least 5
	 cmp.l   d6,d0          see if done
	 bge.s   shdone
*
*   At most 15 shifts left.
*
	 move.l  d0,d5          check for shift by 8
	 and.l   #$001fe000,d5
	 bne.s   chk7           branch if 7 or less shifts left
	    lsl.l   #8,d0          else shift by 8
	    subq.w  #8,d4          adjust exponent, and finish the shift
chk7     cmp.l   d6,d0          check implied one
	 bge.s   shdone
lp_7        add.l   d0,d0          else shift left
	    subq.w  #1,d4
	    cmp.l   d6,d0
	    blt.s   lp_7           continue until normalized
*
*  Splice result together.
*
shdone   subq.w  #1,d4          hidden bit will add back
	 lsl.w   #4,d4          place in correct locations
	 or.w    d4,d7          place exponent in with sign
	 swap    d7             in correct order
	 add.l   d7,d0          add in exponent and sign
	 rts
	 page
*******************************************************************************
*
*       Procedure  : rndnear
*
*       Description: Round a real number to the nearest whole real number.
*                    If the real is too large to be rounded, the same
*                    number is returned.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d5-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

rndnear  move.l  d0,d6          extract the exponent
	 swap    d6             place in low word
	 and.w   #$7ff0,d6      get rid of sign bit
	 lsr.w   #4,d6          in low 11 bits
	 sub.w   #1022,d6       unbiased exponent plus one
*
*  Check if number is too small or large.
*
	 bgt.s   checknxt       branch if check for exponent too large
	 blt.s   rnd_zero       branch if so small that return a zero
	    moveq   #0,d1          else return + or - 1.0
	    tst.l   d0             determine sign
	    bmi.s   retmin
	       move.l  #$3ff00000,d0
	       rts
retmin      move.l  #$bff00000,d0
	    rts
rnd_zero moveq   #0,d0
	 move.l  d0,d1
	 rts
checknxt cmp.w   #53,d6
	 blt.s   nearcon        continue the round; 1 <= exp <= 52
	    rts                    else return with same number
*
*  Compute index for the addition of 0.5.
*
nearcon  neg.w   d6             map into correct range
	 add.w   #53,d6         1 <= d6 <= 52  (so can add in a 1)
	 move.w  d6,d5          save for later clear of mantissa bits
	 subq.w  #1,d6          number of left shifts for the mask
	 moveq   #1,d7          mask for the add
*
*  Add 0.5 (in magnitude) to the number to be rounded.
*
	 cmp.w   #32,d6         see if add to d0 or d1
	 bge.s   add0           branch if add to d0
	    lsl.l   d6,d7          shift over correct number of places
	    add.l   d7,d1
	    bcc.s   finnr          no need to check for overflow
	       addq.l  #1,d0          propagate carry
	       bra.s   finnr          if overflow, exponent adjusted!
add0    sub.w   #32,d6          get the correct mask
	lsl.l   d6,d7
	add.l   d7,d0           do add - oveflow goes into mantissa
*
*   Clear the bottom (d5) bits of (d0,d1).
*
finnr    moveq  #-1,d7          mask for the clear
	 cmp.w  #32,d5
	 blt.s  cleard1         branch of only have to clear bits in d1
	    moveq  #0,d1           else clear all of d1; maybe some of d0
	    sub.w  #32,d5          adjust count
	    bne.s  clearcon        branch if more to clear
	       rts                    else return
clearcon    lsl.l  d5,d7           get mask
	    and.l  d7,d0
	    rts
cleard1  lsl.l  d5,d7
	 and.l  d7,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : adx
*
*       Description: Augment a real number's exponent. This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    1.1  11/03/83  For:
*                            o Removing the test for 0.
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - amount to be augmented
*
*       Registers  : d6         - scratch
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

adx      swap    d0             put exponent into lower part
	 move.w  d0,d6          extract old exponent
	 and.w   #$800f,d0      first, remove old exponent in the result
	 and.w   #$7ff0,d6
	 asl.w   #4,d7          faster if don't have to shift back
	 add.w   d7,d6          new exponent computed
	 and.w   #$7ff0,d6      large exp and negative augment;negative sign
	 or.w    d6,d0          place in new exponent
	 swap    d0             restore correct order
	 rts
	 page
*******************************************************************************
*
*       Procedure  : intxp
*
*       Description: Extract the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*
*       Result     :  The result exponent is returned in d7.
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

intxp    move.l  d0,d7          don't destroy the original number
	 swap    d7             place exponent into low word
	 and.w   #$7ff0,d7
	 lsr.w   #4,d7
	 sub.w   #1022,d7       mantissa in range [0.5,1) (ignore hidden bit)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : setxp
*
*       Description: Set the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - unbiased value of the new exponent.
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

setxp    swap    d0
	 and.w   #$800f,d0      remove the exponent
	 add.w   #1022,d7       hidden bit becomes part of exponent
	 lsl.w   #4,d7          always positive after bias add, so do lsl
	 or.w    d7,d0          place in new exponent
	 swap    d0             re-align
	 rts
	 page
*******************************************************************************
*
*       Procedure  : compare
*
*       Description: Compare operand 1 with operand 2. Both operands are
*                    64 bit floating point reals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For -0 as valid input
*
*       Parameters : (d0,d1)    - operand 1
*                    (d2,d3)    - operand 2
*
*       Result     : Returned in the CCR (EQ,NE,GT,LT,GE,LE).
*
*       Misc       : The operands are not destroyed, and no other registers
*                    are used.
*
*******************************************************************************

compare  tst.l   d0             test first for sign of the first operand
	 bpl.s   rcomp2
	 tst.l   d2             test sign of second operand
	 bpl.s   rcomp2
*
	 cmp.l   d0,d2          both negative so do test backward
	 bne.s   cmpend         CCR set here
	 cmp.l   d1,d3          first part equal, check second part
	 beq.s   cmpend         EQ flag set
	 bhi.s   grt            unsigned compare
lst         move    #8,CCR         XNZVC = 01000
	    rts
*
rcomp2   cmp.l   d2,d0          at least one positive, ordinary test
	 bne.s   checkm0        must check for 0 compared with -0
	 cmp.l   d3,d1          both must be positive
	 beq.s   cmpend
	 bls.s   lst            branch if LT
grt         move    #0,CCR         XNZVC = 00000
cmpend   rts
*
* Check for the operands being 0 and -0.
*
checkm0  tst.l   d0
	 bpl.s   d2minus        branch if second operand is negative
	    cmp.l   #minuszero,d0  else (d0,d1) is negative
	    bne.s   finm0       reset condition code
	    tst.l   d2
	    bne.s   finm0       must check all of it
	       rts                 had (d0,d1) = -0 and (d2,d3) = 0
d2minus  cmp.l   #minuszero,d2  (d2,d3) is negative
	 bne.s   finm0       reset condition code
	 tst.l   d0
	 bne.s   finm0       must check all of it
	    rts              had (d2,d3) = -0 and (d0,d1) = 0
finm0   cmp.l   d2,d0        else reset condition code
	rts
	page
*******************************************************************************
*
*       Procedures : soft_horner / soft_hornera
*
*       Description: Evaluate a polynomial. "soft_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the software
*                    versions of the elementary function evaluations. These
*                    procedures call software floating point routines.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : (a4,a5)    - real number to be evaluated
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : d2,d3      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : radd, rmul
*
*       Miscel     : These procedures used to be know as "horner" and
*                    "hornera" respectively. For hardware floating
*                    point, 2 different procedures are needed: one
*                    for the software math and one for the hardware math.
*
*******************************************************************************

soft_horner move.w  d0,-(sp)    save the degree of the polynomial
	 move.l  (a6)+,d0       initialize result to first coeff.
	 move.l  (a6)+,d1
horloop     move.l  a4,d2          get w
	    move.l  a5,d3
	    bsr     rmul           previous result * w
	    move.l  (a6)+,d2       get next coefficient
	    move.l  (a6)+,d3
	    bsr     radd           add to previous result
	    subq.w  #1,(sp)
	    bne.s   horloop
hordone  addq.l  #2,sp          remove the degree count
	 rts

soft_hornera  move.w  d0,-(sp)  save the degree of the polynomial
	 move.l  a4,d0          initialize result to w
	 move.l  a5,d1
horloopa move.l  (a6)+,d2       get next coefficient; (d0,d1) ok
	 move.l  (a6)+,d3
	 bsr     radd           do the addition; (d0,d1) has result
	 subq.w  #1,(sp)
	 beq.s   hordone
	    move.l  a4,d2          get w; (d0,d1) correct
	    move.l  a5,d3
	    bsr     rmul           (d0,d1) has result
	    bra.s   horloopa
	 page
*******************************************************************************
*
*       Procedures : flpt_horner / flpt_hornera
*
*       Description: Evaluate a polynomial. "flpt_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the
*                    elementary function evaluation.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : (a4,a5)    - real number to be evaluated (w)
*                    a0         - address of the floating point hardware
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : f0-f5      - scratch floating point registers
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned in (f1,f0).
*
*       Error(s)   : All arguments are defined to be in a restricted range,
*                    so error conditions cannot arise.
*
*       Miscel     : The caller must save and restore the contents of f0-f5.
*                    (a4,a5) is left unchanged.
*
*******************************************************************************

flpt_horner move.l (a6)+,movf_m_f1(a0)  first coefficient result in (f1,f0)
	 move.l  (a6)+,movf_m_f0(a0)
	 movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
fhorloop    tst.w   mull_f4_f0(a0)         w * previous result
	    movem.l bogus4(a0),d4-d5       bogus reads and get error flag
	    move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	    move.l  (a6)+,movf_m_f2(a0)
	    tst.w   addl_f2_f0(a0)         add coefficient to previous result
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    subq.w  #1,d0                  see if done
	    bne.s   fhorloop
fhordone rts


flpt_hornera  movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
	 tst.w   movl_f4_f0(a0)         w is also first partial result
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag

fhorlopa move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	 move.l  (a6)+,movf_m_f2(a0)
	 tst.w   addl_f2_f0(a0)         previous result + coefficient
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	 subq.w  #1,d0                  see if done
	 beq.s   fhordone
	    tst.w  mull_f4_f0(a0)          else result*w
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    bra.s   fhorlopa
	 page
*******************************************************************************
*
*       Procedure  : flpt_error
*
*       Description: Determine the type of error that has just happened in the
*                    16081 FPU and generate the appropriate Pascal Workstation
*                    ESCAPECODE.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*
*       Registers  : d0         - the 16081 FPU status register
*                    a0         - address of the floating point card
*
*       Result     : An ESCAPE is generated.
*
*       References : flpt_cardaddr, err_overflow, err_underflow,
*                    err_divzero, err_miscel
*
*       Miscel     : A 'miscellaneous floating point hardware error' escape
*                    is generated for things other than underflow, overflow,
*                    and divide-by-zero.
*
*******************************************************************************

flpt_error  equ  *                         the floating point error handler
	moveq   #flpt_extracttrap,d0       extract the TT field
	and.l   sfsr_m_m+flpt_cardaddr,d0  the floating point status register
	cmpi.w  #flpt_under,d0
	beq     err_underflow
	cmpi.w  #flpt_over,d0
	beq     err_overflow
	cmpi.w  #flpt_divzero,d0
	beq     err_divzero
	bra     err_miscel              miscellaneous floating point error
	page
*******************************************************************************
*
*       Procedure  : flpt_reset
*
*       Description: Reset the floating point card, and initialize the 16081
*                    FPU with a rounding mode of round-to-even and set the
*                    underflow enable trap.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*                  : 3.2  02/19/87 DRAGON support       SFB
*
*       Registers  : d0,d1           - scratch
*
*       Parameters : None
*
*       References : flpt_cardaddr
*
*******************************************************************************

flpt_reset equ *
	lea     flpt_cardaddr,a0                point to the card
	cmpi.b  #flpt_card_id,flpt_id(a0)       see if it has correct ID SFB
	beq     is_float_card                   if so, continue SFB
	move.w  #-12,SYSGLOBALS-2(a5)           else escapecode:=buserror SFB
	trap    #10                             and escape(escapecode) SFB
is_float_card equ *                             SFB
	move.b  #1,flpt_id(a0)                  enable the card
	move.l  #flpt_initmask,lfsr_m_m(a0)     UEN; RM to nearest
	rts
	page
*******************************************************************************
*
*       Procedure  : relbcd
*
*       Description: Convert a real number into a decimal string.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*
*       Parameters : (d0,d1)    - real argument to be converted
*                    a0         - address of the result
*                    d7         - number of digits wanted
*
*       Registers  : (d2,d3)    - value from table
*                    d4         - estimator
*                    d5         - index into table
*                    d6         - scratch
*                    d7         - number of digits to return
*                    a1         - table addresses/ local storage
*
*       Result     : The result is returned through (a0).
*
*       Error(s)   : Invalid IEEE real numbers
*
*       References : tb_pwtt, tb_auxpt, tb_bin, rmul, err_illnumbr
*
*******************************************************************************

*
*  Real to bcd convert begins here. Determine sign of result.
*
relbcd  cmp.l   #minuszero,d0  check for a -0
	bne.s   relb_1         branch if not possible
	   tst.l    d1            must be a zero here!
	   bne      err_illnumbr
	      move.w  #1,(a0)+       store negative signed result
	      clr.w   (a0)+          and return a zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts
relb_1  tst.l   d0             check for zero
	bne.s   bcd_nzer       non-zero, but could still be illegal
	   tst.l   d1
	   bne     err_illnumbr
	      clr.l   (a0)+          return zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts                    fix this up if unpacked
bcd_nzer bmi.s   bcd_neg
	    clr.w   (a0)+          store positive sign result
	    bra.s   rbcd_1
bcd_neg  move.w  #1,(a0)+       store negative signed result
	 bclr    #31,d0         and clear sign
rbcd_1   move.l  d0,d4          scratch register
	 swap    d4             get exponent
	 and.w   #$7ff0,d4      mask off fraction and sign
*
*  Check for valid exponent.
*
	 lsr.w   #4,d4          right justify
	 beq     err_illnumbr   exponent too small?
	 sub.w   #1023,d4       remove bias
	 cmp.w   #1023,d4       exponent too large?
	 bgt     err_illnumbr
*
*  Compute the estimator E = TRUNC(log10(2) * exponent). Computation is done
*  with a fixed point multiply.
*
	 move.w  #$4d10,d5      log10(2) = 0.4d104... (hex)
	 tst.w   d4             check the sign of the base 2 exponent
	 bge.s   mul1           d5 as correct estimator
	    addq.w   #1,d5         negative exponents require 0.4d11      bug69
mul1     muls    d5,d4
	 swap    d4             remove fractional part of the result
	 addq.w  #1,d4          1 larger for the algorithm
*
	 move.w  d4,d5          copy into d5 for table indexing
	 add.w   #64,d5         add 64 for biasing to positive
	 bmi.s   rbcd_3         test for  -64 <= E <= +64
	    cmp.w   #128,d5
	    ble.s   rbcd_2         branch if only one multiply necessary
*
*  Map the number to be converted into the range (10^-64,10^64) using
*  an additional floating multiply.
*
rbcd_3   move.w  d4,d5
	 asr.w   #6,d5          estimator div 64
	 bpl.s   div_fix1       branch if no fixup necessary
	    addq.w  #1,d5          to keep mod and div correct
div_fix1 neg.w   d5             form address of reciprocal
	 addq.w  #4,d5          bias to the positive
	 asl.w   #3,d5          * 8 (bytes per real)
	 lea     tb_auxpt,a1    address of 10^(N*64) table
	 move.l  0(a1,d5.w),d2  get real from table
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          save estimator
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
	 move.w  a1,d4          restore estimator
	 move.w  d4,d5          calculate index for next operation
	 asr.w   #6,d5          estmator div 64
	 bpl.s   div_fix2
	    addq.w  #1,d5          to keep mod consistent with the div
div_fix2 asl.w   #6,d5          calculating estimator mod 64
	 neg.w   d5
	 add.w   d4,d5
	 add.w   #64,d5         bias to positive
*
*  Number is in appropriate range. Use estimator as an index to see
*  if the number is in the correct decade. If they are in the same decade,
*  modify the offset to point to the next larger decade so the map will work.
*
rbcd_2   asl.w   #3,d5          convert logical index to physical
	 lea     tb_pwtt,a1     address of table
	 move.l  0(a1,d5.w),d2  get high order entry
	 cmp.l   d2,d0          compare high order parts
	 blt.s   adjes          branch if table entry will work in the map
	 bgt.s   not_adj        branch if must retrieve the next table entry
	    move.l  4(a1,d5.w),d3  tops are equal; compare low order parts
	    cmp.l   d3,d1          must be unsigned compare!
	    bcs.s   adjes          branch if low (if carry is set, must be low)
not_adj        addq.w  #8,d5          adjust index to next entry
	       bra.s   bcmul          so number will map into correct range
*
*  Map the number into the range [.1,1). If the number to be converted is a
*  power of ten, final real result may be 1 or 2 bits less than .1 because of
*  the rounded table entry and the inexact real multiply. This condition is
*  checked for and the correct BCD number is returned.
*
*  If the number to be converted is a power of ten, the map may also produce a
*  value of 1. This condition is also checked for.
*
adjes    subq.w  #1,d4          adjust exponent estimator (reach only if lt ! )
bcmul    sub.w  #512,d5         find complement table entry
	 neg.w   d5
	 add.w   #512,d5
	 move.l  0(a1,d5.w),d2  fetch value for conversion
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          estimator here to stay in a1 !!
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
*
*  Test for the result being less than 0.1
*
	 addq.w  #1,a1          adjust the exponent
	 cmp.l   #$3fb99999,d0  top part of 0.1
	 bgt.s   real_c1        branch if (d0,d1) > .1
	    cmp.l   #$9999999a,d1  tops are = ; must check the bottom parts
	    bcc.s   real_c1        cc implies greater than or equal to
	       move.l  #$10000000,(a0)+ else return bcd value of .1
	       clr.l   (a0)+          return 16 digits (faster than checking d7)
	       move.w  a1,(a0)        place exp into the bcd buffer
	       rts
*
*  Check for the converted number being exactly one.
*
real_c1  cmp.l   #$3ff00000,d0  check for (d0,d1) = 1 = (3ff00000 00000000)
	 bne.s   real_c2        branch if ok
	    move.l  #$10000000,(a0)+ else return bcd value of 1
	    clr.l   (a0)+          return 16 digits (faster than checking d7)
	    addq.w  #1,a1          boundary condition, so another adjust
	    move.w  a1,(a0)        place into the bcd buffer
	    rts
*
*  Fix up result so that implied decimal point is after bit #23 in d0. Hence bit
*  numbers 24/31 will contain the 2 decimal digits after each multiply by 100.
*
real_c2  move.l  d0,d6          extract exponent into d6
	 swap    d6
	 lsr.w   #4,d6
	 sub.w   #1023-4,d6     compute the number of left shifts
	 swap    d0
	 and.w   #$f,d0
	 or.w    #$10,d0        put in hiden one
	 swap    d0
	 tst.b   d6
	 beq.s   finish
lpten       add.l   d1,d1          loop to shift (at most 4 shifts)
	    addx.l  d0,d0
	    subq.b  #1,d6
	    bne.s   lpten
*
*  Extract the correct number of digits (as specified by d7). One extra digit
*  is returned for the purposes of rounding.
*
finish   move.w  a1,8(a0)       place exponent in memory first
	 lea     tb_bin,a1      address of binary to double bcd table
	 bgt.s   fin_1          check for improper number of digits
maxnum      moveq   #15,d7         boundary condition
	    bra.s   lp16m          get all the digits
fin_1    cmp.w   #16,d7         check if wants all the digits
	 bge.s   maxnum         branch if set counter to maximum amount
*
	 ror.b   #1,d7          determine if odd or even number wanted
	 bcs.s   oddnum         branch if odd number wanted
	    rol.b   #1,d7          even number wanted - adjust counter
	    addq.w  #1,d7
	    bra.s   lp16m
oddnum   rol.b   #1,d7          restore odd number of digits
*
lp16m    move.l  d0,d2          multiply by 100 by shift and add
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 move.l  d0,d2
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 swap    d0             extract top 8 bits for conversion
	 move.w  d0,d3
	 lsr.w   #8,d3
	 and.w   #$00ff,d0      remove top 8 bits from conversion product
	 swap    d0
	 move.b  0(a1,d3.w),(a0)+ store in result area
	 subq.w  #2,d7          and loop (2 digits per loop)
	 bpl.s   lp16m          until gotten correct number of digits
	 rts
	 page
*******************************************************************************
*
*       Procedure  : bcdrel
*
*       Description: Convert a bcd number into a real number.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : a0         - address of the bcd number
*
*       Registers  : a1         - address of tables
*                    d2-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Decimal strings too large or too small.
*
*       References : rmul, err_impvalue
*                    tb_pwt, tb_pwt4, tb_pwt8, tb_auxpt, tb_bcd
*
*******************************************************************************

*
*  Only eight digits to convert so do it fast.
*
bcd8     mulu    #10000,d0
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d0          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d0          last add for fraction
	 addq.l  #4,a0          point at bcd exponent
	 moveq   #0,d1          shift result right 6 places
	 move.w  d0,d1          across d0,d1 pair
	 lsr.l   #6,d0
	 ror.l   #6,d1
	 clr.w   d1
	 move.l  d0,d6          form index for normalizing
	 swap d6
	 and.w   #$1e,d6        look at bits 20, 19, 18, and 17
	 move.w  pn_tb_4(d6.w),d6 lookup shift value
	 move.w  #1023+26-1,d7  exponent value if normalized
	 sub.w   d6,d7          subtract # of shifts required
	 neg.w   d6             computed goto for normalizing
	 addq    #4,d6
	 asl.w   #2,d6
	 jmp     shiftr8(d6.w)
shiftr8  add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 4
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 3
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 2
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 1
	 asl.w   #4,d7          shift exponent into position
	 swap    d7
	 add.l   d7,d0          add to fraction, removing hidden 1
	 lea     tb_pwt8,a1     address of table used for 8 digit convert
	 bra     fractsgn       determine sign and finish conversion
*
*  Table for number of normalization shifts versus value.
*  It must be in this location for short mode addressing.
*
pn_tb_4  dc.w    4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0

*******************************************************************************
*
*  Only four digits (8 at most) to convert so do it extremely fast.
*
bcd4     clr.w   d0
	 move.b  (a0)+,d0       get first two digits
	 move.b  0(a1,d0.w),d0  lookup binary value
	 mulu    #100,d0        weight by 100
	 move.b  (a0)+,d7       get second two digits
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.w   d7,d0
	 tst.w   (a0)           four more digits?
	 bne     bcd8           branch only if 4 more digits
	    addq.l  #6,a0          point at exponent
	    moveq   #0,d1          if four digits then low order real =0
	    asl.l   #7,d0          shift by at least 7 to post normalize
	    move.l  d0,d6          form an index
	    swap    d6             for post normalization
	    and.w   #$1e,d6        look at bits 20,19,18, and 17
	    move.w  pn_tb_4(d6.w),d6 lookup shift value
	    asl.l   d6,d0          normalize real
	    move.w  #1023+13-1,d7  form exponent
	    sub.w   d6,d7          subtract amount normalized
	    asl.w   #4,d7          align into position
	    swap    d7
	    add.l   d7,d0          merge into fraction
	    lea     tb_pwt4,a1     address of table for 4 digit convert
	    bra     fractsgn

*******************************************************************************
*
*  BCD to real conversion begins here.
*
bcdrel   addq.l  #2,a0          skip over sign
*
*  Convert first eight bcd digits to binary and store in d2.
*
	 tst.b   (a0)           check for zero (remember, must be normalized!)
	 bne.s   continue       continue if non-zero
	    moveq   #0,d0          else return a value of 0
	    move.l  d0,d1
	    rts
continue lea     tb_bcd,a1      address of 2 digit bcd to binary table
	 moveq   #0,d3
	 moveq   #0,d7
	 moveq   #0,d2
	 tst.l   4(a0)          check for 8 or less digits
	 beq.s   bcd4
	 move.b  (a0)+,d2       fetch first bcd digit pair
	 move.b  0(a1,d2.w),d2  lookup its binary value
	 mulu    #62500,d2      multiply by 1,000,000
	 asl.l   #4,d2          (62,500*16)
	 move.b  (a0)+,d7       fetch second pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d2          add to sum
*
*  Convert bottom eight bcd digits and store in d3.
*
	 move.b  (a0)+,d3       fetch fifth bcd digit pair
	 move.b  0(a1,d3.w),d3  lookup its binary value
	 mulu    #62500,d3      multiply by 1,000,000
	 asl.l   #4,d3          (62,500*16)
	 move.b  (a0)+,d7       fetch sixth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch seventh pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch eighth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d3          add to sum
*
*  Multiply high order part by 1,000,000 and add low order part
*  1,000,000=$5f5e100. Result=(((hi * 5f5e) * $1000) + (hi * $100)) + lo.
*
	 moveq   #0,d4
	 move.w  d2,d1
	 mulu    #$5f5e,d1      hi.word(lower) * 5f5e
	 move.l  d2,d0
	 swap    d0
	 mulu    #$5f5e,d0      hi.word(upper) * 5f5e
	 swap    d1
	 move.w  d1,d4
	 clr.w   d1
	 add.l   d4,d0
	 move.w  d0,d4
	 lsr.l   #4,d0          multiply by $1000 by shifting
	 lsr.l   #4,d1
	 ror.l   #4,d4
	 clr.w   d4
	 or.l    d4,d1
	 move.l  d2,d4
	 clr.w   d4
	 swap    d4
	 lsr.w   #8,d4          multiply hi by $100 by shifting
	 lsl.l   #8,d2
	 add.l   d2,d1          add to previous result
	 addx.l  d4,d0
	 add.l   d3,d1          add in conversion from lower 8 digits
	 bcc.s   bcdr_nz
	    addq.l  #1,d0
*
*  Use jump table for post normalization and exponent location.
*
bcdr_nz  move.l  d0,d6
	 swap    d6             get upper 16 bits of fraction
	 and.w   #$3e,d6        mask off all but top 5 bits (17-21)
	 move.w  eval_exp(d6.w),d7 look up exponent
	 jmp     pn_table(d6.w)
*
*  Exponent value table for converted bcd integer.
*  1023 (bias) + 52 (size of integer) - #postnorm shifts
*  -1 (gets rid of hidden one) all times 16 to bit align.
*
eval_exp dc.w    17120
	 dc.w    17136
	 dc.w    17152
	 dc.w    17152
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17184,17184,17184,17184
	 dc.w    17184,17184,17184,17184
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
pn_table bra.s   pn_4
	 bra.s   pn_3
	 bra.s   pn_2
	 bra.s   pn_2
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 nop                    must be there; can't branch to next instruction!
*
pn_m1    lsr.l   #1,d0          16 digit bcd number was too large
	 roxr.l  #1,d1          and so overflowed requiring a shift
	 bra.s   pn_done        to the right and dumping of one bit
*
pn_4     add.l   d1,d1
	 addx.l  d0,d0
pn_3     add.l   d1,d1
	 addx.l  d0,d0
pn_2     add.l   d1,d1
	 addx.l  d0,d0
pn_1     add.l   d1,d1
	 addx.l  d0,d0
pn_0     equ     *
pn_done  swap    d7             insert exponent
	 add.l   d7,d0          automatically removes hidden one
	 lea     tb_pwt,a1      address of primary powers of ten table
*
*  Check sign of bcd number.
*
fractsgn tst.w   -10(a0)        test bcd sign
	 beq.s   firfl
	    bset    #31,d0         set sign bit if negative
*
*  Fetch exponent, and test for proper range.
*
firfl    move.w  (a0),d3        get binary exponent
	 cmp.w   #-309,d3
	 blt     err_impvalue   number too small
	 cmp.w   #309,d3
	 bgt     err_impvalue   number too large
*
*  Check for one or two multiplies.
*
	 move.w  d3,d6
	 add.w   #64,d6         bias to the positive
	 bmi.s   bcdr_3         E<-64?
	 cmp.w   #128,d6        E>64?
	 bgt.s   bcdr_3         must do 2 multiplies, return here later
bcdr_4      asl.w   #3,d6          convert logical to physical index
	    move.l  0(a1,d6.w),d2  lookup values
	    move.l  4(a1,d6.w),d3
	       move.l  sysglobals-10(a5),-(sp) TRY, could get over or underflow
	       pea     improper       address for the possible ESCAPE
	       move.l  sp,sysglobals-10(a5)
	       bsr     rmul           do the operation
	       addq.l  #4,sp          remove ESCAPE address
	       move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	    rts
*
*  Exponent > abs(64).
*
bcdr_3   move.w  d3,-(sp)       save exponent for later
	 asr.w   #6,d3          div 64
	 bpl.s   divfix1        this is Paul Beiser's patented DIV
	    addq.w  #1,d3
divfix1  addq.w  #4,d3          bias to the positive
	 asl.w   #3,d3          change logical to physical index
	 lea     tb_auxpt,a0       address of secondary table
	 move.l  0(a0,d3.w),d2
	 move.l  4(a0,d3.w),d3  fetch value
	 bsr     rmul           do the operation
	 move.w  (sp)+,d6       restore exponent
	 move.w  d6,d3          find exponent mod 64
	 asr.w   #6,d3
	 bpl.s   divfix2        thank you Paul
	    addq.w  #1,d3
divfix2  asl.w   #6,d3
	 sub.w   d3,d6
	 add.w   #64,d6         bias to the positive
	 bra     bcdr_4         one more multiply to do
*
*  Either real multiply generated an ESCAPE or error detected earlier.
*  Generate the ESCAPE with the correct error code.
*
improper move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 bra     err_impvalue               improper value error
	 page
*******************************************************************************
*
*       Procedure  : flpt_sin / flpt_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a1         - flag for either sin/cos
*                    a0         - address of the floating point card
*                    -(sp)      - sign of the result
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : flpt_horner, compare, cff_sin, flpt_cardaddr, rellnt
*                    err_trigerr
*
*******************************************************************************

flpt_sin move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 suba.w  a1,a1                  set flag for in the sin routine
	 move.l  d1,movf_m_f0(a0)       (f1,f0) <- x
	 move.l  d0,movf_m_f1(a0)
	 bmi.s   f@@step2neg             branch if set sgn flag to negative
	    move.w  #1,-(sp)               set sgn flag to positive
	    bra.s   f@@sincs9
f@@step2neg move.w  #-1,-(sp)            sgn flag negative
	 cmp.l    #minuszero,d0         check for a -0
	 bne.s    stx@@3                 branch if not a -0
	    move.w  #1,(sp)                else change sign to +
stx@@3    tst.w   absl_f0_f0(a0)         make (f1,f0) positive
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
f@@sincs9 tst.w   movl_f0_f2(a0)         (f2,f3) <- abs(x) = y
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 bra.s   f@@sincos               (f1,f0) <- abs(x)
*
*  Entry point for the cosine routine.
*
flpt_cos move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 moveq   #1,d3                  can't move immediate to A register
	 movea.w d3,a1                  set flag for in the cos routine
	 move.l  d1,movf_m_f0(a0)       (f0,f1) <- x
	 move.l  d0,movf_m_f1(a0)
	 bne.s   f@@cos_1                if non-zero continue
f@@cosret1   move.l  #$3ff00000,d0          else return 1 as the result
	    moveq   #0,d1
	    bra     f@@done                 (d0,d1) <- 1;
f@@cos_1  cmp.l   #minuszero,d0          check for a -0
	 beq.s   f@@cosret1
	 move.w  #1,-(sp)               set sgn flag to one
	 tst.w   absl_f0_f0(a0)         (f1,f0) <- abs(x)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ff921fb,movf_m_f3(a0)    pi/2
	 move.l  #$54442d18,movf_m_f2(a0)
	 tst.w   addl_f0_f2(a0)         (f2,f3) <- y = abs(x) + pi/2
	 movem.l bogus4(a0),d4-d5
*
*  Common point for both the sine and cosine routines.
*  (f1,f0) <- abs(x), (f3,f2) <- y
*
f@@sincos move.l  movf_f3_m(a0),d0       get y
	 move.l  movf_f2_m(a0),d1
	 move.l  #$41b1c583,d2          check argument not too large
	 move.l  #$1a000000,d3          ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr             branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,movf_m_f5(a0)  compute y * 1/pi
	 move.l  #$6dc9c883,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f5,f4) <- y*1/pi
	 movem.l bogus4(a0),d4-d5
	 btst    #q,status(a0)          see if had underflow
	 beq     f@@sin34                continue if no underflow
	    move.l  #0,movf_m_f5(a0)       else set result to 0
	    move.l  #0,movf_m_f4(a0)       and continue
f@@sin34  move.l  movf_f5_m(a0),d0       get the result
	 move.l  movf_f4_m(a0),d1
	 bsr     rellnt                 convert to a 32 bit integer
	 move.w  d0,d7                  scratch register
	 lsr.w   #1,d7                  determine if even or odd
	 bcc.s   f@@step8                branch if even
	    neg.w   (sp)                   sgn <- -sgn
f@@step8  move.l  d0,movil_m_f4(a0)      (f5,f4) <- xn (converted d0 to real)
	 movem.l bogus4(a0),d4-d5
*
*  See if adjustment necessary to xn. At this stage,
*  (f1,f0) <- abs(x), (f3,f2) <- y, and (f5,f4) <- xn.
*
	 move.w  a1,d6                  for the check
	 beq.s   f@@step10               branch if sin wanted
	    move.l  #$bfe00000,movf_m_f7(a0)  else adjust xn
	    move.l  #0,movf_m_f6(a0)          by -1/2
	    tst.w   addl_f6_f4(a0)         (f5,f4) <- xn = xn - 0.5
	    movem.l bogus4(a0),d4-d5
*
*  Compute the reduced argument f.
*
f@@step10 move.l  #$c0092200,movf_m_f7(a0)  get constant -c1
	 move.l  #0,movf_m_f6(a0)       (f7,f6) <- -c1
	 tst.w   mull_f4_f6(a0)         (f7,f6) <- -xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- abs(x) - xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ee2aeef,movf_m_f7(a0) (f7,f6) <- c2
	 move.l  #$4b9ee59e,movf_m_f6(a0)
	 tst.w   mull_f6_f4(a0)         (f5,f4) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f1,f0) <- f = (abs(x) - xn*c1) + xn*c2
	 movem.l bogus4(a0),d4-d5
*
*  Check size of reduced argument. If too small, return f as result else
*  compute g and continue. At this point, (f1,f0) <- f.
*
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  d0,d6                  save the top part of f
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   f@@step12               branch if f not too small
	    move.l  d6,d0                  else return f as the answer
	    bra.s   f@@sign_tst             check for the correct sign
f@@step12 tst.w   movl_f0_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         g <- f*f
	 movem.l bogus4(a0),d4-d5
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result. At
*  this point, (f1,f0) <- f and (f3,f2) <- g.
*
	 movea.l movf_f3_m(a0),a4       number to be evaluated g
	 movea.l movf_f2_m(a0),a5
	 lea     cff_sin,a6             point to coefficients
	 moveq   #7,d0                  degree of polynomial
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- f (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 bsr     flpt_horner            compute p(g); result in (f1,f0)
	 movem.l a4-a5,movf_m_f3(a0)    restore g
	 tst.w   mull_f0_f2(a0)         (f3,f2) <- g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f2(a0)         (f3,f2) <- f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f6(a0)         (f6,f7) <- f + f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f7_m(a0),d0       (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
*
f@@sign_tst tst.w (sp)+          retrieve sgn
	 bpl.s   f@@done         branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
f@@done   movem.l (sp)+,a5-a6     restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_sin / soft_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : radd, rmul, soft_horner, err_trigerr
*                    compare, lntrel, rellnt, cff_sin, sysglobals
*
*******************************************************************************

soft_sin move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bmi.s   step2neg       branch if set sgn flag to negative
	    move.w  #1,-(sp)       set sgn flag to positive
	    movea.l d0,a0          (a0,a1) <- x
	    movea.l d1,a1
	    bra.s   sincos         common point for both routines
step2neg move.w  #-1,-(sp)      sgn flag negative
	 cmp.l    #minuszero,d0 check for a -0
	 bne.s    sty@@3         branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sty@@3    bclr    #31,d0
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 bra.s   sincos
*
*  Entry point for the cosine routine.
*
soft_cos move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bne.s   cos_1          if non-zero continue
cosret1     move.l  #$3ff00000,d0 else return 1 as the result
	    moveq   #0,d1
	    bra     done          (d0,d1) <- 1;
cos_1    cmp.l   #minuszero,d0  check for -0
	 beq.s   cosret1
	 move.w  #1,-(sp)       set sgn flag to one
	 bclr    #31,d0         abs(x)
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 move.l  #$3ff921fb,d2  pi/2
	 move.l  #$54442d18,d3
	 bsr     radd           y = abs(x) + pi/2
*
*  Common point for both the sine and cosine routines.
*
sincos   movea.l d0,a2          (a2,a3) <- y
	 movea.l d1,a3
	 move.l  #$41b1c583,d2  check argument not too large
	 move.l  #$1a000000,d3  ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr    branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,d2  compute y * 1/pi
	 move.l  #$6dc9c883,d3
	    move.l  sysglobals-10(a5),-(sp)
	    pea     recover        in case of underflow
	    move.l  sp,sysglobals-10(a5)     new try block
	    bsr     rmul
	    addq.l  #4,sp          remove error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 bsr     rellnt         round result to a 32 bit integer
	 move.w  d0,d7          scratch register
	 lsr.w   #1,d7          determine if even or odd
	 bcc.s   step8          branch if even
	    neg.w   (sp)           sgn <- -sgn
step8    bsr     lntrel         (d0,d1) <- xn
	 movea.l a2,a4          (a4,a5) <- y
	 movea.l a3,a5
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  See if adjustment necessary to xn.
*
	 move.l  a0,d0          retrieve abs(x)
	 move.l  a1,d1
	 move.l  a4,d2          retrieve y
	 move.l  a5,d3
	 bsr     compare        check abs(x) = y
	 beq.s   step10a        branch if sin wanted
	    move.l  a2,d0          else adjust xn
	    move.l  a3,d1
	    move.l  #$bfe00000,d2  -1/2
	    moveq   #0,d3
	    bsr     radd           xn <- xn - 0.5
	    movea.l d0,a2          (a2,a3) <- xn
	    movea.l d1,a3
	    bra.s   step10
step10a  move.l  a2,d0          load up (d0,d1) with xn
	 move.l  a3,d1
*
*  Compute the reduced argument f.
*
step10   move.l  #$c0092200,d2  get constant -c1
	 moveq   #0,d3          (d0,d1) already has xn
	 bsr     rmul           -xn*c1
	 move.l  a0,d2          get abs(x)
	 move.l  a1,d3
	 bsr     radd           abs(x) - xn*c1
	 movea.l d0,a0          save in (a0,a1)
	 movea.l d1,a1          abs(x) no longer needed
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3ee2aeef,d2  c2
	 move.l  #$4b9ee59e,d3
	 bsr     rmul           xn*c2
	 move.l  a0,d2          retrieve intermediate result
	 move.l  a1,d3
	 bsr     radd           (abs(x) - xn*c1) + xn*c2
	 movea.l d0,a0          (a0,a1) <- f
	 movea.l d1,a1
*
*  Check size of reduced argument. If too small, return
*  f as result else compute g and continue.
*
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   step12         branch if f not too small
	    move.l  a0,d0          else return f as the answer
	    bra.s   sign_tst       still must check for the correct sign
step12   move.l  a0,d0          restore top part of f
	 move.l  d0,d2
	 move.l  d1,d3
	 bsr     rmul           g <- f*f
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result.
*
	 movea.l d0,a4          number to be evaluated
	 movea.l d1,a5
	 lea     cff_sin,a6     point to coefficients
	 moveq   #7,d0          degree of polynomial
	 bsr     soft_horner    compute p(g)
	 move.l  a4,d2          retrieve g
	 move.l  a5,d3
	 bsr     rmul           g*p(g)
	 move.l  a0,d2          retrieve f
	 move.l  a1,d3
	 bsr     rmul           f*g*p(g)
	 move.l  a0,d2          retrieve f again
	 move.l  a1,d3
	 bsr     radd           f + f*g*p(g)
*
sign_tst tst.w   (sp)+          retrieve sgn
	 bpl.s   done           branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
done     movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
*
*  Argument reduction caused an underflow error, so the sine routine
*  must have been called. Therefore, return the original argument as the
*  result.
*
recover  move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 move.l  a0,d0          get original argument
	 move.l  a1,d1
	 bra.s   sign_tst       determine the sign of original argument
	 page
*******************************************************************************
*
*       Procedure  : flpt_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : flpt_horner, rndnear, rellnt, adx, cff_expp, cff_expq
*                    compare, flpt_cardaddr, err_overflow, err_underflow
*
*******************************************************************************

flpt_exp move.l  4(sp),d0               get the operand
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow          underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6                  save top part of operand for later
	 bclr    #31,d0                 get the absolute value of the operand
	 move.l  #$3c900000,d2          threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   f@@exp_11               branch if operand in range
	    move.l  #$3ff00000,d0          else return answer of 1.0
	    moveq   #0,d1
	    bra     f@@donee1               place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
f@@exp_11 move.l  d6,d0                  restore top part of operand
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- x
	 move.l  #$3ff71547,movf_m_f3(a0)   (f2,f3) <- 1/ln(2)
	 move.l  #$652b82fe,movf_m_f2(a0)
	 tst.w   mull_f0_f2(a0)         (f2,f3) <- x * 1/ln(2)
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 move.l movf_f3_m(a0),d0        retrieve x * 1/ln(2)
	 move.l movf_f2_m(a0),d1
	 bsr     rndnear                (d0,d1) <- xn (conversion to int later)
	 movem.l d0-d1,movf_m_f3(a0)    (f2,f3) <- xn
*
*  Determine g. Have (f0,f1) <- x and (f2,f3) <- xn.
*
	 move.l  #$bfe63000,movf_m_f5(a0)  -0.543 octal = c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- x + xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3f2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- (x + xn*c1) + xn*c2 = g
	 movem.l bogus4(a0),d4-d5
*
*  Have (f2,f3) <- xn and (f0,f1) <- g.
*  Save xn in (a2,a3) and compute z, p(z), and g*p(z), and q(z).
*
	 movea.l movf_f2_m(a0),a3       xn is not needed till much later
	 movea.l movf_f3_m(a0),a2
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- g (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f0_f0(a0)         (f0,f1) <- g*g = z
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f0_m(a0),a5       (a4,a5) <- z
	 movea.l movf_f1_m(a0),a4
	 lea     cff_expp,a6            point to coefficients
	 moveq   #2,d0                  degree of p
	 bsr     flpt_horner            compute p(z); result in (f0,f1)
	 tst.w   mull_f0_f6(a0)         (f6,f7) <- g * p(z)
	 movem.l bogus4(a0),d4-d5
	 lea     cff_expq,a6            point to coefficients
	 moveq   #3,d0                  degree of q
	 bsr     flpt_horner            do the evaluation; (a4,a5) still has z
*
*  Have (f0,f1) <- q(z) and (f6,f7) <- g*p(z). Compute r(g).
*
	 tst.w   subl_f6_f0(a0)         (f0,f1) <- q(z) - g*p(z)
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f6(a0)         (f6,f7) <- g*p(z) / (q(z) - g*p(g))
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f1(a0) (f0,f1) <- 1/2
	 move.l  #0,movf_m_f0(a0)
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- r(g)
	 movem.l bogus4(a0),d4-d5
*
*  Compute integer value of xn, and finish computation.
*
	 move.l  a3,d1                  retrieve xn
	 move.l  a2,d0
	 bsr     rellnt                 32 bit integer (already been rounded)
	 addq.l  #1,d0                  part of step 9 in the algorithm
	 move.l  d0,d7                  augment with r to form result
	 move.l  movf_f1_m(a0),d0       retrieve r(g) from the chip
	 move.l  movf_f0_m(a0),d1
	 bsr     adx                    r(g) and n form the result
*
*  Place result on the stack.
*
f@@donee1 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : radd, rmul, rdvd, soft_horner,
*                    compare, rndnear, rellnt, adx, cff_expp, cff_expq
*                    err_overflow, err_underflow
*
*******************************************************************************

soft_exp move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6          save top part of operand for later
	 bclr    #31,d0         get the absolute value of the operand
	 move.l  #$3c900000,d2  threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   exp_11         branch if operand in range
	    move.l  #$3ff00000,d0  else return answer of 1.0
	    moveq   #0,d1
	    bra     donee1         place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
exp_11   move.l  d6,d0          restore top part of operand and continue
	 movea.l d0,a0          (a0,a1) <- x
	 movea.l d1,a1
	 move.l  #$3ff71547,d2  1/ln(2)
	 move.l  #$652b82fe,d3
	 bsr     rmul           (d0,d1) <- x * 1/ln(2)
	 bsr     rndnear        (d0,d1) <- xn (conversion to integer later)
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  Determine g.
*
	 move.l  #$bfe63000,d2  -0.543 octal = c1
	 moveq   #0,d3
	 bsr     rmul           xn*c1
	 move.l  a0,d2          (d2,d3) <- x
	 move.l  a1,d3          (a0,a1) is now freed
	 bsr     radd           x + xn*c1
	 movea.l d0,a0          (a0,a1) <- x + xn*c1
	 movea.l d1,a1
	 move.l  a2,d0          (d0,d1) <- xn
	 move.l  a3,d1
	 move.l  #$3f2bd010,d2  get c2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           (d0,d1) <- xn*c2
	 move.l  a0,d2          get previous intermediate result
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <- (x + xn*c1) + xn*c2
*
*  Compute z, p(z), and g*p(z), and q(z).
*
	 movea.l d0,a0          save away g
	 movea.l d1,a1
	 move.l  d0,d2          compute z = g*g
	 move.l  d1,d3
	 bsr     rmul           (d0,d1) <- z
	 movem.l d0-d1,-(sp)    save z away
*
	 movea.l d0,a4          compute p(z)
	 movea.l d1,a5
	 lea     cff_expp,a6    point to coefficients
	 moveq   #2,d0          degree of p
	 bsr     soft_horner    do the evaluation
	 move.l  a0,d2          restore g
	 move.l  a1,d3
	 bsr     rmul           g*p(z)
	 movea.l d0,a0          (a0,a1) <- g*p(z)
	 movea.l d1,a1
*
	 movem.l (sp)+,a4-a5    restore z
	 lea     cff_expq,a6    point to coefficients
	 moveq   #3,d0          degree of q
	 bsr     soft_horner    do the evaluation
*
*  Compute r(g).
*
	 move.l a0,d2           (d2,d3) <- g*p(z)
	 move.l a1,d3
	 bsr    rsbt            (d0,d1) <- q(z) - g*p(z)
	 move.l d0,d2           to be used as divisor
	 move.l d1,d3
	 move.l a0,d0           (d0,d1) <- g*p(z)
	 move.l a1,d1
	 bsr    rdvd            (d0,d1) <- g*p(z) / (q(z)-g*p(z))
	 move.l #$3fe00000,d2   add 1/2
	 moveq  #0,d3
	 bsr    radd            (d0,d1) <- r(g)
*
*  Compute integer value of xn, and finish computation.
*
	 movea.l d0,a0          save r(g)
	 movea.l d1,a1
	 move.l  a2,d0          retrieve xn
	 move.l  a3,d1
	 bsr     rellnt         32 bit integer (already been rounded)
	 addq.l  #1,d0          part of step 9 in the algorithm
	 move.l  d0,d7          augment with r to form result
	 move.l  a0,d0          (d0,d1) <- r(g)
	 move.l  a1,d1
	 bsr     adx            r and n form the result
*
*  Place result on the stack.
*
donee1   movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - exponent of the argument
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : cff_expp, cff_expq, flpt_horner, flpt_hornera,
*                    flpt_cardaddr, intxp, setxp, err_logerr
*
*******************************************************************************

flpt_ln  move.l  4(sp),d0
	 ble     err_logerr             branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 bsr     intxp                  extract exponent; operand in (d0,d1)
	 movea.w d7,a1                  place exponent temporarily into a1
	 clr.w   d7                     map number into range [0.5,1)
	 bsr     setxp                  compute value of f
	 move.w  a1,d7                  save exponent in d7
	 movea.l d0,a2                  save f in (a2,a3)
	 movea.l d1,a3
	 move.l  #$bfe00000,d2          combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 movem.l d0-d3,movf_m_f3(a0)    (f0,f1) <- -0.5;  (f2,f3) <- f
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- f - 0.5 = znum
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,d0          (d0,d1) <-  0.5
	 moveq   #0,d1
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a2          upper part of constant sqrt(1/2)
	 bgt.s   f@@stepp10
	 blt.s   f@@step9
	    cmpa.l  #$667f3bcd,a3
	    bhi.s   f@@stepp10
f@@step9        movem.l d0-d1,movf_m_f3(a0) (f2,f3) <- 0.5
	       tst.w   movl_f2_f4(a0)      (f4,f5) <- 0.5
	       movem.l bogus4(a0),d4-d5    wait for the chip to finish
	       tst.w   mull_f0_f2(a0)      (f2,f3) <- znum * 0.5
	       movem.l bogus4(a0),d4-d5
	       tst.w   addl_f4_f2(a0)      (f2,f3) <- znum * 0.5 + 0.5
	       movem.l bogus4(a0),d4-d5
	       subq.w  #1,d7               don't forget to adjust exponent!
	       bra.s   f@@step11            (f2,f3) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
f@@stepp10 movem.l d0-d1,movf_m_f3(a0)   first, subtract 0.5 from znum
	 tst.w   subl_f2_f0(a0)         (f0,f1) <- znum - 0.5
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 movem.l a2-a3,movf_m_f5(a0)    (f4,f5) <- f
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- f * 0.5
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f2(a0)         (f2,f3) <- 0.5 + f * 0.5
	 movem.l bogus4(a0),d4-d5
*
*   Step 11. Have (f0,f1) <- znum and (f2,f3) <- zden. First compute z and w.
*
f@@step11 tst.w   divl_f2_f0(a0)         (f0,f1) <- znum / zden = z
	 movem.l bogus4(a0),d4-d5
	 tst.w   movl_f0_f2(a0)         (f2,f3) <- z
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         (f2,f3) <- z * z = w
	 movem.l bogus4(a0),d4-d5
*
*  Evaluate A(w) and store the result in (a2,a3).
*
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- z  (untouched by horner(a))
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f3_m(a0),a4       (a4,a5) <- w
	 movea.l movf_f2_m(a0),a5
	 lea     cff_loga,a6            address of the coefficients
	 moveq   #2,d0                  degree of the polynomial
	 bsr     flpt_horner            do the polynomial evaluation
	 movea.l movf_f1_m(a0),a2       (a2,a3) <- A(w)
	 movea.l movf_f0_m(a0),a3
*
*  Evaluate B(w), with the result in (f0,f1).
*
	 lea     cff_logb,a6            address of the coefficients
	 moveq   #3,d0                  degree of the polynomial
	 bsr     flpt_hornera           remember, (a4,a5) still has w!
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)). Remember that (f6,f7) <- z,
*  (a4,a5) <- w, (a2,a3) <- A(w), and (f0,f1) <- B(w).
*
	 movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- A(w)
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 movem.l a4-a5,movf_m_f1(a0)    (f0,f1) <- w
	 tst.w   mull_f2_f0(a0)         (f0,f1) <- w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f0(a0)         (f0,f1) <- z*w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- z + z*w*A(w)*B(w) = R(z)
	 movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
	 ext.l   d7                     extend the exponent of the argument
	 move.l  d7,movil_m_f2(a0)      (f2,f3) <- xn
	 movem.l bogus4(a0),d4-d5
	 move.l  #$bf2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn * c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- xn * c2 + R(z)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe63000,movf_m_f5(a0) (f4,f5) <- c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f2(a0)         (f2,f3) <- xn * c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- xn*c2+R(z) + xn*c1
	 movem.l bogus4(a0),d4-d5
*
*  Place result on the stack and return.
*
	 move.l  movf_f1_m(a0),d0       retrieve the result
	 move.l  movf_f0_m(a0),d1
	 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)               get the result
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : radd, rmul, rdvd,
*                    soft_horner,soft_hornera, err_logerr
*                    intrel, intxp, setxp, adx, cff_loga, cff_logb
*
*******************************************************************************

soft_ln  move.l  4(sp),d0
	 ble     err_logerr     branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bsr     intxp          extract the exponent; operand in (d0,d1)
	 move.w  d7,-(sp)       place exponent into memory
	 clr.w   d7             map number into range [0.5,1)
	 bsr     setxp          compute value of f
	 movea.l d0,a0          save f in (a0,a1)
	 movea.l d1,a1
	 move.l  #$bfe00000,d2  combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 bsr     radd           znum <-- (d0,d1)
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a0  upper part of constant sqrt(1/2)
	 bgt.s   stepp10
	 blt.s   step9
	    cmpa.l  #$667f3bcd,a1
	    bhi.s   stepp10
step9          movea.l d0,a2          save away znum in (a2,a3)
	       movea.l d1,a3
	       moveq   #-1,d7         zden <-- znum * 0.5 + 0.5
	       bsr     adx            znum * 0.5
	       move.l  #$3fe00000,d2  add the 0.5
	       moveq   #0,d3
	       bsr     radd
	       subq.w  #1,(sp)        don't forget to adjust exponent!
	       bra.s   step11         (d0,d1) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
stepp10  move.l  #$bfe00000,d2  subtract 0.5
	 moveq   #0,d3
	 bsr     radd           znum correct, so now compute zden.
	 movea.l d0,a2          first, save znum away
	 movea.l d1,a3
	 moveq   #-1,d7         compute zden <-- f * 0.5 + 0.5
	 move.l  a0,d0
	 move.l  a1,d1
	 bsr     adx            f * 0.5
	 move.l  #$3fe00000,d2  add 0.5
	 moveq   #0,d3
	 bsr     radd           (d0,d1) contains zden; (a2,a3) has znum
*
*  Step 11. First compute z and w.
*
step11   move.l  d0,d2          place zden in correct registers for divide
	 move.l  d1,d3
	 move.l  a2,d0          z <-- znum / zden
	 move.l  a3,d1
	 bsr     rdvd
	 movea.l d0,a0          (a0,a1) <-- z
	 movea.l d1,a1
	 move.l  d0,d2          w <-- z * z
	 move.l  d1,d3
	 bsr     rmul
	 movea.l d0,a2          (a2,a3) <-- w
	 movea.l d1,a3
*
*  Evaluate A(w) and store the result on the stack.
*
	 movea.l d0,a4          place w in correct registers
	 movea.l d1,a5
	 lea     cff_loga,a6    address of the coefficients
	 moveq   #2,d0          degree of the polynomial
	 bsr     soft_horner    do the polynomial evaluation
	 movem.l d0-d1,-(sp)
*
*  Evaluate B(w) and leave result in (d0,d1).
*
	 movea.l a2,a4          place w in correct registers
	 movea.l a3,a5
	 lea     cff_logb,a6    address of the coefficients
	 moveq   #3,d0          degree of the polynomial
	 bsr     soft_hornera   do the polynomial evaluation
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)).
*
	 move.l  d0,d2          place B(w) in correct registers for divide
	 move.l  d1,d3
	 movem.l (sp)+,d0-d1    retrieve A(w)
	 bsr     rdvd           (d0,d1) <-- A(w)/B(w)
	 move.l  a2,d2          get w in (d2,d3)
	 move.l  a3,d3
	 bsr     rmul           (d0,d1) <-- w * A(w)/B(w)
	 move.l  a0,d2          place z in (d2,d3)
	 move.l  a1,d3
	 bsr     rmul           (d0,d1) <-- z * (w * A(w)/B(w))
	 move.l  a0,d2          (a0,a1) still has z
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <-- z + z * (w * A(w)/B(w))
	 movea.l d0,a0          (a0,a1) <-- R(z)
	 movea.l d1,a1
*
*  Finish the computation.
*
	 move.w  (sp)+,d0       get integer exponent
	 ext.l   d0
	 bsr     lntrel         convert exponent into a real
	 movea.l d0,a2          (a2,a3) <-- xn
	 movea.l d1,a3
	 move.l  #$bf2bd010,d2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           xn * c2
	 move.l  a0,d2          get R(z)
	 move.l  a1,d3
	 bsr     radd           xn * c2 + R(z)
	 movem.l d0-d1,-(sp)    save intermediate result
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3fe63000,d2
	 moveq   #0,d3
	 bsr     rmul           xn * c1
	 movem.l (sp)+,d2-d3    restore intermediate result
	 bsr     radd           (xn * c2 + R(z)) + (xn * c1)
*
*  Place result on the stack and return.
*
	 movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_sqrt
*
*       Description: Compute the square root of the numeric item on top
*                    of the stack. This algorithm is taken from the book
*                    "Software Manual for the Elementary Functions" by
*                    William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                  : 2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - original exponent of argument
*                    (f6,f7)    - f
*                    (f0,f1)    - partial results
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : intxp, setxp, adx, flpt_cardaddr, err_sqrterr
*
*******************************************************************************

flpt_sqrt move.l 8(sp),d1
	 move.l  4(sp),d0
	 bmi     errmaybe               branch if negative
	 bne.s   f@@sqrok                if non-zero, have positive number
	    rts                            else result = operand = 0
*
*  Continue with the square root.
*
f@@sqrok  lea     flpt_cardaddr,a0       point to the start of the hardware
	 bsr     intxp                  extract exponent
	 move.w  d7,d6                  save exponent
	 clr.w   d7                     new unbiased exponent
	 bsr     setxp                  (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movem.l d0-d1,movf_m_f7(a0)    f will be in (f7,f6) throughout
	 move.l  #$3fe2e297,movf_m_f1(a0) constant .59016
	 move.l  #$396d0918,movf_m_f0(a0) the rest of it
	 tst.w   mull_f6_f0(a0)         (f1,f0) <- .59016 * f
	 movem.l bogus4(a0),d4-d5       wait until the chip has finished
	 move.l  #$3fdab535,movf_m_f3(a0) constant .41731
	 move.l  #$0092ccf7,movf_m_f2(a0) the rest of it
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0
	 movem.l bogus4(a0),d4-d5
*
*  Compute z = (y0 + f/y0).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y0
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0 + f/y0 = z
	 movem.l bogus4(a0),d4-d5
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/z
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fd00000,movf_m_f5(a0) (f5,f4) <- .25
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f0(a0)         (f1,f0) <- .25*z
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/z + .25*z = y2
	 movem.l bogus4(a0),d4-d5
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/y2 + y2
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f3(a0) (f3,f2) <- .5
	 move.l  #0,movf_m_f2(a0)
	 tst.w   mull_f2_f0(a0)         (f1,f0) <- .5 * (y2 + f/y2)
	 movem.l bogus4(a0),d4-d5
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  d6,d7                  save the original exponent
	 asr.w   #1,d7                  the original exponent
	 bcc.s   f@@evenexp              branch if the exponent was even
	    move.l  #$3fe6a09e,movf_m_f3(a0) (f3,f2) <- sqrt(1/2)
	    move.l  #$667f3bcd,movf_m_f2(a0)
	    tst.w   mull_f2_f0(a0)         (f1,f0) <- (f1,f0) * sqrt(1/2)
	    movem.l bogus4(a0),d4-d5
	    addq.w  #1,d6                  (n+1) / 2 --> m
f@@evenexp asr.w  #1,d6                  adjust the old exponent
	 move.l  movf_f1_m(a0),d0       retrieve the last partial result
	 move.l  movf_f0_m(a0),d1
	 move.w  d6,d7                  place here for the adx
	 bsr     adx                    put in the result exponent
*
* Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
*
*  Negative number, so check for sqrt(-0).
*
errmaybe cmp.l   #minuszero,d0          first, check for a -0
	 bne     err_sqrterr
	    rts                            else return with -0 as the result
	 page
*******************************************************************************
*
*       Procedure  : soft_sqrt
*
*       Description: Compute the square root of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : radd, rmul, rdvd, intxp, setxp, adx, err_sqrterr
*
*******************************************************************************

soft_sqrt move.l 8(sp),d1
	 move.l 4(sp),d0
	 bmi.s   errmaybe       branch if negative
	 bne.s   sqrok          if non-zero, have positive number
	    rts                    else result = operand = 0
*
*  Continue with the square root.
*
sqrok    bsr     intxp          extract exponent
	 movea.w d7,a4          save exponent
	 clr.w   d7             new unbiased exponent
	 bsr     setxp          (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movea.l d0,a0          (a0,a1) <-- f
	 movea.l d1,a1
	 move.l  #$3fe2e297,d2  constant 0.59016
	 move.l  #$396d0918,d3
	 bsr     rmul           (d0,d1) contains first term
	 move.l  #$3fdab535,d2  constant 0.41731
	 move.l  #$0092ccf7,d3
	 bsr     radd           (d0,d1) has initial guess for y
	 movea.l d0,a2          (a2,a3) <-- y
	 movea.l d1,a3
*
*  Compute z = (y0 + f/y0).
*
	 move.l  d0,d2          (d2,d3) <-- y0
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <-- f
	 move.l  a1,d1
	 bsr     rdvd           f/y0
	 move.l  a2,d2          (d2,d3) <-- y0
	 move.l  a3,d3
	 bsr     radd           (d0,d1) <-- z = y0 + f/y0
	 movea.l d0,a2          (a2,a3) <- z
	 movea.l d1,a3
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 move.l  d0,d2          (d2,d3) <- z
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <- f
	 move.l  a1,d1
	 bsr     rdvd           f/z
	 move.l  d0,d2          (d2,d3) <- f/z
	 move.l  d1,d3
	 move.l  a2,d0          (d0,d1) <- z
	 move.l  a3,d1
	 moveq   #-2,d7         'adx' does not affect (d2,d3) = f/z
	 bsr     adx            .25*x
	 bsr     radd           y2 <-- .25*x + f/z
	 movea.l d0,a2          (a2,a3) <- y2
	 movea.l d1,a3
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 move.l  d0,d2          place y2 in divisor registers
	 move.l  d1,d3
	 move.l  a0,d0          load up the value of f; y is in (d0,d1)
	 move.l  a1,d1
	 bsr     rdvd           f/y computed; result in (d0,d1)
	 move.l  a2,d2          get y2
	 move.l  a3,d3
	 bsr     radd           y2 + f/y2 computed; result in (d0,d1)
	 moveq   #-1,d7
	 bsr     adx            y = y3 <- 0.5 * (y2 + f/y2)
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  a4,d7          get the initial exponent guess
	 asr.w   #1,d7          see if even or odd
	 bcc.s   evenexp        branch if even exponent
	    move.l  #$3fe6a09e,d2  else adjust mantissa accordingly
	    move.l  #$667f3bcd,d3  constant sqrt(1/2)
	    bsr     rmul           y <- y * sqrt(1/2)
	    move.w  a4,d7          get old exponent
	    addq.w  #1,d7          adjust it
	    asr.w   #1,d7          (n + 1) / 2  --> m
evenexp  bsr     adx            d7 has result exponent; (d0,d1) the rest
*
*  Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - n
*                    d6         - sign of the argument
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large returns an error.
*
*       References : flpt_horner, flpt_hornera, compare, cff_atnp, cff_atnq,
*                    flpt_cardaddr
*
*******************************************************************************

flpt_arctan move.l 4(sp),d0             get the argument
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       must save all the fp registers
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 move.l  d0,d6                  save the sign
	 cmp.l   #minuszero,d6          check if a -0
	 bne.s   act@@1                  branch if not a -0
	    moveq   #0,d6                  set the sign to +
act@@1    bclr    #31,d0                 f <- abs(x)
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- f
*
*  Adjust f if > 1. Note that underflow is possible if x is real large.
*  If underflowed, then the argument was real large, so return pi/2 as
*  the angle.
*
	 move.l  #$3ff00000,d2          floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   f@@invertf              branch if have to invert f
	    moveq   #0,d7                  else set n to 0
	    bra.s   f@@step7                and continue with the computation
f@@invertf movem.l d2-d3,movf_m_f3(a0)   (f2,f3) <- 1
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- 1/f
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 btst    #q,status(a0)          see if had an underflow
	 beq     f@@arc34                branch if no underflow
	    move.l  #$3ff921fb,d0          top part of pi/2
	    move.l  #$54442d18,d1          rest of result of pi/2
	    tst.l   d6                     check sign of original operand
	    bpl     f@@donee                pos arguement yields positive result
	       bset   #31,d0                  if negative, result is negative
	       bra     f@@donee                place result on stack and return
f@@arc34  tst.w   movl_f2_f0(a0)         no error, so (f0,f1) <- f = 1/f
	 movem.l bogus4(a0),d4-d5
	 moveq   #2,d7                  n <- 2
*
*  Adjust f if > 2 - sqrt(3).
*
f@@step7  move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  #$3fd12614,d2          2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   f@@steep10              branch if no more adjusting of f or n
	    addq.w  #1,d7                  step 8; first adjust n
	    move.l  #$3ffbb67a,movf_m_f3(a0) (f2,f3) <- sqrt(3)
	    move.l  #$e8584caa,movf_m_f2(a0)
	    tst.w   addl_f0_f2(a0)         (f2,f3) <- f + sqrt(3)
	    movem.l bogus4(a0),d4-d5
	    move.l  #$3fe76cf5,movf_m_f5(a0) (f4,f5) <-  sqrt(3) - 1 = a
	    move.l  #$d0b09955,movf_m_f4(a0)
	    tst.w   mull_f0_f4(a0)         (f4,f5) <- a*f
	    movem.l bogus4(a0),d4-d5
	    move.l  #$bfe00000,movf_m_f7(a0) (f6,f7) <-  -1/2
	    move.l  #0,movf_m_f6(a0)
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- a*f - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- (a*f - 1/2) - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f4_f0(a0)         (f0,f1) <- ((a*f - 1/2) - 1/2) + f
	    movem.l bogus4(a0),d4-d5
	    tst.w   divl_f2_f0(a0)         (f0,f1) <- (f0,f1)/denominator = f
	    movem.l bogus4(a0),d4-d5
*
*  Evaluate the polynomials if required. (f0,f1) <- f.
*
f@@steep10  tst.w movl_f0_f6(a0)         result must be in (f6,f7) for later
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare                is abs(f) < eps?
	 blt     f@@step15
	    tst.w   movl_f0_f2(a0)         (f2,f3) <- f
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f2_f2(a0)         (f2,f3) <- f*f = g
	    movem.l bogus4(a0),d4-d5
	    movea.l movf_f3_m(a0),a4       (a4,a5) <- g
	    movea.l movf_f2_m(a0),a5
	    moveq   #3,d0                  degree of the polynomial
	    lea     cff_atnp,a6            point to the coefficients
	    tst.w   movl_f0_f6(a0)         (f6,f7)<- f (untouched by horner(a))
	    movem.l bogus4(a0),d4-d5
	    bsr     flpt_horner            compute pg; result in (f0,f1)
	    movem.l a4-a5,movf_m_f3(a0)    (f2,f3) <- g
	    tst.w   mull_f0_f2(a0)         (f2,f3) <- g * p(g)
	    movem.l bogus4(a0),d4-d5
	    moveq   #4,d0                  degree for the next polynomial
	    lea     cff_atnq,a6
	    movea.l movf_f3_m(a0),a2       (a2,a3) <- g * p(g)
	    movea.l movf_f2_m(a0),a3
	    bsr     flpt_hornera           compute q(g); result in (f0,f1)
	    movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- g * p(g)
	    tst.w   divl_f0_f2(a0)         (f2,f3) <- g * p(g) / q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f6_f2(a0)         (f2,f3) <- f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f2_f6(a0)         result= (f6,f7) <- f + f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
f@@step15 tst.w   d7                     check n
	 beq.s   f@@checksgn             fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   f@@val23                branch if adjustment to result
	       move.l  #$3fe0c152,movf_m_f3(a0)  (f2,f3) <- a(1) = pi/6
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/6
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val23     tst.w  negl_f6_f6(a0)       else result <- -result
	    movem.l bogus4(a0),d4-d5
	    cmp.w   #2,d7               check n for either a 2 or 3
	    beq.s   f@@val2              branch if equal to 2
	       move.l  #$3ff0c152,movf_m_f3(a0)  (f2,f3) <- a(3) = pi/3
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/3
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val2      move.l  #$3ff921fb,movf_m_f3(a0)  (f2,f3) <- a(2) = pi/2
	    move.l  #$54442d18,movf_m_f2(a0)
	    tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/2
	    movem.l bogus4(a0),d4-d5
*
f@@checksgn move.l movf_f7_m(a0),d0      (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
	 tst.l   d6                     check sign of original argument
	 bpl.s   f@@donee
	    bchg    #31,d0                 negate sign of result
*
*  Place result on the stack and return.
*
f@@donee  movem.l  (sp)+,a5-a6           restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : None
*
*       References : radd, rmul, rdvd, soft_horner, soft_hornera, compare,
*                    cff_atnp, cff_atnq
*
*******************************************************************************

soft_arctan move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)    save dedicated registers
	 swap    d0             save the sign
	 move.w  d0,-(sp)
	 swap    d0             restore correct order of the operand
	 cmpi.l  #minuszero,d0  check for a -0
	 bne.s   sftat@@1        branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sftat@@1  bclr    #31,d0         f <- abs(x)
*
*  Adjust f if > 1. Underflow is possible here if f is real large.
*
	 move.l  #$3ff00000,d2  floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   invertf        branch if have to invert f
	    clr.w   -(sp)          else set n to 0
	    bra.s   step7          and continue with the computation
invertf  exg     d0,d2          place 1 as the dividend, and
	 exg     d1,d3          f as the divisor
	    move.l  sysglobals-10(a5),-(sp)  TRY, could get real underflow
	    pea     recoverr       address for the RECOVER
	    move.l  sp,sysglobals-10(a5)     new TRY block
	    bsr     rdvd           reciprocate the argument
	    addq.l  #4,sp          pop off the error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 move.w  #2,-(sp)       n <- 2
*
*  Save value of n. Adjust f if > 2 - sqrt(3).
*
step7    move.l  #$3fd12614,d2  2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   steep10         branch if no more adjusting of f or n required
	    addq.w  #1,(sp)        step 8; first adjust n
	    movea.l d0,a0          (a0,a1) <- f
	    movea.l d1,a1
	    move.l  #$3ffbb67a,d2  sqrt(3)
	    move.l  #$e8584caa,d3
	    bsr     radd           f + sqrt(3)
	    movea.l d0,a2          save denominator for now
	    movea.l d1,a3
	    move.l  #$3fe76cf5,d0  a = sqrt(3) - 1
	    move.l  #$d0b09955,d1
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           a * f
	    move.l  #$bfe00000,d2  -1/2
	    movea.l d2,a4          save for next radd
	    moveq   #0,d3
	    bsr     radd           a * f - 1/2
	    move.l  a4,d2          -1/2
	    moveq   #0,d3
	    bsr     radd           (a * f - 1/2) - 1/2
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           ( (a * f - 1/2) - 1/2) + f
	    move.l  a2,d2          restore f + sqrt(3)
	    move.l  a3,d3
	    bsr     rdvd           new f
*
*  Evaluate the polynomials if required.
*
steep10  movea.l d0,a0          save the sign of f
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare        is abs(f) < eps?
	 blt.s   step12a
	    move.l  a0,d0          restore sign of f
	    movea.l d1,a1          (a0,a1) <- f
	    move.l  d0,d2
	    move.l  d1,d3
	    bsr     rmul           g <- f * f
	    movea.l d0,a4          (a4,a5) <- g
	    movea.l d1,a5
	    moveq   #3,d0          degree of the polynomial
	    lea     cff_atnp,a6    point to the coefficients
	    bsr     soft_horner
	    move.l  a4,d2          get g
	    move.l  a5,d3
	    bsr     rmul           g * p(g)
	    movea.l d0,a2          (a2,a3) <- g * p(g)
	    movea.l d1,a3
	    moveq   #4,d0          degree for the next polynomial
	    lea     cff_atnq,a6
	    bsr     soft_hornera   q(g)
	    move.l  d0,d2          divisor
	    move.l  d1,d3
	    move.l  a2,d0          dividend
	    move.l  a3,d1
	    bsr     rdvd           g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           f * g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           result <- f + f*g*p(g)/q(g)
	    bra.s   step15
step12a  move.l  a0,d0          f is the result
*
*  Finish the computation.
*
step15   move.w  (sp)+,d7       retrieve n
	 beq.s   checksgn       fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   val23          branch if adjustment to result necesary
	       move.l  #$3fe0c152,d2  a(1) = pi/6
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val23       bchg   #31,d0          else result <- -result
	    cmp.w   #2,d7          check n for either a 2 or 3
	    beq.s   val2           branch if equal to 2
	       move.l  #$3ff0c152,d2  a(3) = pi/3
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val2        move.l  #$3ff921fb,d2  a(2) = pi/2
	    move.l  #$54442d18,d3
	    bsr     radd
*
checksgn tst.w   (sp)+          check sign of original argument
	 bpl.s   donee
	    bchg    #31,d0         negate sign of result
*
*  Place result on the stack and return.
*
donee    movem.l  (sp)+,a5-a6   restore dedicated registers
	 move.l   d0,4(sp)
	 move.l   d1,8(sp)
	 rts
*
*  Argument was too large. Return pi/2 as the result.
*
recoverr move.l  (sp)+,sysglobals-10(a5)  restore TRY block
	 move.l  #$3ff921fb,d0  else underflowed, so get top part of pi/2
	 move.l  #$54442d18,d1  rest of result of pi/2
	 tst.w   (sp)+          check sign of original operand
	 bpl     donee          positive argument yields positive result
	    bset   #31,d0          if negative, result is negative
	    bra     donee          place result on stack and return
	page
*******************************************************************************
*
*       Procedures : Assorted
*
*       Description: The rest of the procedures are a collection of
*                    utility interface routines for the compiler.
*                    See the text of the procedures for information
*                    concerning them.
*
*       Author     : Brad Ritter
*
*       Revisions  : 1.0  06/01/81
*
*******************************************************************************

asm_bcdround equ *
	movea.l (sp)+,a0        return address
	movea.l (sp)+,a1        address of string
	move.w  (sp)+,d0        number of digits
	movea.l (sp)+,a2        address of bcd_strtype
	addq.l  #3,a1           point to s[3]
	movea.l a1,a3           save address of s[3]
	addq.l  #2,a2           point to first bcd digit
*
*  Move the digits to s[3..17]
*
	moveq   #8,d1           count
bcdr1   move.b  (a2)+,d3
	move.b  d3,d4
	andi.b  #$F,d4
	andi.b  #$F0,d3
	lsr.b   #4,d3
	move.b  d3,(a1)+
	move.b  d4,(a1)+
	subq.b  #1,d1
	bgt.s   bcdr1
*
*  Round to proper number of digits
*
	lea     0(a3,d0.w),a1   address off digit to round
	addq.b  #5,(a1)
bcdr2   cmpi.b  #10,(a1)
	blt.s   bcdr5
	subi.b  #10,(a1)
	cmpa.l  a1,a3
	beq.s   bcdr3           all done but final carry
	subq.l  #1,a1
	addq.b  #1,(a1)
	bra.s   bcdr2
*
bcdr3   move.b  #49,(a3)+       '1'
	subq.b  #1,d0
bcdr4   move.b  #48,(a3)+       '0'
	subi.b  #1,d0
	bge.s   bcdr4           add 1 extra 0
*
*  Increment exponent by 1
*
	addq.w  #1,(a2)
	jmp     (a0)
*
*  Convert to characters
*
bcdr5   addi.b  #48,(a3)+
	subi.b  #1,d0
	bgt.s   bcdr5
	jmp     (a0)


asm_pack movea.l (sp)+,a0       return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a1        destination
	movea.l (sp)+,a2        source
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   pack
	movea.l d5,a1
	move.w  #8,d4

pack    cmpi.w  #2,d2           unpacksize = word ?
	bne.s   pack1
	move.w  (a2)+,d3
	bra.s   pack3

pack1   cmpi.w  #1,d2           unpacksize = byte ?
	bne.s   pack2
	move.b  (a2)+,d3
	bra.s   pack3

pack2   move.l  (a2)+,d3        unpacksize = long

pack3   move.w  d4,d5           bit index
	subi.w  #32,d5
	add.w   d1,d5
	neg.w   d5              #32 - offset - width

	cmpi.w  #16,d1          fieldwidth = 16 ?
	bne.s   pack4
	move.l  #65535,d6
	bra.s   pack8

pack4   cmpi.w  #8,d1           fieldwidth = 8 ?
	bne.s   pack5
	move.l  #255,d6
	bra.s   pack8

pack5   cmpi.w  #4,d1           fieldwidth = 4 ?
	bne.s   pack6
	moveq   #15,d6
	bra.s   pack8

pack6   cmpi.w  #2,d1           fieldwidth = 2 ?
	bne.s   pack7
	move.l  #3,d6
	bra.s   pack8

pack7   moveq   #1,d6           fieldwidth = 1

pack8   lsl.l   d5,d6           position mask
	lsl.l   d5,d3           position source
	and.l   d6,d3           mask off source
	not.l   d6
	and.l   d6,(a1)         clr dest field
	or.l    d3,(a1)         store source in dest
	add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   pack9
	subi.w  #16,d4
	addq.l  #2,a1
pack9   subq.l  #1,d0
	bne.s   pack
	jmp     (a0)

asm_unpack movea.l (sp)+,a0     return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a2        source
	movea.l (sp)+,a1        destination
	move.b  (sp)+,d3        signed fields ?
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   unpack
	movea.l d5,a1
	move.w  #8,d4

unpack  move.l  (a2),d5
	lsl.l   d4,d5           left justify field
	move.w  d1,d6
	subi.w  #32,d6
	neg.w   d6              32 - fieldwidth
	tst.b   d3
	bne.s   unpack1
	lsr.l   d6,d5           right justify unsigned
	bra.s   unpack2
unpack1 asr.l   d6,d5           right justify signed

unpack2 add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   unpack3
	subi.w  #16,d4
	addq.l  #2,a2

unpack3 cmpi.w  #2,d2           unpacksize = 2 ?
	bne.s   unpack4
	move.w  d5,(a1)+
	bra.s   unpack6

unpack4 cmpi.w  #1,d2           unpacksize =1 ?
	bne.s   unpack5
	move.b  d5,(a1)+
	bra.s   unpack6

unpack5 move.l  d5,(a1)+

unpack6 subq.l  #1,d0
	bne.s   unpack
	jmp     (a0)

asm_hex movea.l 4(sp),a0        address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
h@@x1    clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   h@@x2
	subq.b  #1,d2
	bgt.s   h@@x1
	bra.s   error           {sb}
h@@x5    clr.l   d1
	move.b  (a0)+,d1
h@@x2    subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #9,d1
	ble.s   h@@x3
	subi.w  #17,d1          ord('A') = 65   {sb}
	blt.s   error
	cmpi.w  #5,d1           {sb}
	ble.s   h@@x6            {sb}
	subi.w  #32,d1          ord('a') = 97
	blt.s   error
	cmpi.w  #5,d1           {sb}
	bgt.s   error
h@@x6    addi.w  #10,d1          {sb}
h@@x3    move.l  d0,d3
	andi.l  #$F0000000,d3
	bne.s   error
	asl.l   #4,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   h@@x5
h@@x4    move.l  d0,4(sp)
	rts

tstblk  addi.w #48,d1
tstblk0 cmpi.b #32,d1           test for trailing blanks
	bne.s  error
	subq.b #1,d2
	ble.s  h@@x4
	move.b (a0)+,d1
	bra.s  tstblk0

error   move.w  #-8,sysglobals-2(a5)
	trap    #10             value range error

asm_octal movea.l 4(sp),a0      address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
oct@@l1  clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   oct@@l2
	subq.b  #1,d2
	bgt.s   oct@@l1
	bra.s   error           {sb}
oct@@l5  clr.l   d1
	move.b  (a0)+,d1
oct@@l2  subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #7,d1
	bgt.s   error
	move.l  d0,d3
	andi.l  #$E0000000,d3
	bne.s   error
	asl.l   #3,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   oct@@l5
oct@@l4  move.l  d0,4(sp)
	rts

asm_binary movea.l 4(sp),a0     address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
bin@@ry1 clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   bin@@ry2
	subq.b  #1,d2
	bgt.s   bin@@ry1
	bra.s   error           {sb}
bin@@ry5 clr.l   d1
	move.b  (a0)+,d1
bin@@ry2 subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #1,d1
	bgt.s   error
	asl.l   #1,d0
	bcs.s   error
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   bin@@ry5
bin@@ry4 move.l  d0,4(sp)
	rts

asm_addsetrange equ *
*************************************************
*       d3, d4, a4 are not used by addelement   *
*************************************************
	movea.l (sp)+,a4        return address
	move.w  (sp)+,d3        hivalue
	move.w  (sp)+,d4        lovalue
	cmp.w   d3,d4
	ble.s   e@@add
	move.l  (sp)+,(sp)
e@@end   jmp     (a4)
e@@add   ext.l   d4
	move.l  d4,-(sp)
	jsr     asm_adelement
	addq.w  #1,d4
	cmp.w   d3,d4
	bgt     e@@end
	move.l  (sp),-(sp)
	bra.s   e@@add

***********************************************************************

retfalse clr.b  -(sp)           false
	jmp     (a0)
rettrue move.b  #1,-(sp)        true
	jmp     (a0)

***********************************************************************

asm_eq  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	beq     rettrue
	bra     retfalse

asm_ne  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bne     rettrue
	bra     retfalse

asm_lt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	blt     rettrue
	bra     retfalse

asm_le  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	ble     rettrue
	bra     retfalse

asm_gt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bgt     rettrue
	bra     retfalse

asm_ge  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bge     rettrue
	bra     retfalse
	page
****************************************************************************
*
*  Code for all the math errors.
*
err_intover  trap    #4
err_divzero  move.w  #esc_flpt_divzer,sysglobals-2(a5)
	     trap    #10
err_overflow move.w  #esc_flpt_over,sysglobals-2(a5)
	     trap    #10
err_underflow move.w #esc_flpt_under,sysglobals-2(a5)
	     trap    #10
err_trigerr  move.w  #esc_flpt_sincos,sysglobals-2(a5)
	     trap    #10
err_logerr   move.w  #esc_flpt_natlog,sysglobals-2(a5)
	     trap    #10
err_sqrterr  move.w  #esc_flpt_sqrt,sysglobals-2(a5)
	     trap    #10
err_illnumbr move.w  #esc_flpt_relbcd,sysglobals-2(a5)
	     trap    #10
err_impvalue move.w  #esc_flpt_bcdrel,sysglobals-2(a5)
	     trap    #10
err_miscel   move.w  #esc_flpt_misc,sysglobals-2(a5)
	     trap    #10
	     end

@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 10:27:27 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 5113
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 5113
*
*  FILE:        allreals
*
*  This file contains the math routines for the Pascal Workstation.
*  Major modifications for the 98635A card (hardware floating point) were
*  done by Paul Beiser   March 25, 1984.
*
	sprint
	nosyms
	refa    sysglobals
	refa    asm_adelement,fltpthdw
	lmode   asm_adelement,fltpthdw
	rorg    0

****************************************************************************
*
*  The following are the addresses of the coefficients used in the evaluation
*  of transcendental functions.
*
cff_loga        equ     $3c26           LOG coefficients
cff_logb        equ     $3c3e
cff_expp        equ     $3c56           EXP coefficients
cff_expq        equ     $3c6e
cff_sin         equ     $3c8e           SIN/COS coefficients
cff_atnp        equ     $3d66           ATN coefficients
cff_atnq        equ     $3d86
*
*  The following are address of tables used in the BCD <-> real conversions
*  and in the evaluation of x^y.
*
tb_pwt          equ     $3658           BCD <-> real tables
tb_pwt8         equ     $3698
tb_pwt4         equ     $36b8
tb_pwtt         equ     $36d8
tb_auxpt        equ     $3ae0
tb_bcd          equ     $3b28
tb_bin          equ     $3bc2
*
*  Pascal Workstation Escapecodes
*
esc_flpt_divzer equ     -5              divide by zero
esc_flpt_over   equ     -6              overflow
esc_flpt_under  equ     -7              underflow
esc_flpt_sincos equ     -15             bad argument - sine/cosine
esc_flpt_natlog equ     -16             bad argument - natural log
esc_flpt_sqrt   equ     -17             bad argument - square root
esc_flpt_relbcd equ     -18             bad argument - real/BCD conversion
esc_flpt_bcdrel equ     -19             bad argument - BCD/real conversion
esc_flpt_misc   equ     -29             misc floating point error


****************************************************************************
*
* The following are some constants that relate to the floating point card.
*
status          equ     $21             offset of the FPU protocol status byte
q               equ     3               bit postion for the q bit in <status>
bogus4          equ     $18             offset to do 4 bogus word reads
bogus4s         equ     $16             offset for 6 word reads: 4 bogus and 2
*                                         to get the status word at <status>
minuszero       equ     $80000000       top 32 bits of the real value -0

flpt_cardaddr   equ     $5c0000         address of floating pt card
flpt_id         equ     $1              offset of the ID byte/write reset
flpt_initmask   equ     $00000008       UEN flag set; RM to nearest
flpt_extracttrap equ    $00000007       mask for extracting the exception type
flpt_card_id    equ     $0a             float card ID byte SFB
*
*  Values returned by the 16081 FPU if an error occurred.
*
flpt_under      equ     1               floating point underflow
flpt_over       equ     2               floating point overflow
flpt_divzero    equ     3               floating point divide-by-zero
flpt_illegal    equ     4               illegal floating point instruction
flpt_invalid    equ     5               invalid floating point operation
flpt_inexact    equ     6               inexact floating point result
flpt_notdoc     equ     7               not furnished by National
*
*  Offsets from "flpt_cardaddr" for the operations to the floating point card.
*
addl_f0_f0      equ     $4000
addl_f0_f2      equ     $4002
addl_f0_f4      equ     $4004
addl_f0_f6      equ     $4006
addl_f2_f0      equ     $4008
addl_f2_f2      equ     $400a
addl_f2_f4      equ     $400c
addl_f2_f6      equ     $400e
addl_f4_f0      equ     $4010
addl_f4_f2      equ     $4012
addl_f4_f4      equ     $4014
addl_f4_f6      equ     $4016
addl_f6_f0      equ     $4018
addl_f6_f2      equ     $401a
addl_f6_f4      equ     $401c
addl_f6_f6      equ     $401e
subl_f0_f0      equ     $4020
subl_f0_f2      equ     $4022
subl_f0_f4      equ     $4024
subl_f0_f6      equ     $4026
subl_f2_f0      equ     $4028
subl_f2_f2      equ     $402a
subl_f2_f4      equ     $402c
subl_f2_f6      equ     $402e
subl_f4_f0      equ     $4030
subl_f4_f2      equ     $4032
subl_f4_f4      equ     $4034
subl_f4_f6      equ     $4036
subl_f6_f0      equ     $4038
subl_f6_f2      equ     $403a
subl_f6_f4      equ     $403c
subl_f6_f6      equ     $403e
mull_f0_f0      equ     $4040
mull_f0_f2      equ     $4042
mull_f0_f4      equ     $4044
mull_f0_f6      equ     $4046
mull_f2_f0      equ     $4048
mull_f2_f2      equ     $404a
mull_f2_f4      equ     $404c
mull_f2_f6      equ     $404e
mull_f4_f0      equ     $4050
mull_f4_f2      equ     $4052
mull_f4_f4      equ     $4054
mull_f4_f6      equ     $4056
mull_f6_f0      equ     $4058
mull_f6_f2      equ     $405a
mull_f6_f4      equ     $405c
mull_f6_f6      equ     $405e
divl_f0_f0      equ     $4060
divl_f0_f2      equ     $4062
divl_f0_f4      equ     $4064
divl_f0_f6      equ     $4066
divl_f2_f0      equ     $4068
divl_f2_f2      equ     $406a
divl_f2_f4      equ     $406c
divl_f2_f6      equ     $406e
divl_f4_f0      equ     $4070
divl_f4_f2      equ     $4072
divl_f4_f4      equ     $4074
divl_f4_f6      equ     $4076
divl_f6_f0      equ     $4078
divl_f6_f2      equ     $407a
divl_f6_f4      equ     $407c
divl_f6_f6      equ     $407e
negl_f0_f0      equ     $4080
negl_f0_f2      equ     $4082
negl_f0_f4      equ     $4084
negl_f0_f6      equ     $4086
negl_f2_f0      equ     $4088
negl_f2_f2      equ     $408a
negl_f2_f4      equ     $408c
negl_f2_f6      equ     $408e
negl_f4_f0      equ     $4090
negl_f4_f2      equ     $4092
negl_f4_f4      equ     $4094
negl_f4_f6      equ     $4096
negl_f6_f0      equ     $4098
negl_f6_f2      equ     $409a
negl_f6_f4      equ     $409c
negl_f6_f6      equ     $409e
absl_f0_f0      equ     $40a0
absl_f0_f2      equ     $40a2
absl_f0_f4      equ     $40a4
absl_f0_f6      equ     $40a6
absl_f2_f0      equ     $40a8
absl_f2_f2      equ     $40aa
absl_f2_f4      equ     $40ac
absl_f2_f6      equ     $40ae
absl_f4_f0      equ     $40b0
absl_f4_f2      equ     $40b2
absl_f4_f4      equ     $40b4
absl_f4_f6      equ     $40b6
absl_f6_f0      equ     $40b8
absl_f6_f2      equ     $40ba
absl_f6_f4      equ     $40bc
absl_f6_f6      equ     $40be
addf_f0_f0      equ     $40c0
addf_f0_f1      equ     $40c2
addf_f0_f2      equ     $40c4
addf_f0_f3      equ     $40c6
addf_f0_f4      equ     $40c8
addf_f0_f5      equ     $40ca
addf_f0_f6      equ     $40cc
addf_f0_f7      equ     $40ce
addf_f1_f0      equ     $40d0
addf_f1_f1      equ     $40d2
addf_f1_f2      equ     $40d4
addf_f1_f3      equ     $40d6
addf_f1_f4      equ     $40d8
addf_f1_f5      equ     $40da
addf_f1_f6      equ     $40dc
addf_f1_f7      equ     $40de
addf_f2_f0      equ     $40e0
addf_f2_f1      equ     $40e2
addf_f2_f2      equ     $40e4
addf_f2_f3      equ     $40e6
addf_f2_f4      equ     $40e8
addf_f2_f5      equ     $40ea
addf_f2_f6      equ     $40ec
addf_f2_f7      equ     $40ee
addf_f3_f0      equ     $40f0
addf_f3_f1      equ     $40f2
addf_f3_f2      equ     $40f4
addf_f3_f3      equ     $40f6
addf_f3_f4      equ     $40f8
addf_f3_f5      equ     $40fa
addf_f3_f6      equ     $40fc
addf_f3_f7      equ     $40fe
addf_f4_f0      equ     $4100
addf_f4_f1      equ     $4102
addf_f4_f2      equ     $4104
addf_f4_f3      equ     $4106
addf_f4_f4      equ     $4108
addf_f4_f5      equ     $410a
addf_f4_f6      equ     $410c
addf_f4_f7      equ     $410e
addf_f5_f0      equ     $4110
addf_f5_f1      equ     $4112
addf_f5_f2      equ     $4114
addf_f5_f3      equ     $4116
addf_f5_f4      equ     $4118
addf_f5_f5      equ     $411a
addf_f5_f6      equ     $411c
addf_f5_f7      equ     $411e
addf_f6_f0      equ     $4120
addf_f6_f1      equ     $4122
addf_f6_f2      equ     $4124
addf_f6_f3      equ     $4126
addf_f6_f4      equ     $4128
addf_f6_f5      equ     $412a
addf_f6_f6      equ     $412c
addf_f6_f7      equ     $412e
addf_f7_f0      equ     $4130
addf_f7_f1      equ     $4132
addf_f7_f2      equ     $4134
addf_f7_f3      equ     $4136
addf_f7_f4      equ     $4138
addf_f7_f5      equ     $413a
addf_f7_f6      equ     $413c
addf_f7_f7      equ     $413e
subf_f0_f0      equ     $4140
subf_f0_f1      equ     $4142
subf_f0_f2      equ     $4144
subf_f0_f3      equ     $4146
subf_f0_f4      equ     $4148
subf_f0_f5      equ     $414a
subf_f0_f6      equ     $414c
subf_f0_f7      equ     $414e
subf_f1_f0      equ     $4150
subf_f1_f1      equ     $4152
subf_f1_f2      equ     $4154
subf_f1_f3      equ     $4156
subf_f1_f4      equ     $4158
subf_f1_f5      equ     $415a
subf_f1_f6      equ     $415c
subf_f1_f7      equ     $415e
subf_f2_f0      equ     $4160
subf_f2_f1      equ     $4162
subf_f2_f2      equ     $4164
subf_f2_f3      equ     $4166
subf_f2_f4      equ     $4168
subf_f2_f5      equ     $416a
subf_f2_f6      equ     $416c
subf_f2_f7      equ     $416e
subf_f3_f0      equ     $4170
subf_f3_f1      equ     $4172
subf_f3_f2      equ     $4174
subf_f3_f3      equ     $4176
subf_f3_f4      equ     $4178
subf_f3_f5      equ     $417a
subf_f3_f6      equ     $417c
subf_f3_f7      equ     $417e
subf_f4_f0      equ     $4180
subf_f4_f1      equ     $4182
subf_f4_f2      equ     $4184
subf_f4_f3      equ     $4186
subf_f4_f4      equ     $4188
subf_f4_f5      equ     $418a
subf_f4_f6      equ     $418c
subf_f4_f7      equ     $418e
subf_f5_f0      equ     $4190
subf_f5_f1      equ     $4192
subf_f5_f2      equ     $4194
subf_f5_f3      equ     $4196
subf_f5_f4      equ     $4198
subf_f5_f5      equ     $419a
subf_f5_f6      equ     $419c
subf_f5_f7      equ     $419e
subf_f6_f0      equ     $41a0
subf_f6_f1      equ     $41a2
subf_f6_f2      equ     $41a4
subf_f6_f3      equ     $41a6
subf_f6_f4      equ     $41a8
subf_f6_f5      equ     $41aa
subf_f6_f6      equ     $41ac
subf_f6_f7      equ     $41ae
subf_f7_f0      equ     $41b0
subf_f7_f1      equ     $41b2
subf_f7_f2      equ     $41b4
subf_f7_f3      equ     $41b6
subf_f7_f4      equ     $41b8
subf_f7_f5      equ     $41ba
subf_f7_f6      equ     $41bc
subf_f7_f7      equ     $41be
mulf_f0_f0      equ     $41c0
mulf_f0_f1      equ     $41c2
mulf_f0_f2      equ     $41c4
mulf_f0_f3      equ     $41c6
mulf_f0_f4      equ     $41c8
mulf_f0_f5      equ     $41ca
mulf_f0_f6      equ     $41cc
mulf_f0_f7      equ     $41ce
mulf_f1_f0      equ     $41d0
mulf_f1_f1      equ     $41d2
mulf_f1_f2      equ     $41d4
mulf_f1_f3      equ     $41d6
mulf_f1_f4      equ     $41d8
mulf_f1_f5      equ     $41da
mulf_f1_f6      equ     $41dc
mulf_f1_f7      equ     $41de
mulf_f2_f0      equ     $41e0
mulf_f2_f1      equ     $41e2
mulf_f2_f2      equ     $41e4
mulf_f2_f3      equ     $41e6
mulf_f2_f4      equ     $41e8
mulf_f2_f5      equ     $41ea
mulf_f2_f6      equ     $41ec
mulf_f2_f7      equ     $41ee
mulf_f3_f0      equ     $41f0
mulf_f3_f1      equ     $41f2
mulf_f3_f2      equ     $41f4
mulf_f3_f3      equ     $41f6
mulf_f3_f4      equ     $41f8
mulf_f3_f5      equ     $41fa
mulf_f3_f6      equ     $41fc
mulf_f3_f7      equ     $41fe
mulf_f4_f0      equ     $4200
mulf_f4_f1      equ     $4202
mulf_f4_f2      equ     $4204
mulf_f4_f3      equ     $4206
mulf_f4_f4      equ     $4208
mulf_f4_f5      equ     $420a
mulf_f4_f6      equ     $420c
mulf_f4_f7      equ     $420e
mulf_f5_f0      equ     $4210
mulf_f5_f1      equ     $4212
mulf_f5_f2      equ     $4214
mulf_f5_f3      equ     $4216
mulf_f5_f4      equ     $4218
mulf_f5_f5      equ     $421a
mulf_f5_f6      equ     $421c
mulf_f5_f7      equ     $421e
mulf_f6_f0      equ     $4220
mulf_f6_f1      equ     $4222
mulf_f6_f2      equ     $4224
mulf_f6_f3      equ     $4226
mulf_f6_f4      equ     $4228
mulf_f6_f5      equ     $422a
mulf_f6_f6      equ     $422c
mulf_f6_f7      equ     $422e
mulf_f7_f0      equ     $4230
mulf_f7_f1      equ     $4232
mulf_f7_f2      equ     $4234
mulf_f7_f3      equ     $4236
mulf_f7_f4      equ     $4238
mulf_f7_f5      equ     $423a
mulf_f7_f6      equ     $423c
mulf_f7_f7      equ     $423e
divf_f0_f0      equ     $4240
divf_f0_f1      equ     $4242
divf_f0_f2      equ     $4244
divf_f0_f3      equ     $4246
divf_f0_f4      equ     $4248
divf_f0_f5      equ     $424a
divf_f0_f6      equ     $424c
divf_f0_f7      equ     $424e
divf_f1_f0      equ     $4250
divf_f1_f1      equ     $4252
divf_f1_f2      equ     $4254
divf_f1_f3      equ     $4256
divf_f1_f4      equ     $4258
divf_f1_f5      equ     $425a
divf_f1_f6      equ     $425c
divf_f1_f7      equ     $425e
divf_f2_f0      equ     $4260
divf_f2_f1      equ     $4262
divf_f2_f2      equ     $4264
divf_f2_f3      equ     $4266
divf_f2_f4      equ     $4268
divf_f2_f5      equ     $426a
divf_f2_f6      equ     $426c
divf_f2_f7      equ     $426e
divf_f3_f0      equ     $4270
divf_f3_f1      equ     $4272
divf_f3_f2      equ     $4274
divf_f3_f3      equ     $4276
divf_f3_f4      equ     $4278
divf_f3_f5      equ     $427a
divf_f3_f6      equ     $427c
divf_f3_f7      equ     $427e
divf_f4_f0      equ     $4280
divf_f4_f1      equ     $4282
divf_f4_f2      equ     $4284
divf_f4_f3      equ     $4286
divf_f4_f4      equ     $4288
divf_f4_f5      equ     $428a
divf_f4_f6      equ     $428c
divf_f4_f7      equ     $428e
divf_f5_f0      equ     $4290
divf_f5_f1      equ     $4292
divf_f5_f2      equ     $4294
divf_f5_f3      equ     $4296
divf_f5_f4      equ     $4298
divf_f5_f5      equ     $429a
divf_f5_f6      equ     $429c
divf_f5_f7      equ     $429e
divf_f6_f0      equ     $42a0
divf_f6_f1      equ     $42a2
divf_f6_f2      equ     $42a4
divf_f6_f3      equ     $42a6
divf_f6_f4      equ     $42a8
divf_f6_f5      equ     $42aa
divf_f6_f6      equ     $42ac
divf_f6_f7      equ     $42ae
divf_f7_f0      equ     $42b0
divf_f7_f1      equ     $42b2
divf_f7_f2      equ     $42b4
divf_f7_f3      equ     $42b6
divf_f7_f4      equ     $42b8
divf_f7_f5      equ     $42ba
divf_f7_f6      equ     $42bc
divf_f7_f7      equ     $42be
negf_f0_f0      equ     $42c0
negf_f0_f1      equ     $42c2
negf_f0_f2      equ     $42c4
negf_f0_f3      equ     $42c6
negf_f0_f4      equ     $42c8
negf_f0_f5      equ     $42ca
negf_f0_f6      equ     $42cc
negf_f0_f7      equ     $42ce
negf_f1_f0      equ     $42d0
negf_f1_f1      equ     $42d2
negf_f1_f2      equ     $42d4
negf_f1_f3      equ     $42d6
negf_f1_f4      equ     $42d8
negf_f1_f5      equ     $42da
negf_f1_f6      equ     $42dc
negf_f1_f7      equ     $42de
negf_f2_f0      equ     $42e0
negf_f2_f1      equ     $42e2
negf_f2_f2      equ     $42e4
negf_f2_f3      equ     $42e6
negf_f2_f4      equ     $42e8
negf_f2_f5      equ     $42ea
negf_f2_f6      equ     $42ec
negf_f2_f7      equ     $42ee
negf_f3_f0      equ     $42f0
negf_f3_f1      equ     $42f2
negf_f3_f2      equ     $42f4
negf_f3_f3      equ     $42f6
negf_f3_f4      equ     $42f8
negf_f3_f5      equ     $42fa
negf_f3_f6      equ     $42fc
negf_f3_f7      equ     $42fe
negf_f4_f0      equ     $4300
negf_f4_f1      equ     $4302
negf_f4_f2      equ     $4304
negf_f4_f3      equ     $4306
negf_f4_f4      equ     $4308
negf_f4_f5      equ     $430a
negf_f4_f6      equ     $430c
negf_f4_f7      equ     $430e
negf_f5_f0      equ     $4310
negf_f5_f1      equ     $4312
negf_f5_f2      equ     $4314
negf_f5_f3      equ     $4316
negf_f5_f4      equ     $4318
negf_f5_f5      equ     $431a
negf_f5_f6      equ     $431c
negf_f5_f7      equ     $431e
negf_f6_f0      equ     $4320
negf_f6_f1      equ     $4322
negf_f6_f2      equ     $4324
negf_f6_f3      equ     $4326
negf_f6_f4      equ     $4328
negf_f6_f5      equ     $432a
negf_f6_f6      equ     $432c
negf_f6_f7      equ     $432e
negf_f7_f0      equ     $4330
negf_f7_f1      equ     $4332
negf_f7_f2      equ     $4334
negf_f7_f3      equ     $4336
negf_f7_f4      equ     $4338
negf_f7_f5      equ     $433a
negf_f7_f6      equ     $433c
negf_f7_f7      equ     $433e
absf_f0_f0      equ     $4340
absf_f0_f1      equ     $4342
absf_f0_f2      equ     $4344
absf_f0_f3      equ     $4346
absf_f0_f4      equ     $4348
absf_f0_f5      equ     $434a
absf_f0_f6      equ     $434c
absf_f0_f7      equ     $434e
absf_f1_f0      equ     $4350
absf_f1_f1      equ     $4352
absf_f1_f2      equ     $4354
absf_f1_f3      equ     $4356
absf_f1_f4      equ     $4358
absf_f1_f5      equ     $435a
absf_f1_f6      equ     $435c
absf_f1_f7      equ     $435e
absf_f2_f0      equ     $4360
absf_f2_f1      equ     $4362
absf_f2_f2      equ     $4364
absf_f2_f3      equ     $4366
absf_f2_f4      equ     $4368
absf_f2_f5      equ     $436a
absf_f2_f6      equ     $436c
absf_f2_f7      equ     $436e
absf_f3_f0      equ     $4370
absf_f3_f1      equ     $4372
absf_f3_f2      equ     $4374
absf_f3_f3      equ     $4376
absf_f3_f4      equ     $4378
absf_f3_f5      equ     $437a
absf_f3_f6      equ     $437c
absf_f3_f7      equ     $437e
absf_f4_f0      equ     $4380
absf_f4_f1      equ     $4382
absf_f4_f2      equ     $4384
absf_f4_f3      equ     $4386
absf_f4_f4      equ     $4388
absf_f4_f5      equ     $438a
absf_f4_f6      equ     $438c
absf_f4_f7      equ     $438e
absf_f5_f0      equ     $4390
absf_f5_f1      equ     $4392
absf_f5_f2      equ     $4394
absf_f5_f3      equ     $4396
absf_f5_f4      equ     $4398
absf_f5_f5      equ     $439a
absf_f5_f6      equ     $439c
absf_f5_f7      equ     $439e
absf_f6_f0      equ     $43a0
absf_f6_f1      equ     $43a2
absf_f6_f2      equ     $43a4
absf_f6_f3      equ     $43a6
absf_f6_f4      equ     $43a8
absf_f6_f5      equ     $43aa
absf_f6_f6      equ     $43ac
absf_f6_f7      equ     $43ae
absf_f7_f0      equ     $43b0
absf_f7_f1      equ     $43b2
absf_f7_f2      equ     $43b4
absf_f7_f3      equ     $43b6
absf_f7_f4      equ     $43b8
absf_f7_f5      equ     $43ba
absf_f7_f6      equ     $43bc
absf_f7_f7      equ     $43be
movfl_f0_f0     equ     $43c0
movfl_f0_f2     equ     $43c2
movfl_f0_f4     equ     $43c4
movfl_f0_f6     equ     $43c6
movfl_f1_f0     equ     $43c8
movfl_f1_f2     equ     $43ca
movfl_f1_f4     equ     $43cc
movfl_f1_f6     equ     $43ce
movfl_f2_f0     equ     $43d0
movfl_f2_f2     equ     $43d2
movfl_f2_f4     equ     $43d4
movfl_f2_f6     equ     $43d6
movfl_f3_f0     equ     $43d8
movfl_f3_f2     equ     $43da
movfl_f3_f4     equ     $43dc
movfl_f3_f6     equ     $43de
movfl_f4_f0     equ     $43e0
movfl_f4_f2     equ     $43e2
movfl_f4_f4     equ     $43e4
movfl_f4_f6     equ     $43e6
movfl_f5_f0     equ     $43e8
movfl_f5_f2     equ     $43ea
movfl_f5_f4     equ     $43ec
movfl_f5_f6     equ     $43ee
movfl_f6_f0     equ     $43f0
movfl_f6_f2     equ     $43f2
movfl_f6_f4     equ     $43f4
movfl_f6_f6     equ     $43f6
movfl_f7_f0     equ     $43f8
movfl_f7_f2     equ     $43fa
movfl_f7_f4     equ     $43fc
movfl_f7_f6     equ     $43fe
movlf_f0_f0     equ     $4400
movlf_f0_f1     equ     $4402
movlf_f0_f2     equ     $4404
movlf_f0_f3     equ     $4406
movlf_f0_f4     equ     $4408
movlf_f0_f5     equ     $440a
movlf_f0_f6     equ     $440c
movlf_f0_f7     equ     $440e
movlf_f2_f0     equ     $4410
movlf_f2_f1     equ     $4412
movlf_f2_f2     equ     $4414
movlf_f2_f3     equ     $4416
movlf_f2_f4     equ     $4418
movlf_f2_f5     equ     $441a
movlf_f2_f6     equ     $441c
movlf_f2_f7     equ     $441e
movlf_f4_f0     equ     $4420
movlf_f4_f1     equ     $4422
movlf_f4_f2     equ     $4424
movlf_f4_f3     equ     $4426
movlf_f4_f4     equ     $4428
movlf_f4_f5     equ     $442a
movlf_f4_f6     equ     $442c
movlf_f4_f7     equ     $442e
movlf_f6_f0     equ     $4430
movlf_f6_f1     equ     $4432
movlf_f6_f2     equ     $4434
movlf_f6_f3     equ     $4436
movlf_f6_f4     equ     $4438
movlf_f6_f5     equ     $443a
movlf_f6_f6     equ     $443c
movlf_f6_f7     equ     $443e
movl_f0_f0      equ     $4440
movl_f0_f2      equ     $4442
movl_f0_f4      equ     $4444
movl_f0_f6      equ     $4446
movl_f2_f0      equ     $4448
movl_f2_f2      equ     $444a
movl_f2_f4      equ     $444c
movl_f2_f6      equ     $444e
movl_f4_f0      equ     $4450
movl_f4_f2      equ     $4452
movl_f4_f4      equ     $4454
movl_f4_f6      equ     $4456
movl_f6_f0      equ     $4458
movl_f6_f2      equ     $445a
movl_f6_f4      equ     $445c
movl_f6_f6      equ     $445e
movf_f0_f0      equ     $4460
movf_f0_f1      equ     $4462
movf_f0_f2      equ     $4464
movf_f0_f3      equ     $4466
movf_f0_f4      equ     $4468
movf_f0_f5      equ     $446a
movf_f0_f6      equ     $446c
movf_f0_f7      equ     $446e
movf_f1_f0      equ     $4470
movf_f1_f1      equ     $4472
movf_f1_f2      equ     $4474
movf_f1_f3      equ     $4476
movf_f1_f4      equ     $4478
movf_f1_f5      equ     $447a
movf_f1_f6      equ     $447c
movf_f1_f7      equ     $447e
movf_f2_f0      equ     $4480
movf_f2_f1      equ     $4482
movf_f2_f2      equ     $4484
movf_f2_f3      equ     $4486
movf_f2_f4      equ     $4488
movf_f2_f5      equ     $448a
movf_f2_f6      equ     $448c
movf_f2_f7      equ     $448e
movf_f3_f0      equ     $4490
movf_f3_f1      equ     $4492
movf_f3_f2      equ     $4494
movf_f3_f3      equ     $4496
movf_f3_f4      equ     $4498
movf_f3_f5      equ     $449a
movf_f3_f6      equ     $449c
movf_f3_f7      equ     $449e
movf_f4_f0      equ     $44a0
movf_f4_f1      equ     $44a2
movf_f4_f2      equ     $44a4
movf_f4_f3      equ     $44a6
movf_f4_f4      equ     $44a8
movf_f4_f5      equ     $44aa
movf_f4_f6      equ     $44ac
movf_f4_f7      equ     $44ae
movf_f5_f0      equ     $44b0
movf_f5_f1      equ     $44b2
movf_f5_f2      equ     $44b4
movf_f5_f3      equ     $44b6
movf_f5_f4      equ     $44b8
movf_f5_f5      equ     $44ba
movf_f5_f6      equ     $44bc
movf_f5_f7      equ     $44be
movf_f6_f0      equ     $44c0
movf_f6_f1      equ     $44c2
movf_f6_f2      equ     $44c4
movf_f6_f3      equ     $44c6
movf_f6_f4      equ     $44c8
movf_f6_f5      equ     $44ca
movf_f6_f6      equ     $44cc
movf_f6_f7      equ     $44ce
movf_f7_f0      equ     $44d0
movf_f7_f1      equ     $44d2
movf_f7_f2      equ     $44d4
movf_f7_f3      equ     $44d6
movf_f7_f4      equ     $44d8
movf_f7_f5      equ     $44da
movf_f7_f6      equ     $44dc
movf_f7_f7      equ     $44de

movf_m_f7       equ     $44e0
movf_m_f6       equ     $44e4
movf_m_f5       equ     $44e8
movf_m_f4       equ     $44ec
movf_m_f3       equ     $44f0
movf_m_f2       equ     $44f4
movf_m_f1       equ     $44f8
movf_m_f0       equ     $44fc
movif_m_f7      equ     $4500
movif_m_f6      equ     $4504
movif_m_f5      equ     $4508
movif_m_f4      equ     $450c
movif_m_f3      equ     $4510
movif_m_f2      equ     $4514
movif_m_f1      equ     $4518
movif_m_f0      equ     $451c
movil_m_f6      equ     $4520
movil_m_f4      equ     $4524
movil_m_f2      equ     $4528
movil_m_f0      equ     $452c
movfl_m_f6      equ     $4530
movfl_m_f4      equ     $4534
movfl_m_f2      equ     $4538
movfl_m_f0      equ     $453c
lfsr_m_m        equ     $4540

movf_f7_m       equ     $4550
movf_f6_m       equ     $4554
movf_f5_m       equ     $4558
movf_f4_m       equ     $455c
movf_f3_m       equ     $4560
movf_f2_m       equ     $4564
movf_f1_m       equ     $4568
movf_f0_m       equ     $456c
movlf_f6_m      equ     $4570
movlf_f4_m      equ     $4574
movlf_f2_m      equ     $4578
movlf_f0_m      equ     $457c
sfsr_m_m        equ     $4580
	     page
	def     asm_rmul,asm_rdiv,asm_rsub,asm_radd
	def     asm_round,asm_trunc,asm_float
	def     asm_bcd_real,asm_real_bcd,asm_bcdround
	def     asm_pack,asm_unpack
	def     asm_hex,asm_octal,asm_binary
	def     asm_eq,asm_ne,asm_lt,asm_le,asm_gt,asm_ge
	def     asm_sin,asm_cos,asm_arctan,asm_sqrt,asm_exp,asm_ln
	def     asm_addsetrange
	def     asm_flpt_error,asm_flpt_reset

asm_flpt_error  bra     flpt_error
asm_flpt_reset  bra     flpt_reset

*******************************************************************************
*
*       Procedures : asm_radd / asm_rsub / asm_rmul / asm_rdiv
*
*       Description: These are the compiler interface routines for
*                    doing real +, -, *, and /.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand2
*
*       Registers  : a0         - return address
*                    a1         - address of the card
*                    d0-d3      - the operands
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : radd, rsbt, rmul, rdvd, flpt_cardaddr, flpt_error
*
*******************************************************************************

asm_radd  movea.l (sp)+,a0              get the return address
	movem.l (sp)+,d0-d3             get the operands
	tst.b   fltpthdw                is fp hardware there
	beq.s   s@@1                     branch if not
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   addl_f0_f2(a1)          f2 + f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@1     bsr     radd                   do the operation in software
	move.l  d1,-(sp)                return the result
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rsub  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@3
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   subl_f0_f2(a1)          f2 - f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@3     bsr     rsbt
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rmul  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@5
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   mull_f0_f2(a1)          f2 * f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@5     bsr     rmul
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
*
*
*
asm_rdiv  movea.l (sp)+,a0
	movem.l (sp)+,d0-d3
	tst.b   fltpthdw
	beq.s   s@@7
	   lea     flpt_cardaddr,a1        a1 points to the start of the card
	   movem.l d0-d3,movf_m_f3(a1)     (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0)
	   tst.w   divl_f0_f2(a1)          f2 / f0 -> f2
	   movem.l bogus4s(a1),d4-d6       4 bogus reads and get error flag
	   btst    #q,d6                   the q bit is returned on last read
	   bne     flpt_error
	   move.l  movf_f2_m(a1),-(sp)     return the result (least sig. first)
	   move.l  movf_f3_m(a1),-(sp)
	   jmp     (a0)
s@@7     bsr     rdvd
	move.l  d1,-(sp)
	move.l  d0,-(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_sin / asm_cos / asm_arctan / asm_sqrt
*                    asm_exp / asm_ln
*
*       Description: These are the compiler interface routines for
*                    the transendentals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - operand
*
*       Result     : The result is returned on the stack by the
*                    called routine.
*
*       Error(s)   : Generated in the called routines.
*
*       References : See text.
*
*******************************************************************************

asm_sin tst.b   fltpthdw                is hardware there?
	beq     soft_sin                software transcendental
	bra     flpt_sin

asm_cos tst.b   fltpthdw
	beq     soft_cos
	bra     flpt_cos

asm_arctan tst.b   fltpthdw
	beq     soft_arctan
	bra     flpt_arctan

asm_sqrt tst.b  fltpthdw
	beq     soft_sqrt
	bra     flpt_sqrt

asm_exp tst.b   fltpthdw
	beq     soft_exp
	bra     flpt_exp

asm_ln  tst.b   fltpthdw
	beq     soft_ln
	bra     flpt_ln
	page
*******************************************************************************
*
*       Procedures : asm_float / asm_round / asm_trunc
*
*       Description: These are the compiler interface routines for
*                    converting integers to reals and reals to integers.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : 4(sp)      - operand1
*                    12(sp)     - operand (if present)
*
*       Registers  : a0         - return address
*                    d0-d1      - the operand(s)
*
*       Result     : The result is returned on the stack.
*
*       Error(s)   : Generated in the called routines.
*
*       References : lntrel, rellnt, rellntt
*
*       Miscel     : The floating point card is not used for any of these
*                    conversions mainly because our hardware does not support
*                    conversions from reals to integers and, in the other
*                    direction, floating point registers would have to be
*                    saved and restored, making the hardware versions not
*                    much faster than the software versions.
*
*******************************************************************************

asm_float movea.l (sp)+,a0              return address
	move.l  (sp)+,d0                operand to convert
	bsr     lntrel
	move.l  d1,-(sp)                place result on stack
	move.l  d0,-(sp)
	jmp     (a0)

asm_round movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellnt
	move.l  d0,(sp)
	jmp     (a0)

asm_trunc movea.l (sp)+,a0
	move.l  (sp)+,d0
	move.l  (sp),d1
	bsr     rellntt
	move.l  d0,(sp)
	jmp     (a0)
	page
*******************************************************************************
*
*       Procedures : asm_bcd_real / asm_real_bcd
*
*       Description: These are the compiler interface routines for
*                    converting between reals and decimals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : asm_bcd_real
*                       4(sp)   - address of the result real
*                       8(sp)   - address of the bcd number to convert
*                    asm_real_bcd
*                       4(sp)   - address of the result bcd number
*                       8(sp)   - address of the real to convert
*
*       Registers  : See the text of the code.
*
*       Result     : See "Parameters".
*
*       Error(s)   : Generated in the called routines.
*
*       References : relbcd, bcdrel
*
*       Miscel     : Both bcdrel and relbcd still do software multiplies.
*
*******************************************************************************

asm_bcd_real movea.l 8(sp),a0           address of the bcd to convert
	bsr     bcdrel                  return real in (d0,d1)
	movea.l (sp)+,a0                return address
	movea.l (sp)+,a1                address of the result real
	move.l  d0,(a1)+
	move.l  d1,(a1)
	addq.l  #4,sp
	jmp     (a0)

asm_real_bcd moveq  #16,d7      16 digits requested
	movea.l (sp)+,a1        return address
	movea.l (sp)+,a0        address of result bcd number
	movea.l (sp),a2         address of number to convert
	move.l  (a2)+,d0
	move.l  (a2),d1
	move.l  a1,(sp)
	bsr     relbcd
	rts
	page
*******************************************************************************
*
*       Procedure  : rmul
*
*       Description: Do a software 64 bit real multiply.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Registers  : d4,d5,d6   - partial products
*                    d7         - sticky bit information
*                    a0         - result exponent
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

retzero moveq   #0,d0           return zero
	move.l  d0,d1
	rts
*
*  Shortness is defined as < 17 bits of mantissa.
*
short2  tst.l   d3              test opnd2lo for zero
	bne.s   ts2
	   move.l  d0,d6           test both operandhi for
	   or.l    d2,d6           shortness
	   swap    d6
	   and.w   #$1f,d6
	   beq     shxsh           short times a short
	      move.l  d2,d6           test opnd2hi for shortness
	      swap    d6
	      and.w   #$1f,d6
	      bne.s   ts2
		 exg     d0,d2
		 exg     d1,d3            short opnd in d0-d1
		 bra     longxsh          long times a short
*
*  If here then opnd2 is definitely not short.
*
ts2     move.l  d0,d6
	swap    d6              test opnd1hi for shortness
	and.w   #$1f,d6
	bne.s   phase1
	   bra     longxsh
short1  move.l  d2,d6           test opnd2hi
	swap    d6              for shortness
	and.w   #$1f,d6
	bne.s   ph1a
	   exg     d0,d2
	   exg     d1,d3
	   bra     longxsh

*******************************************************************************
*
*  64 bit real multiply begins here.
*
rmul      cmp.l   #minuszero,d0 check first operand for -0
	  beq.s   retzero       return +0 as the answer
	  cmp.l   #minuszero,d2 check second operand for -0
	  beq.s   retzero       return +0 as the answer
	  move.l  #$80007ff0,d5 mask for exponent evaluation
	  move.l  d0,d7         high order opnd1 -> d7
	  beq.s   retzero       branch if zero operand
	  swap    d0            duplicate high order word into
	  move.w  d0,d7         low order word of d7
	  move.l  d2,d6         do the same for opnd2 into d6
	  beq.s   retzero       branch if zero operand
	  move.l  a0,-(sp)      a0 must not be altered by this routine
	  swap    d2
	  move.w  d2,d6
	  and.l   d5,d6         use mask to put sign in high order
	  and.l   d5,d7         and exponent in low order word
	  add.l   d6,d7         form result sign and exponent at once
	  moveq   #$f,d6        mask for removing exponent
	  and.w   d6,d0         extract mantissas
	  and.w   d6,d2
	  moveq   #$10,d6       mask for inserting hidden one
	  or.w    d6,d2         put in hidden one
	  or.w    d6,d0
	  movea.l d7,a0         store result exponent in a0
	  moveq   #0,d7         use d7 for sticky bit
	  tst.l   d1            can we do a faster multiply?
	  beq     short2
*
*                                     B3    B2   B1   B0
*                          X          A3    A2   A1   A0
*                               ---------------------------
*                                               [A0 X B0] (1)
*                                          [A0 X B1]      (2.1)
*                                          [A1 X B0]      (2.2)
*                                     [A1 X B1]           (3.1)
*                                     [A2 X B0]           (3.2)
*                                     [A0 X B2]           (3.3)
*                                [A3 X B0]                (4.1)
*                                [A2 X B1]                (4.2)
*                                [A0 X B3]                (4.3)
*                                [A1 X B2]                (4.4)
*                           [A3 X B1]                     (5.1)
*                           [A1 X B3]                     (5.2)
*                           [A2 x B2]                     (5.3)
*                      [A2 X B3]                          (6.1)
*                      [A3 X B2]                          (6.2)
*                 [A3 X B3]                               (7)
*-------------------------------------------------------------
*                 PP7  PP6  PP5  PP4  PP3  PP2  PP1  PP0
*
* Keep PP4 thru PP7; use PP0 thru PP3 for stickiness.

*
*                       Phase 1
*                        (1)
*
phase1   move.l  d3,d5          check for shortness
	 beq.s   short1
ph1a     mulu    d1,d5          A0*B0
	 or.w    d5,d7          keep track of lost bits for stickiness
	 clr.w   d5             discard bits 0-15
	 swap    d5
*
*                       Phase 2
*
*                       (2.1)
*
	 move.l  d3,d6
	 swap    d6
	 mulu    d1,d6          A0*B1
	 add.l   d6,d5
*
*                       (2.2)
*
	 clr.w   d4
	 move.l  d1,d6
	 swap    d6
	 mulu    d3,d6          A1*B0
	 add.l   d6,d5
	 addx.w  d4,d4
	 or.w    d5,d7
	 move.w  d4,d5
	 swap    d5
*
*                       Phase 3
*                       (3.1)
*
*
	 move.l  d3,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B1
	 swap    d1
	 add.l   d6,d5
*
*                       (3.2)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B0
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (3.3)
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d1,d6          A0*B2
	 add.l   d6,d5
	 or.w    d5,d7
	 move.w  d4,d5
	 negx.w  d5
	 neg.w   d5
	 swap    d5
*
*                       Phase 4
*                       (4.1)
*
	 move.w  d0,d6
	 mulu    d3,d6          A3*B0
	 add.l   d6,d5
*
*                       (4.2)
*
	 swap    d3
	 move.l  d0,d6
	 swap    d6
	 mulu    d3,d6          A2*B1
	 swap    d3
	 add.l   d6,d5
	 clr.w   d4
	 addx.w  d4,d4
*
*                       (4.3)
*
	 move.w  d2,d6
	 mulu    d1,d6          A0*B3
	 add.l   d6,d5
	 negx.w  d4
	 neg     d4
*
*                       (4.4)
*
	 move.l  d2,d6
	 swap    d6
	 swap    d1
	 mulu    d1,d6          A1*B2
	 swap    d1
	 add.l   d6,d5
	 negx.w  d4
	 neg.w   d4
	 swap    d4
	 swap    d5
	 move.w  d5,d4
*
*                       Phase 5
*                       (5.1)
*
*
	 clr.w   d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A3*B1
	 add.l   d6,d4
*
*                       (5.2)
*
*
	 move.l  d1,d6
	 swap    d6
	 mulu    d2,d6          A1*B3
	 add.l   d6,d4
*
*                       (5.3)
*
*
	 move.l  d2,d6
	 swap    d6
	 swap    d0
	 mulu    d0,d6          A2*B2
	 swap    d0
	 add.l   d6,d4
	 addx.w  d5,d5
	 move.w  d5,d6
	 move.w  d4,d5
	 move.w  d6,d4
	 swap    d5
	 swap    d4
*
*                       Phase 6
*
*                       (6.1)
*
	 move.l  d0,d6
	 swap    d6
	 mulu    d2,d6          A2*B3
	 add.l   d6,d4
*
*                       (6.2)
*
*
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A3*B2
	 add.l   d6,d4
*
*                       Phase 7
*
*                       (7)
*
	 move.w  d0,d6
	 mulu    d2,d6          A3*B3
	 swap    d6
	 add.l   d6,d4
*
*  Post normalization after multiplication
*
p_norm   btst    #25,d4
	 bne.s   m_norm_1
*
*  Shift whole mantissa 4 places right. This avoids 1 shift left.
*
	 suba.w  #$10,a0        adjust exponent
	 move.l  d4,d0
	 lsr.l   #4,d0
	 and.l   #$f,d4
	 ror.l   #4,d4
	 move.l  d5,d1
	 lsr.l   #4,d1
	 or.l    d4,d1
	 add.l   d5,d5          put round and stcky bits in place
	 bra.s   mround
*
*  Now shift whole mantissa right 5 places.
*
m_norm_1 move.l  d4,d0
	 lsr.l   #5,d0
	 and.l   #$1f,d4
	 ror.l   #5,d4
	 move.l  d5,d1
	 lsr.l   #5,d1
	 or.l    d4,d1
*
*  Result in (d0,d1). Now round.
*
mround   btst    #4,d5          test round bit
	 beq.s   roundun        if clear then no rounding to do
	 and.b   #$f,d5         get bits lost during last alignment
	 or.b    d5,d7          factor into sticky bit
mul_rnd2 tst.w   d7             test mr. sticky
	 bne.s   round_up       if sticky and round then round up
	    btst    #0,d1          test lsb of result
	    beq.s   roundun        else round to even
round_up addq.l  #1,d1
	 bcc.s   rm_4
	    addq.l  #1,d0
rm_4     btst    #21,d0
	 beq.s   roundun        test for mantissa overflow
	    lsr.l   #1,d0          d1 must already be zero
	    adda.w  #$10,a0
*
*  Extract result sign for later 'or' with the exponent.
*
roundun  move.l  a0,d6          get sign
	 swap    d6             place in bottom word
*
*  Complete exponent calculation with tests for overflow and underflow.
*
	 move.l  a0,d7          exponent with the sign
	 bpl.s   no_clear       branch if top portion already cleared
	    swap    d7             else clear the sign bit
	    clr.w   d7
	    swap    d7
no_clear movea.l  (sp)+,a0      restore original value of a0
	 sub.l   #$4000-$10,d7  remove extra bias minus hidden one
	 bmi     err_underflow  exponent underflow?
	 cmp.w   #$7fd0,d7      hidden bit add on later
	 bhi     err_overflow   or overflow?
*
*  Merge exponent and mantissa.
*
	 or.w    d6,d7          place sign with the exponent
	 swap    d7             place exponent into top portion
	 add.l   d7,d0          aha, hidden bit finally adds back!
	 rts

********************************************************************************
*
*  Shorter precision multiply when possible.
*
shxsh    swap    d0             align 16 bits of mantissa into d0
	 swap    d2             same for d2
	 lsr.l   #5,d0
	 lsr.l   #5,d2
	 mulu    d2,d0          A0*B0 only one multiply required here
	 swap    d0             rotate and mask result into correct bits
	 move.l  d0,d1
	 clr.w   d1
	 lsl.l   #5,d1
	 rol.l   #5,d0
	 and.l   #$001fffff,d0
	 btst    #20,d0         test for post-normalize
	 bne.s   roundun        note: no rounding possible, too few bits
	    add.l   d1,d1          shift mantissa left one position
	    addx.l  d0,d0
	    suba.w  #$10,a0        compensate exponent
	    bra     roundun
*
*  Long times shorter.
*
longxsh  swap    d0             align 16 bits of mantissa into d0
	 lsr.l   #5,d0
	 move.w  d3,d5
	 mulu    d0,d5          A0 * B0
	 or.w    d5,d7          keep PP0 in d7 for rounding
	 clr.w   d5
	 swap    d5
	 move.l  d3,d6
	 swap    d6
	 mulu    d0,d6          A0 * B1
	 add.l   d6,d5
	 move.w  d5,d4
	 clr.w   d5
	 swap    d5
	 move.l  d2,d6
	 swap    d6
	 mulu    d0,d6          A0 * B2
	 add.l   d6,d5
	 swap    d4
	 move.w  d5,d4
	 swap    d4
	 clr.w   d5
	 swap    d5
	 move.w  d2,d6
	 mulu    d0,d6          A0 * B3
	 add.l   d6,d5
	 move.l  d5,d0
	 move.l  d4,d1
	 btst    #20,d0         test for post-normalize
	 bne.s   lxs2
	    add.w   d7,d7          shift entire fraction left
	    addx.l  d1,d1
	    addx.l  d0,d0
	    suba.w  #$10,a0        fix exponent
lxs2     add.w   d7,d7          round bit into carry, leaving stickyness in d7
	 bcc     roundun
	    bra     mul_rnd2       possible rounding to do
	 page
*******************************************************************************
*
*       Procedure  : rdvd
*
*       Description: Do a software 64 bit real divide.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand (dividend)
*                    (d2,d3)    - second operand (divisor)
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow, real underflow, and divide-by-zero.
*
*       References : err_underflow, err_overflow, err_divzero
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************
*
*
*  This routine called 4 times will produce up to 64 quotient bits
*  d0-d1 is 64 bit dividend
*  d2-d3 is 64 bit divisor      (should be normalized (bit 31 = 1))
*  d4-d5 is 64 bit quotient
*
dv00     swap    d4             shift quotient left 16 bits
	 swap    d5
	 move.w  d5,d4
*
	 tst.l   d0             1st 32 dividend bits  /  1st 16 divisor bits
	 beq.s   dv7
dv0         swap    d2
	    divu    d2,d0
	    bvc.s   normal         branch if no overflow
*
*  Had an overflow on the divide. Our quotient must be $ffff or $fffe, and the
*  fixup for the new dividend is derived as follows.
*
*  DVD := Shl16(d0,d1) - Quotient * (d2,d3)
*      := Shl16(d0,d1) - (2^16-c) * (d2,d3);  c = 1 or 2
*      := Shl16(d0,d1) - Shl16(d2,d3) + c(d2,d3)
*      := Shl16( (d0,d1) - (d2,d3) ) + c(d2,d3)
*
	    swap    d2                restore correct order of divisor
	    move.w  #$ffff,d5         new quotient
	    sub.l   d3,d1             (d0,d1) - (d2,d3)
	    subx.l  d2,d0
	    swap    d0                shift left by 16
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   dv6               fixup up dividend (add back at least once)
*
*  Normal divide - no overflow. Go through standard routine.
*
normal   swap    d2
dv7      move.w  d0,d5          16 bits shifted into quotient register
	 swap    d1             shift dividend left 16 bits
	 move.w  d1,d0          except for remainder in d0 upper
	 clr.w   d1
	 tst.w   d5             finish low order part of division:
	 beq.s   dv1
	 moveq   #0,d7          d7 is used for borrow bit out of dividend
	 move.w  d2,d6          dividend - (quotient * 2nd 16 divisor bits)
	 beq.s   dv2
	    mulu    d5,d6
	    sub.l   d6,d0
	    bcc.s   dv2
	    subq    #1,d7
*
dv2      move.w  d3,d6          dividend - (quotient * 4th 16 divisor bits)
	 beq.s   dv3
	    mulu    d5,d6
	    sub.l   d6,d1
	    bcc.s   dv3
	       subq.l  #1,d0
	       bcc.s   dv3
		  subq    #1,d7
*
dv3      swap    d3             dividend - (quotient * 3rd 16 divisor bits)
	 move.w  d3,d6
	 beq.s   dv4
	    mulu    d5,d6
	    swap    d1
	    sub.w   d6,d1
	    swap    d1
	    swap    d6
	    subx.w  d6,d0
	    bcc.s   dv4
	       sub.l   #$10000,d0
	       bcc.s   dv4
		  subq    #1,d7
dv4      swap    d3
	 tst.w   d7             restore dividend and quotient if it didn't go
	 bpl.s   dv1
*
dv5         subq.l  #1,d5          decrement quotient
	    bcc.s   dv6
	       subq.l  #1,d4          propagate the borrow in the quotient
dv6         add.l   d3,d1          add divisor back to dividend
	    addx.l  d2,d0
	    bcc.s   dv5            repeat till dividend >= 0
*                               (at most twice more if bit 31 of divisor is 1)
dv1     rts

*******************************************************************************
*
*  Main body of the real divide.
*
rdvd     tst.l   d2             check for zero
	 beq     err_divzero     branch if divisor is a zero
	 cmp.l   #minuszero,d2   check for -0
	 beq     err_divzero     branch if divisor is a zero
*
*  Check for a zero dividend.
*
dvndzer  tst.l   d0
	 bne.s   checkn
divret0     moveq   #0,d0          else return a zero result
	    move.l  d0,d1
	    rts
checkn   cmp.l   #minuszero,d0  check for -0
	 beq.s   divret0
*
*  Prepare mantissas for divide, and save exponents for later.
*
procdvd  moveq   #$000f,d6      masks for the mantissa preparation
	 moveq   #$0010,d7
	 swap    d2             get the mantissas
	 move.w  d2,-(sp)       push the divisor exponent
	 and.w   d6,d2
	 or.w    d7,d2
	 swap    d2
	 swap    d0             same for next operand
	 move.w  d0,-(sp)       push the dividend exponent
	 and.w   d6,d0
	 or.w    d7,d0
	 swap    d0             mantissas ready for divide; compute exp
*
*  Divide of the mantissas with the remainder in (d0,d1)
*  and a 55 bit result to enable proper rounding. The result
*  is generated in (d4,d5).
*
	add.l   d1,d1           preshift dividend so quotient lines up right
	addx.l  d0,d0

	moveq   #11,d7          normalize divisor so that bit 31 = 1
	lsl.l   d7,d2
	rol.l   d7,d3
	move.l  d3,d6
	and.w   #$f800,d3
	and.w   #$07ff,d6
	or.w    d6,d2

	bsr     dv0             inner loop of divide
	bsr     dv00
	bsr     dv00
	bsr     dv00
	move.l  d4,d2           place here so sticky bit can be set
	move.l  d5,d3
*
*  Compute the new exponent and sign.
*
	 moveq   #0,d7          contain the exponent and sign of result
	 move.l  d7,d5          exponent calculation registers
	 move.l  d7,d6
	 move.w  (sp)+,d5       get dividend exponent
	 move.w  (sp)+,d6       get divisor exponent
	 eor.w   d5,d6          compute sign of result
	 bpl.s   possign
	     move.w  #$8000,d7     negative sign
possign  eor.w   d5,d6          restore exponents - nice trick
	 move.w  #$7ff0,d4      masks for the exponents
	 and.w   d4,d5          mask out exponents
	 and.w   d4,d6
	 sub.l   d6,d5          dividend exponent - divisor exponent
	 add.l   #$3ff0-$10,d5  bias - hidden bit (hidden bit adds later)
*
*  Normalize mantissa if necessary and compute sticky bit.
*
possitv  btst    #22,d2         check leading bit for normalize
	 bne.s   shftd          branch if already a one
	    add.l   d3,d3          else make it a leading one
	    addx.l  d2,d2
	    sub.l   #$10,d5        adjust exponent
shftd    or.l    d0,d1          set sticky bit with remainder
	 beq.s   rnd            if zero, sticky bit set correctly
	    or.b    #1,d3          else set sticky bit
*
*  Do the round and check for overflow and underflow.
*
rnd      btst    #1,d3          check round bit
	 beq.s   rend           branch if nothing to round
	 addq.l  #$2,d3         add 1 in the round bit
	 bcc.s   rndcon         branch if nothing to propagate
	    addq.l  #1,d2          else propagate the carry
rndcon   move.b  d3,d0          get the sticky bit
	 lsr.b   #1,d0          place into carry
	 bcs.s   norml          branch if number not halfway between
	    and.b   #$f8,d3        all zero so clear lsb (round to even)
norml    btst    #23,d2         check for overflow
	 beq.s   rend           if a zero then no overflow
	    lsr.l   #1,d2          only bit set is #24 because of overflow
	    add.l   #$10,d5        adjust exponent accordingly
rend     tst.l   d5             check for underflow
	 bmi     err_underflow  underflow error handler
	 cmp.w   #$7fd0,d5      check for overflow (remember, hidden bit! )
	 bhi     err_overflow   overflow error handler
*
*  Splice result together.
*
	 lsr.l   #1,d2          throw away round and sticky bits
	 roxr.l  #1,d3
	 lsr.l   #1,d2
	 roxr.l  #1,d3
	 or.w    d5,d7          place exponent with sign
	 swap    d7
	 add.l   d7,d2          ah!, hidden bit finally adds back!!
	 move.l  d2,d0          place in the correct registers
	 move.l  d3,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : radd / rsbt
*
*       Description: Do a software 64 bit real addition/subtraction.
*
*       Author     : Sam Sands / Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid operand
*
*       Parameters : (d0,d1)    - first operand
*                    (d2,d3)    - second operand
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Real overflow and real underflow.
*
*       References : err_underflow, err_overflow
*
*       Miscel     : No a registers are destroyed. This is not
*                    quite IEEE because 0 is always returned as
*                    a result regardless of the sign of the operands.
*
*******************************************************************************

first_z  move.l  d7,d0          if subtracting from zero then the
	 move.l  d3,d1          result is operand2 with the sign
	 rts                    complemented previously
*
*  This is the subtract front end. The second operand is subtracted
*  by complementing its sign.
*
rsbt     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s   rsbt1
	    rts                    (d0,d1) is the result
rsbt1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   subnonz        zero value?
	    rts                    else (d0,d1) is the result
subnonz  bchg    #31,d7         complement sign bit for subtract
	 bne.s   second_p       test if plus or minus

second_m cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sec11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sec11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        -(d2,d3) is the result
	 bmi.s   same_sig       if signs are different then set

difsigns move.w  #-1,d6         subtract flag
	 bra.s   add1

prenorm  moveq   #0,d4          no prenormalization to do
	 bra.s   do_it          so clear overflow (g,r,s)
*
*  This is the add front end.
*
radd     cmp.l   #minuszero,d2  check second operand for -0
	 bne.s    radd1
	    rts                    (d0,d1) is the result
radd1    move.l  d2,d7          copy operand2 high order to d7
	 bne.s   add_11         test for zero
	    rts                    else (d0,d1) is the result
add_11   bmi.s   second_m       test sign
second_p cmp.l   #minuszero,d0  check first operand for -0
	 bne.s   sss11          branch if not a -0
	    moveq   #0,d0          else make it a plus 0
sss11    move.l  d0,d6          copy operand1 high order to d6
	 beq.s   first_z        also test it for zero
	 bmi.s   difsigns       and check its sign
same_sig clr.w   d6             clear subtract flag

*******************************************************************************
*
*  Common to both the add and subtract.
*
add1     moveq   #$000f,d4      masks for mantissa extraction
	 moveq   #$0010,d5
	 swap    d0             clear out exponent of operand1
	 and.w   d4,d0          and put in hidden one bit
	 or.w    d5,d0
	 swap    d0
	 swap    d2             do the same for operand2
	 and.w   d4,d2
	 or.w    d5,d2
	 swap    d2
	 swap    d6             note: sign flag goes into high part
	 swap    d7
	 move.w  #$7ff0,d4      take difference of exponents
	 move.w  d4,d5
	 and.w   d6,d4
	 and.w   d7,d5
	 sub.w   d5,d4
	 beq.s   prenorm        skip prenormalization
	 asr.w   #4,d4          faster to shift difference
	 bpl.s   add2           larger operand in d0-d1?
	 neg.w   d4             otherwise swap
	 move.w  d7,d6          use larger exponent
	 exg     d0,d2
	 exg     d1,d3
add2     moveq   #-1,d7         all ones mask in d7
	 cmp.w   #32,d4         use move.l for >= 32
	 bge     long_sh
	    lsr.l   d4,d7          rotate mask and merge to shift
	    ror.l   d4,d2          a 64 bit value by N positions
	    ror.l   d4,d3          without looping
	    move.l  d3,d4          dump spillover into d3
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4

do_it    move.w  d6,d5          get result exponent
	 tst.l   d6
	 bmi.s   sub_it         remember subtract flag?
*
*  Add 2 numbers with the same signs.
*
add_it   and.w   #$7ff0,d5      mask out exponent
	 move.l  #$00200000,d7  mask for mantissa overflow test
	 add.l   d3,d1          this is it, sports fans
	 addx.l  d2,d0
	 cmp.l   d7,d0          test for mantissa overflow
	 blt.s   add3
	    add.w   #16,d5         exponent in bits 15/5
	    lsr.l   #1,d0          everything right and increment
	    roxr.l  #1,d1          the exponent
	    roxr.l  #1,d4
	    bcc.s   add3           don't forget to catch the
	       or.w    #1,d4          sticky bit
add3     cmp.l   #$80000000,d4  test for rounding
	 bcs.s   add5           if lower then no rounding to do
	 bhi.s   add4           if higher then round up
	    btst    #0,d1          otherwise test mr. sticky
	    beq.s   add5
add4     addq.l  #1,d1          here we are at the roundup
	 bcc.s   add5
	    addq.l  #1,d0
	    cmp.l   d7,d0          a word to the wise: test for
	    blt.s   add5           mantissa overflow when you
	       lsr.l   #1,d0          round up during an add
	       add.w   #16,d5         exponent in bits 15/5
add5     cmp.w   #$7fe0,d5      check for exponent overflow
	 bhi     err_overflow
	 tst.w    d6            get sign of the result
	 bpl.s   add6           positive result
	    add.w   #$8000,d5      copy sign bit
add6     swap    d5
	 clr.w   d5             for the or
	 bclr    #20,d0         hide hidden one
	 or.l    d5,d0          exponent into mantissa
	 rts
*
*  Add two numbers with differing signs.
*
sub_it   lsr.w   #4,d5          align in correct location
	 and.w   #$07ff,d5      get rid of the sign bit
	 neg.l   d4             zero minus overlow
	 subx.l  d3,d1          subtract low order
	 subx.l  d2,d0          subtract high order
	 tst.l   d0             test for top 21 bits all zero
	 beq     zerores        at least 21 left shifts necessary
	 bpl.s   sign_un        did we do it the right way?
	    add.w   #$8000,d6      flip sign of result
	    neg.l   d1             Note: this path only taken if path
	    negx.l  d0                   thru prenormalized was taken
	    tst.l   d0             check for top 21 bits being zero
	    beq     zerores        at least 21 left shifts necessary
sign_un  move.l  #$00100000,d7  post normalization mask
	 cmp.l   d7,d0          test for post normalization
	 bge.s   sub1
	 add.l   d4,d4          shift everything left one
	 addx.l  d1,d1          shift along guard bit first
	 addx.l  d0,d0          time only
	 subq.w  #1,d5          decrement exponent
	 cmp.l   d7,d0          normalized yet?
	 bge.s   sub1
	 move.l  d0,d4          test for shift by 16
	 and.l   #$001fffe0,d4  test high 16 bits
	 bne.s   norm8lop       if not 16 , check by 8
	    sub.w   #16,d5         adjust exponent
	    swap    d0
	    swap    d1
	    move.w  d1,d0
	    clr.w   d1
	    bra.s   normlopp       less than 5 shifts left (maybe 0)
norm8lop move.l  d0,d4          test for shift by 8
	 and.l   #$001fe000,d4  check 8 high bits
	 bne.s   normloop       at least one shift still necesarry!
	    sub.w   #8,d5          adjust exponent
	    lsl.l   #8,d0
	    rol.l   #8,d1
	    move.b  d1,d0          d0 correct
	    clr.b   d1             d1 correct
normlopp cmp.l   d7,d0          must test here - could be done
	 bge.s   sub2           no rounding necessary
normloop add.l   d1,d1          this is for post normalizing < 8 times
	 addx.l  d0,d0          for any additional shifting
	 subq.w  #1,d5          note: this code can be improved
	 cmp.l   d7,d0
	 blt.s   normloop
	 bra.s   sub2           no rounding necessary
sub1     cmp.l   #$80000000,d4  rounding for subtract
	 bcs.s   sub2           same sequence as add
	 bhi.s   sub3
	    btst    #0,d1
	    beq.s   sub2
sub3     addq.l  #1,d1          round up
	 bcc.s   sub2
	    addq.l  #1,d0
	    btst    #21,d0         mantissa overflow?
	    beq.s   sub2
	       asr.l   #1,d0
	       addq    #1,d5          increment exponent (can't overflow)
sub2     tst.w   d5             test for exponent underflow
	 ble     err_underflow
	    lsl.w   #5,d5          exponent in top so can place in sign
	    add.w   d6,d6          get sign
	    roxr.w  #1,d5          into exponent
	    swap    d5
	    clr.w   d5             for the or
	    bclr    #20,d0         hide hidden one
	    or.l    d5,d0          exponent into mantissa
	    rts

shifted_ bclr    #20,d0         more than 55 shifts to prenormalize
	 swap    d6             so reconstruct larger operand and
	 clr.w   d6             return in d0-d1
	 or.l    d6,d0
	 rts

long_sh  beq.s   ls1            branch if exactly 32 shifts
	 cmp.w   #55,d4         if shift count is too large then
	 bgt.s   shifted_       don't bother
	    sub.w   #32,d4
	    lsr.l   d4,d7
	    ror.l   d4,d2
	    ror.l   d4,d3
	    move.l  d3,d4
	    move.l  d2,d5
	    and.l   d7,d2
	    and.l   d7,d3
	    not.l   d7
	    and.l   d7,d5
	    or.l    d5,d3
	    and.l   d7,d4
	    beq.s   ls1
	       or.w    #1,d3
ls1      move.l  d3,d4
	 move.l  d2,d3
	 moveq   #0,d2
	 bra     do_it

zerores  tst.l   d1
	 bne.s   longnorm       if result was zero after subtract, done
	 tst.l   d4             check guard bit
	 bmi.s   longnorm
	    rts

longnorm add.l   d4,d4          result nearly zero, shift 21 or more
	 addx.l  d1,d1
	 bcs.s   norm21         exact shift by 21
	 swap    d1             test for shift of 16
	 tst.w   d1
	 bne.s   test8          test for shift of 8
	    sub.w   #16,d5         adjust exponent (d1 correct)
	    move.l  d1,d7          check which byte first one in
	    swap    d7
	    and.w   #$ff00,d7
	    bne.s   lnloop         less than 8 shifts left
	       lsl.l   #8,d1          else adjust
	       subq.w  #8,d5
	       bra.s   lnloop
test8    move.w  d1,d7          check lower bytes
	 swap    d1             d1 in correct order
	 and.w   #$ff00,d7
	 bne.s   lnloop         less than 8 shifts left
	    lsl.l   #8,d1          else adjust
	    subq.w  #8,d5
lnloop   subq.w  #1,d5          less than 8 shifts left
	 add.l   d1,d1
	 bcc.s   lnloop
norm21   sub.w   #21,d5         adjust exponent
	 swap    d1             rotate left 20 or more places
	 rol.l   #4,d1          copy over the boundary
	 move.l  d1,d0
	 and.l   #$000fffff,d0  save high 20 bits
	 and.l   #$fff00000,d1  save low 12 bits
	 bra     sub2           hidden 1 is already gone
	 page
*******************************************************************************
*
*       Procedure  : rellnt
*
*       Description: Convert a real into a 32 bit integer (round).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellnt   move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover
	 beq.s   check32        -2,147,483,648.5 = (c1e00000,00100000)
	 tst.w   d6
	 bge.s   in32con        continue with conversion
	    moveq   #0,d0          else return a zero
	    rts
*
*  Finish the conversion.
*
in32con  and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1          place top bits (except hidden one) in d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 32
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 bcc.s   chksign        branch if rounded correctly
	    addq.l  #1,d1          round to the nearest
	    bpl.s   chksign        no overflow
	       tst.w   d7             overflow - check for negative result
	       bpl     err_intover    error if positive 2^31
chksign  tst.w   d7             check the sign
	 bpl.s   done3
	    neg.l   d1             else convert to negative
done3    move.l  d1,d0          place result in correct register
	 rts
*
*  Boundary condition checks.
*
check32  tst.w   d0             check sign first
	 bpl     err_intover    remember, shifted right by 16
	    and.w   #$000f,d0      mantissa of 2^31-.5 = ([1]00000 00100000)
	    bne     err_intover    definitely WAY too large
	       lsr.l   #5,d1          else shift till get LSb
	       bne     err_intover    if non-zero, less than -2^31 - 0.5
		  bcs     err_intover    branch if equal to -2^31 - 0.5
		     move.l  #$80000000,d0  else return -2^31
		     rts
	 page
*******************************************************************************
*
*       Procedure  : rellntt
*
*       Description: Convert a real into a 32 bit integer (truncation).
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d6,d7      - scratch
*
*       Result     : The result is returned in d0.
*
*       Error(s)   : A real too large for a 32 bit integer.
*
*       References : err_intover
*
*******************************************************************************

rellntt  move.w  d0,d1          shift everthing to the right by 16
	 swap    d1             d1 is correct
	 clr.w   d0
	 swap    d0             d0 is correct
	 move.w  d0,d7          save the sign of the number
	 move.w  d0,d6
	 and.w   #$7ff0,d6      mask out the sign
	 lsr.w   #4,d6
	 sub.w   #1022,d6       exponent 1 bigger because of leading one
*
*  Check for boundary conditions.
*
	 cmp.w   #32,d6
	 bgt     err_intover    too big if don't branch
	 beq.s   silkcheck
skip     tst.w   d6             for small numbers
	 bgt.s   in32cont       branch if will convert
	    moveq   #0,d0          else return 0
	    rts
*
*  Place top bits (except for hidden bit) all in d1.
*
in32cont and.w   #$000f,d0      d0 has top 4 bits
	 lsr.l   #5,d1
	 ror.l   #5,d0
	 or.l    d0,d1          correct except for the hidden bit
*
*  Finish the conversion.
*
	 neg.w   d6
	 add.w   #32,d6         1 <= shifts <= 31
	 bset    #31,d1         place in hidden bit
	 lsr.l   d6,d1
	 tst.w   d7             check the sign
	 bpl.s   done32
	    neg.l   d1             else convert to negative
done32   move.l  d1,d0          place result in correct register
	 rts
*
silkcheck tst.w  d0             check the sign first
	 bpl     err_intover
	    and.w   #$000f,d0
	    bne     err_intover if MS bite non-zero, WAY TOO LARGE
	    lsr.l   #5,d1       shift fractional portion out
	    bne     err_intover
	       move.l   #$80000000,d0
	       rts
	 page
*******************************************************************************
*
*       Procedure  : lntrel
*
*       Description: Convert a 32 bit integer into a real number.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : d0         - integer to be converted
*
*       Registers  : d4-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

maxlnt   move.l  #$c1e00000,d0  return -2^31
	 moveq   #0,d1
	 rts
*
*  Main body of lntrel.
*
lntrel   moveq   #0,d7          will hold sign of result and exponent
	 moveq   #0,d1          bottom part of mantissa
	 tst.l   d0             check if non-zero
	 bne.s   nonzero        branch if non-zero
	    moveq   #0,d0          else returna zero result
	    move.l  d0,d1
	    rts                    and return
nonzero  bpl.s   ifposit        branch if positive
	    neg.l   d0             else convert to positive
	    bvs.s   maxlnt         branch if had -2^31
	    move.w  #$8000,d7      else set sign bit in result
*
*  Determine if a 16 bit integer hiding in 32 bits.
*
ifposit  swap    d0             check for a 16 bit integer
	 tst.w   d0
	 beq.s   int16          branch if a 16 bit integer
	    move.w  #1023+20,d4    place in the bias
	    move.w  d0,d5          test if have to left shift
	    and.w   #$fff0,d5
	    bne.s   highpart       branch if first one in top of word
	       move.l  #$00100000,d6  mask for the test for normalization
	       swap    d0             else restore number
loop4          add.l   d0,d0          at least 1 and most 4 shifts
	       subq.w  #1,d4
	       cmp.l   d6,d0
	       blt.s   loop4          until normalized
		  bra.s   shdone
highpart    move.w  d0,d5          see if at least 8 right shifts
	    and.w   #$0ff0,d5
	    bne.s   finrit         if non-zero, then at most 7 more shifts
	       swap    d0             restore mantissa
	       addq.l  #8,d4          adjust exponent
	       move.b  d0,d1
	       ror.l   #8,d1          d1 is correct
	       lsr.l   #8,d0          d0 is correct
	       bra.s   insmask
finrit      swap    d0             restore mantissa
insmask     move.l  #$00200000,d6  mask for the test for normalization
	    cmp.l   d6,d0
	    blt.s   shdone         if <, d0 correctly lined up
loop_7         lsr.l   #1,d0
	       roxr.l  #1,d1
	       addq.l  #1,d4
	       cmp.l   d6,d0          continue until normalized
	       bge.s   loop_7
		  bra.s   shdone
*
*  Have a 16 bit integer to convert, so do it fast.
*
int16    swap    d0             restore the integer
	 move.w  #1023+15,d4    place in the bias
	 move.l  #$00100000,d6  mask for the test for normalization
	 lsl.l   #5,d0          shift by at least 5
	 cmp.l   d6,d0          see if done
	 bge.s   shdone
*
*   At most 15 shifts left.
*
	 move.l  d0,d5          check for shift by 8
	 and.l   #$001fe000,d5
	 bne.s   chk7           branch if 7 or less shifts left
	    lsl.l   #8,d0          else shift by 8
	    subq.w  #8,d4          adjust exponent, and finish the shift
chk7     cmp.l   d6,d0          check implied one
	 bge.s   shdone
lp_7        add.l   d0,d0          else shift left
	    subq.w  #1,d4
	    cmp.l   d6,d0
	    blt.s   lp_7           continue until normalized
*
*  Splice result together.
*
shdone   subq.w  #1,d4          hidden bit will add back
	 lsl.w   #4,d4          place in correct locations
	 or.w    d4,d7          place exponent in with sign
	 swap    d7             in correct order
	 add.l   d7,d0          add in exponent and sign
	 rts
	 page
*******************************************************************************
*
*       Procedure  : rndnear
*
*       Description: Round a real number to the nearest whole real number.
*                    If the real is too large to be rounded, the same
*                    number is returned.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real argument
*
*       Registers  : d5-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None
*
*       References : None
*
*******************************************************************************

rndnear  move.l  d0,d6          extract the exponent
	 swap    d6             place in low word
	 and.w   #$7ff0,d6      get rid of sign bit
	 lsr.w   #4,d6          in low 11 bits
	 sub.w   #1022,d6       unbiased exponent plus one
*
*  Check if number is too small or large.
*
	 bgt.s   checknxt       branch if check for exponent too large
	 blt.s   rnd_zero       branch if so small that return a zero
	    moveq   #0,d1          else return + or - 1.0
	    tst.l   d0             determine sign
	    bmi.s   retmin
	       move.l  #$3ff00000,d0
	       rts
retmin      move.l  #$bff00000,d0
	    rts
rnd_zero moveq   #0,d0
	 move.l  d0,d1
	 rts
checknxt cmp.w   #53,d6
	 blt.s   nearcon        continue the round; 1 <= exp <= 52
	    rts                    else return with same number
*
*  Compute index for the addition of 0.5.
*
nearcon  neg.w   d6             map into correct range
	 add.w   #53,d6         1 <= d6 <= 52  (so can add in a 1)
	 move.w  d6,d5          save for later clear of mantissa bits
	 subq.w  #1,d6          number of left shifts for the mask
	 moveq   #1,d7          mask for the add
*
*  Add 0.5 (in magnitude) to the number to be rounded.
*
	 cmp.w   #32,d6         see if add to d0 or d1
	 bge.s   add0           branch if add to d0
	    lsl.l   d6,d7          shift over correct number of places
	    add.l   d7,d1
	    bcc.s   finnr          no need to check for overflow
	       addq.l  #1,d0          propagate carry
	       bra.s   finnr          if overflow, exponent adjusted!
add0    sub.w   #32,d6          get the correct mask
	lsl.l   d6,d7
	add.l   d7,d0           do add - oveflow goes into mantissa
*
*   Clear the bottom (d5) bits of (d0,d1).
*
finnr    moveq  #-1,d7          mask for the clear
	 cmp.w  #32,d5
	 blt.s  cleard1         branch of only have to clear bits in d1
	    moveq  #0,d1           else clear all of d1; maybe some of d0
	    sub.w  #32,d5          adjust count
	    bne.s  clearcon        branch if more to clear
	       rts                    else return
clearcon    lsl.l  d5,d7           get mask
	    and.l  d7,d0
	    rts
cleard1  lsl.l  d5,d7
	 and.l  d7,d1
	 rts
	 page
*******************************************************************************
*
*       Procedure  : adx
*
*       Description: Augment a real number's exponent. This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    1.1  11/03/83  For:
*                            o Removing the test for 0.
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - amount to be augmented
*
*       Registers  : d6         - scratch
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

adx      swap    d0             put exponent into lower part
	 move.w  d0,d6          extract old exponent
	 and.w   #$800f,d0      first, remove old exponent in the result
	 and.w   #$7ff0,d6
	 asl.w   #4,d7          faster if don't have to shift back
	 add.w   d7,d6          new exponent computed
	 and.w   #$7ff0,d6      large exp and negative augment;negative sign
	 or.w    d6,d0          place in new exponent
	 swap    d0             restore correct order
	 rts
	 page
*******************************************************************************
*
*       Procedure  : intxp
*
*       Description: Extract the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*
*       Result     :  The result exponent is returned in d7.
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

intxp    move.l  d0,d7          don't destroy the original number
	 swap    d7             place exponent into low word
	 and.w   #$7ff0,d7
	 lsr.w   #4,d7
	 sub.w   #1022,d7       mantissa in range [0.5,1) (ignore hidden bit)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : setxp
*
*       Description: Set the exponent of a real number. The mantissa is
*                    assumed to be in the range [.5,1). This procedure is
*                    used only in the elementary function evaluations.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : (d0,d1)    - real number to be augmented
*                    d7         - unbiased value of the new exponent.
*
*       Result     :  The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : None
*
*******************************************************************************

setxp    swap    d0
	 and.w   #$800f,d0      remove the exponent
	 add.w   #1022,d7       hidden bit becomes part of exponent
	 lsl.w   #4,d7          always positive after bias add, so do lsl
	 or.w    d7,d0          place in new exponent
	 swap    d0             re-align
	 rts
	 page
*******************************************************************************
*
*       Procedure  : compare
*
*       Description: Compare operand 1 with operand 2. Both operands are
*                    64 bit floating point reals.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For -0 as valid input
*
*       Parameters : (d0,d1)    - operand 1
*                    (d2,d3)    - operand 2
*
*       Result     : Returned in the CCR (EQ,NE,GT,LT,GE,LE).
*
*       Misc       : The operands are not destroyed, and no other registers
*                    are used.
*
*******************************************************************************

compare  tst.l   d0             test first for sign of the first operand
	 bpl.s   rcomp2
	 tst.l   d2             test sign of second operand
	 bpl.s   rcomp2
*
	 cmp.l   d0,d2          both negative so do test backward
	 bne.s   cmpend         CCR set here
	 cmp.l   d1,d3          first part equal, check second part
	 beq.s   cmpend         EQ flag set
	 bhi.s   grt            unsigned compare
lst         move    #8,CCR         XNZVC = 01000
	    rts
*
rcomp2   cmp.l   d2,d0          at least one positive, ordinary test
	 bne.s   checkm0        must check for 0 compared with -0
	 cmp.l   d3,d1          both must be positive
	 beq.s   cmpend
	 bls.s   lst            branch if LT
grt         move    #0,CCR         XNZVC = 00000
cmpend   rts
*
* Check for the operands being 0 and -0.
*
checkm0  tst.l   d0
	 bpl.s   d2minus        branch if second operand is negative
	    cmp.l   #minuszero,d0  else (d0,d1) is negative
	    bne.s   finm0       reset condition code
	    tst.l   d2
	    bne.s   finm0       must check all of it
	       rts                 had (d0,d1) = -0 and (d2,d3) = 0
d2minus  cmp.l   #minuszero,d2  (d2,d3) is negative
	 bne.s   finm0       reset condition code
	 tst.l   d0
	 bne.s   finm0       must check all of it
	    rts              had (d2,d3) = -0 and (d0,d1) = 0
finm0   cmp.l   d2,d0        else reset condition code
	rts
	page
*******************************************************************************
*
*       Procedures : soft_horner / soft_hornera
*
*       Description: Evaluate a polynomial. "soft_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the software
*                    versions of the elementary function evaluations. These
*                    procedures call software floating point routines.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83
*
*       Parameters : (a4,a5)    - real number to be evaluated
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : d2,d3      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : None, because all arguments are defined to be in a
*                    restricted range.
*
*       References : radd, rmul
*
*       Miscel     : These procedures used to be know as "horner" and
*                    "hornera" respectively. For hardware floating
*                    point, 2 different procedures are needed: one
*                    for the software math and one for the hardware math.
*
*******************************************************************************

soft_horner move.w  d0,-(sp)    save the degree of the polynomial
	 move.l  (a6)+,d0       initialize result to first coeff.
	 move.l  (a6)+,d1
horloop     move.l  a4,d2          get w
	    move.l  a5,d3
	    bsr     rmul           previous result * w
	    move.l  (a6)+,d2       get next coefficient
	    move.l  (a6)+,d3
	    bsr     radd           add to previous result
	    subq.w  #1,(sp)
	    bne.s   horloop
hordone  addq.l  #2,sp          remove the degree count
	 rts

soft_hornera  move.w  d0,-(sp)  save the degree of the polynomial
	 move.l  a4,d0          initialize result to w
	 move.l  a5,d1
horloopa move.l  (a6)+,d2       get next coefficient; (d0,d1) ok
	 move.l  (a6)+,d3
	 bsr     radd           do the addition; (d0,d1) has result
	 subq.w  #1,(sp)
	 beq.s   hordone
	    move.l  a4,d2          get w; (d0,d1) correct
	    move.l  a5,d3
	    bsr     rmul           (d0,d1) has result
	    bra.s   horloopa
	 page
*******************************************************************************
*
*       Procedures : flpt_horner / flpt_hornera
*
*       Description: Evaluate a polynomial. "flpt_hornera" assumes that the
*                    leading coefficient is 1, and thus avoids an extra
*                    multiply. These procedures are used only in the
*                    elementary function evaluation.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : (a4,a5)    - real number to be evaluated (w)
*                    a0         - address of the floating point hardware
*                    a6         - address of the coefficients
*                    d0         - the degree of the polynomial
*
*       Registers  : f0-f5      - scratch floating point registers
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned in (f1,f0).
*
*       Error(s)   : All arguments are defined to be in a restricted range,
*                    so error conditions cannot arise.
*
*       Miscel     : The caller must save and restore the contents of f0-f5.
*                    (a4,a5) is left unchanged.
*
*******************************************************************************

flpt_horner move.l (a6)+,movf_m_f1(a0)  first coefficient result in (f1,f0)
	 move.l  (a6)+,movf_m_f0(a0)
	 movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
fhorloop    tst.w   mull_f4_f0(a0)         w * previous result
	    movem.l bogus4(a0),d4-d5       bogus reads and get error flag
	    move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	    move.l  (a6)+,movf_m_f2(a0)
	    tst.w   addl_f2_f0(a0)         add coefficient to previous result
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    subq.w  #1,d0                  see if done
	    bne.s   fhorloop
fhordone rts


flpt_hornera  movem.l a4-a5,movf_m_f5(a0)    (f5,f4) <- w
	 tst.w   movl_f4_f0(a0)         w is also first partial result
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag

fhorlopa move.l  (a6)+,movf_m_f3(a0)    get the next coefficient
	 move.l  (a6)+,movf_m_f2(a0)
	 tst.w   addl_f2_f0(a0)         previous result + coefficient
	 movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	 subq.w  #1,d0                  see if done
	 beq.s   fhordone
	    tst.w  mull_f4_f0(a0)          else result*w
	    movem.l bogus4(a0),d4-d5       bogus reads with no error flag
	    bra.s   fhorlopa
	 page
*******************************************************************************
*
*       Procedure  : flpt_error
*
*       Description: Determine the type of error that has just happened in the
*                    16081 FPU and generate the appropriate Pascal Workstation
*                    ESCAPECODE.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*
*       Registers  : d0         - the 16081 FPU status register
*                    a0         - address of the floating point card
*
*       Result     : An ESCAPE is generated.
*
*       References : flpt_cardaddr, err_overflow, err_underflow,
*                    err_divzero, err_miscel
*
*       Miscel     : A 'miscellaneous floating point hardware error' escape
*                    is generated for things other than underflow, overflow,
*                    and divide-by-zero.
*
*******************************************************************************

flpt_error  equ  *                         the floating point error handler
	moveq   #flpt_extracttrap,d0       extract the TT field
	and.l   sfsr_m_m+flpt_cardaddr,d0  the floating point status register
	cmpi.w  #flpt_under,d0
	beq     err_underflow
	cmpi.w  #flpt_over,d0
	beq     err_overflow
	cmpi.w  #flpt_divzero,d0
	beq     err_divzero
	bra     err_miscel              miscellaneous floating point error
	page
*******************************************************************************
*
*       Procedure  : flpt_reset
*
*       Description: Reset the floating point card, and initialize the 16081
*                    FPU with a rounding mode of round-to-even and set the
*                    underflow enable trap.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  09/01/83
*                  : 3.2  02/19/87 DRAGON support       SFB
*
*       Registers  : d0,d1           - scratch
*
*       Parameters : None
*
*       References : flpt_cardaddr
*
*******************************************************************************

flpt_reset equ *
	lea     flpt_cardaddr,a0                point to the card
	cmpi.b  #flpt_card_id,flpt_id(a0)       see if it has correct ID SFB
	beq     is_float_card                   if so, continue SFB
	move.w  #-12,SYSGLOBALS-2(a5)           else escapecode:=buserror SFB
	trap    #10                             and escape(escapecode) SFB
is_float_card equ *                             SFB
	move.b  #1,flpt_id(a0)                  enable the card
	move.l  #flpt_initmask,lfsr_m_m(a0)     UEN; RM to nearest
	rts
	page
*******************************************************************************
*
*       Procedure  : relbcd
*
*       Description: Convert a real number into a decimal string.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*
*       Parameters : (d0,d1)    - real argument to be converted
*                    a0         - address of the result
*                    d7         - number of digits wanted
*
*       Registers  : (d2,d3)    - value from table
*                    d4         - estimator
*                    d5         - index into table
*                    d6         - scratch
*                    d7         - number of digits to return
*                    a1         - table addresses/ local storage
*
*       Result     : The result is returned through (a0).
*
*       Error(s)   : Invalid IEEE real numbers
*
*       References : tb_pwtt, tb_auxpt, tb_bin, rmul, err_illnumbr
*
*******************************************************************************

*
*  Real to bcd convert begins here. Determine sign of result.
*
relbcd  cmp.l   #minuszero,d0  check for a -0
	bne.s   relb_1         branch if not possible
	   tst.l    d1            must be a zero here!
	   bne      err_illnumbr
	      move.w  #1,(a0)+       store negative signed result
	      clr.w   (a0)+          and return a zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts
relb_1  tst.l   d0             check for zero
	bne.s   bcd_nzer       non-zero, but could still be illegal
	   tst.l   d1
	   bne     err_illnumbr
	      clr.l   (a0)+          return zero string
	      clr.l   (a0)+
	      clr.l   (a0)
	      rts                    fix this up if unpacked
bcd_nzer bmi.s   bcd_neg
	    clr.w   (a0)+          store positive sign result
	    bra.s   rbcd_1
bcd_neg  move.w  #1,(a0)+       store negative signed result
	 bclr    #31,d0         and clear sign
rbcd_1   move.l  d0,d4          scratch register
	 swap    d4             get exponent
	 and.w   #$7ff0,d4      mask off fraction and sign
*
*  Check for valid exponent.
*
	 lsr.w   #4,d4          right justify
	 beq     err_illnumbr   exponent too small?
	 sub.w   #1023,d4       remove bias
	 cmp.w   #1023,d4       exponent too large?
	 bgt     err_illnumbr
*
*  Compute the estimator E = TRUNC(log10(2) * exponent). Computation is done
*  with a fixed point multiply.
*
	 move.w  #$4d10,d5      log10(2) = 0.4d104... (hex)
	 tst.w   d4             check the sign of the base 2 exponent
	 bge.s   mul1           d5 as correct estimator
	    addq.w   #1,d5         negative exponents require 0.4d11      bug69
mul1     muls    d5,d4
	 swap    d4             remove fractional part of the result
	 addq.w  #1,d4          1 larger for the algorithm
*
	 move.w  d4,d5          copy into d5 for table indexing
	 add.w   #64,d5         add 64 for biasing to positive
	 bmi.s   rbcd_3         test for  -64 <= E <= +64
	    cmp.w   #128,d5
	    ble.s   rbcd_2         branch if only one multiply necessary
*
*  Map the number to be converted into the range (10^-64,10^64) using
*  an additional floating multiply.
*
rbcd_3   move.w  d4,d5
	 asr.w   #6,d5          estimator div 64
	 bpl.s   div_fix1       branch if no fixup necessary
	    addq.w  #1,d5          to keep mod and div correct
div_fix1 neg.w   d5             form address of reciprocal
	 addq.w  #4,d5          bias to the positive
	 asl.w   #3,d5          * 8 (bytes per real)
	 lea     tb_auxpt,a1    address of 10^(N*64) table
	 move.l  0(a1,d5.w),d2  get real from table
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          save estimator
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
	 move.w  a1,d4          restore estimator
	 move.w  d4,d5          calculate index for next operation
	 asr.w   #6,d5          estmator div 64
	 bpl.s   div_fix2
	    addq.w  #1,d5          to keep mod consistent with the div
div_fix2 asl.w   #6,d5          calculating estimator mod 64
	 neg.w   d5
	 add.w   d4,d5
	 add.w   #64,d5         bias to positive
*
*  Number is in appropriate range. Use estimator as an index to see
*  if the number is in the correct decade. If they are in the same decade,
*  modify the offset to point to the next larger decade so the map will work.
*
rbcd_2   asl.w   #3,d5          convert logical index to physical
	 lea     tb_pwtt,a1     address of table
	 move.l  0(a1,d5.w),d2  get high order entry
	 cmp.l   d2,d0          compare high order parts
	 blt.s   adjes          branch if table entry will work in the map
	 bgt.s   not_adj        branch if must retrieve the next table entry
	    move.l  4(a1,d5.w),d3  tops are equal; compare low order parts
	    cmp.l   d3,d1          must be unsigned compare!
	    bcs.s   adjes          branch if low (if carry is set, must be low)
not_adj        addq.w  #8,d5          adjust index to next entry
	       bra.s   bcmul          so number will map into correct range
*
*  Map the number into the range [.1,1). If the number to be converted is a
*  power of ten, final real result may be 1 or 2 bits less than .1 because of
*  the rounded table entry and the inexact real multiply. This condition is
*  checked for and the correct BCD number is returned.
*
*  If the number to be converted is a power of ten, the map may also produce a
*  value of 1. This condition is also checked for.
*
adjes    subq.w  #1,d4          adjust exponent estimator (reach only if lt ! )
bcmul    sub.w  #512,d5         find complement table entry
	 neg.w   d5
	 add.w   #512,d5
	 move.l  0(a1,d5.w),d2  fetch value for conversion
	 move.l  4(a1,d5.w),d3
	 movea.w d4,a1          estimator here to stay in a1 !!
	 move.w  d7,-(sp)       save count
	 bsr     rmul           do the operation
	 move.w  (sp)+,d7       restore count
*
*  Test for the result being less than 0.1
*
	 addq.w  #1,a1          adjust the exponent
	 cmp.l   #$3fb99999,d0  top part of 0.1
	 bgt.s   real_c1        branch if (d0,d1) > .1
	    cmp.l   #$9999999a,d1  tops are = ; must check the bottom parts
	    bcc.s   real_c1        cc implies greater than or equal to
	       move.l  #$10000000,(a0)+ else return bcd value of .1
	       clr.l   (a0)+          return 16 digits (faster than checking d7)
	       move.w  a1,(a0)        place exp into the bcd buffer
	       rts
*
*  Check for the converted number being exactly one.
*
real_c1  cmp.l   #$3ff00000,d0  check for (d0,d1) = 1 = (3ff00000 00000000)
	 bne.s   real_c2        branch if ok
	    move.l  #$10000000,(a0)+ else return bcd value of 1
	    clr.l   (a0)+          return 16 digits (faster than checking d7)
	    addq.w  #1,a1          boundary condition, so another adjust
	    move.w  a1,(a0)        place into the bcd buffer
	    rts
*
*  Fix up result so that implied decimal point is after bit #23 in d0. Hence bit
*  numbers 24/31 will contain the 2 decimal digits after each multiply by 100.
*
real_c2  move.l  d0,d6          extract exponent into d6
	 swap    d6
	 lsr.w   #4,d6
	 sub.w   #1023-4,d6     compute the number of left shifts
	 swap    d0
	 and.w   #$f,d0
	 or.w    #$10,d0        put in hiden one
	 swap    d0
	 tst.b   d6
	 beq.s   finish
lpten       add.l   d1,d1          loop to shift (at most 4 shifts)
	    addx.l  d0,d0
	    subq.b  #1,d6
	    bne.s   lpten
*
*  Extract the correct number of digits (as specified by d7). One extra digit
*  is returned for the purposes of rounding.
*
finish   move.w  a1,8(a0)       place exponent in memory first
	 lea     tb_bin,a1      address of binary to double bcd table
	 bgt.s   fin_1          check for improper number of digits
maxnum      moveq   #15,d7         boundary condition
	    bra.s   lp16m          get all the digits
fin_1    cmp.w   #16,d7         check if wants all the digits
	 bge.s   maxnum         branch if set counter to maximum amount
*
	 ror.b   #1,d7          determine if odd or even number wanted
	 bcs.s   oddnum         branch if odd number wanted
	    rol.b   #1,d7          even number wanted - adjust counter
	    addq.w  #1,d7
	    bra.s   lp16m
oddnum   rol.b   #1,d7          restore odd number of digits
*
lp16m    move.l  d0,d2          multiply by 100 by shift and add
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 move.l  d0,d2
	 move.l  d1,d3
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d3
	 addx.l  d2,d2
	 add.l   d3,d1
	 addx.l  d2,d0
	 add.l   d1,d1
	 addx.l  d0,d0
	 swap    d0             extract top 8 bits for conversion
	 move.w  d0,d3
	 lsr.w   #8,d3
	 and.w   #$00ff,d0      remove top 8 bits from conversion product
	 swap    d0
	 move.b  0(a1,d3.w),(a0)+ store in result area
	 subq.w  #2,d7          and loop (2 digits per loop)
	 bpl.s   lp16m          until gotten correct number of digits
	 rts
	 page
*******************************************************************************
*
*       Procedure  : bcdrel
*
*       Description: Convert a bcd number into a real number.
*
*       Author     : Paul Beiser / Ted Warren
*
*       Revisions  : 1.0  06/01/81
*
*       Parameters : a0         - address of the bcd number
*
*       Registers  : a1         - address of tables
*                    d2-d7      - scratch
*
*       Result     : The result is returned in (d0,d1).
*
*       Error(s)   : Decimal strings too large or too small.
*
*       References : rmul, err_impvalue
*                    tb_pwt, tb_pwt4, tb_pwt8, tb_auxpt, tb_bcd
*
*******************************************************************************

*
*  Only eight digits to convert so do it fast.
*
bcd8     mulu    #10000,d0
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d0          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d0          last add for fraction
	 addq.l  #4,a0          point at bcd exponent
	 moveq   #0,d1          shift result right 6 places
	 move.w  d0,d1          across d0,d1 pair
	 lsr.l   #6,d0
	 ror.l   #6,d1
	 clr.w   d1
	 move.l  d0,d6          form index for normalizing
	 swap d6
	 and.w   #$1e,d6        look at bits 20, 19, 18, and 17
	 move.w  pn_tb_4(d6.w),d6 lookup shift value
	 move.w  #1023+26-1,d7  exponent value if normalized
	 sub.w   d6,d7          subtract # of shifts required
	 neg.w   d6             computed goto for normalizing
	 addq    #4,d6
	 asl.w   #2,d6
	 jmp     shiftr8(d6.w)
shiftr8  add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 4
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 3
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 2
	 add.l   d1,d1
	 addx.l  d0,d0          entry for shift by 1
	 asl.w   #4,d7          shift exponent into position
	 swap    d7
	 add.l   d7,d0          add to fraction, removing hidden 1
	 lea     tb_pwt8,a1     address of table used for 8 digit convert
	 bra     fractsgn       determine sign and finish conversion
*
*  Table for number of normalization shifts versus value.
*  It must be in this location for short mode addressing.
*
pn_tb_4  dc.w    4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0

*******************************************************************************
*
*  Only four digits (8 at most) to convert so do it extremely fast.
*
bcd4     clr.w   d0
	 move.b  (a0)+,d0       get first two digits
	 move.b  0(a1,d0.w),d0  lookup binary value
	 mulu    #100,d0        weight by 100
	 move.b  (a0)+,d7       get second two digits
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.w   d7,d0
	 tst.w   (a0)           four more digits?
	 bne     bcd8           branch only if 4 more digits
	    addq.l  #6,a0          point at exponent
	    moveq   #0,d1          if four digits then low order real =0
	    asl.l   #7,d0          shift by at least 7 to post normalize
	    move.l  d0,d6          form an index
	    swap    d6             for post normalization
	    and.w   #$1e,d6        look at bits 20,19,18, and 17
	    move.w  pn_tb_4(d6.w),d6 lookup shift value
	    asl.l   d6,d0          normalize real
	    move.w  #1023+13-1,d7  form exponent
	    sub.w   d6,d7          subtract amount normalized
	    asl.w   #4,d7          align into position
	    swap    d7
	    add.l   d7,d0          merge into fraction
	    lea     tb_pwt4,a1     address of table for 4 digit convert
	    bra     fractsgn

*******************************************************************************
*
*  BCD to real conversion begins here.
*
bcdrel   addq.l  #2,a0          skip over sign
*
*  Convert first eight bcd digits to binary and store in d2.
*
	 tst.b   (a0)           check for zero (remember, must be normalized!)
	 bne.s   continue       continue if non-zero
	    moveq   #0,d0          else return a value of 0
	    move.l  d0,d1
	    rts
continue lea     tb_bcd,a1      address of 2 digit bcd to binary table
	 moveq   #0,d3
	 moveq   #0,d7
	 moveq   #0,d2
	 tst.l   4(a0)          check for 8 or less digits
	 beq.s   bcd4
	 move.b  (a0)+,d2       fetch first bcd digit pair
	 move.b  0(a1,d2.w),d2  lookup its binary value
	 mulu    #62500,d2      multiply by 1,000,000
	 asl.l   #4,d2          (62,500*16)
	 move.b  (a0)+,d7       fetch second pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch third pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d2          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch fourth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d2          add to sum
*
*  Convert bottom eight bcd digits and store in d3.
*
	 move.b  (a0)+,d3       fetch fifth bcd digit pair
	 move.b  0(a1,d3.w),d3  lookup its binary value
	 mulu    #62500,d3      multiply by 1,000,000
	 asl.l   #4,d3          (62,500*16)
	 move.b  (a0)+,d7       fetch sixth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #10000,d7      multply by 10,000
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch seventh pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 mulu    #100,d7        multiply by 100
	 add.l   d7,d3          and add to sum
	 moveq   #0,d7
	 move.b  (a0)+,d7       fetch eighth pair
	 move.b  0(a1,d7.w),d7  lookup binary value
	 add.l   d7,d3          add to sum
*
*  Multiply high order part by 1,000,000 and add low order part
*  1,000,000=$5f5e100. Result=(((hi * 5f5e) * $1000) + (hi * $100)) + lo.
*
	 moveq   #0,d4
	 move.w  d2,d1
	 mulu    #$5f5e,d1      hi.word(lower) * 5f5e
	 move.l  d2,d0
	 swap    d0
	 mulu    #$5f5e,d0      hi.word(upper) * 5f5e
	 swap    d1
	 move.w  d1,d4
	 clr.w   d1
	 add.l   d4,d0
	 move.w  d0,d4
	 lsr.l   #4,d0          multiply by $1000 by shifting
	 lsr.l   #4,d1
	 ror.l   #4,d4
	 clr.w   d4
	 or.l    d4,d1
	 move.l  d2,d4
	 clr.w   d4
	 swap    d4
	 lsr.w   #8,d4          multiply hi by $100 by shifting
	 lsl.l   #8,d2
	 add.l   d2,d1          add to previous result
	 addx.l  d4,d0
	 add.l   d3,d1          add in conversion from lower 8 digits
	 bcc.s   bcdr_nz
	    addq.l  #1,d0
*
*  Use jump table for post normalization and exponent location.
*
bcdr_nz  move.l  d0,d6
	 swap    d6             get upper 16 bits of fraction
	 and.w   #$3e,d6        mask off all but top 5 bits (17-21)
	 move.w  eval_exp(d6.w),d7 look up exponent
	 jmp     pn_table(d6.w)
*
*  Exponent value table for converted bcd integer.
*  1023 (bias) + 52 (size of integer) - #postnorm shifts
*  -1 (gets rid of hidden one) all times 16 to bit align.
*
eval_exp dc.w    17120
	 dc.w    17136
	 dc.w    17152
	 dc.w    17152
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17168
	 dc.w    17184,17184,17184,17184
	 dc.w    17184,17184,17184,17184
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
	 dc.w    17200,17200,17200,17200
pn_table bra.s   pn_4
	 bra.s   pn_3
	 bra.s   pn_2
	 bra.s   pn_2
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_1
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_0
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 bra.s   pn_m1
	 nop                    must be there; can't branch to next instruction!
*
pn_m1    lsr.l   #1,d0          16 digit bcd number was too large
	 roxr.l  #1,d1          and so overflowed requiring a shift
	 bra.s   pn_done        to the right and dumping of one bit
*
pn_4     add.l   d1,d1
	 addx.l  d0,d0
pn_3     add.l   d1,d1
	 addx.l  d0,d0
pn_2     add.l   d1,d1
	 addx.l  d0,d0
pn_1     add.l   d1,d1
	 addx.l  d0,d0
pn_0     equ     *
pn_done  swap    d7             insert exponent
	 add.l   d7,d0          automatically removes hidden one
	 lea     tb_pwt,a1      address of primary powers of ten table
*
*  Check sign of bcd number.
*
fractsgn tst.w   -10(a0)        test bcd sign
	 beq.s   firfl
	    bset    #31,d0         set sign bit if negative
*
*  Fetch exponent, and test for proper range.
*
firfl    move.w  (a0),d3        get binary exponent
	 cmp.w   #-309,d3
	 blt     err_impvalue   number too small
	 cmp.w   #309,d3
	 bgt     err_impvalue   number too large
*
*  Check for one or two multiplies.
*
	 move.w  d3,d6
	 add.w   #64,d6         bias to the positive
	 bmi.s   bcdr_3         E<-64?
	 cmp.w   #128,d6        E>64?
	 bgt.s   bcdr_3         must do 2 multiplies, return here later
bcdr_4      asl.w   #3,d6          convert logical to physical index
	    move.l  0(a1,d6.w),d2  lookup values
	    move.l  4(a1,d6.w),d3
	       move.l  sysglobals-10(a5),-(sp) TRY, could get over or underflow
	       pea     improper       address for the possible ESCAPE
	       move.l  sp,sysglobals-10(a5)
	       bsr     rmul           do the operation
	       addq.l  #4,sp          remove ESCAPE address
	       move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	    rts
*
*  Exponent > abs(64).
*
bcdr_3   move.w  d3,-(sp)       save exponent for later
	 asr.w   #6,d3          div 64
	 bpl.s   divfix1        this is Paul Beiser's patented DIV
	    addq.w  #1,d3
divfix1  addq.w  #4,d3          bias to the positive
	 asl.w   #3,d3          change logical to physical index
	 lea     tb_auxpt,a0       address of secondary table
	 move.l  0(a0,d3.w),d2
	 move.l  4(a0,d3.w),d3  fetch value
	 bsr     rmul           do the operation
	 move.w  (sp)+,d6       restore exponent
	 move.w  d6,d3          find exponent mod 64
	 asr.w   #6,d3
	 bpl.s   divfix2        thank you Paul
	    addq.w  #1,d3
divfix2  asl.w   #6,d3
	 sub.w   d3,d6
	 add.w   #64,d6         bias to the positive
	 bra     bcdr_4         one more multiply to do
*
*  Either real multiply generated an ESCAPE or error detected earlier.
*  Generate the ESCAPE with the correct error code.
*
improper move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 bra     err_impvalue               improper value error
	 page
*******************************************************************************
*
*       Procedure  : flpt_sin / flpt_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a1         - flag for either sin/cos
*                    a0         - address of the floating point card
*                    -(sp)      - sign of the result
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : flpt_horner, compare, cff_sin, flpt_cardaddr, rellnt
*                    err_trigerr
*
*******************************************************************************

flpt_sin move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 suba.w  a1,a1                  set flag for in the sin routine
	 move.l  d1,movf_m_f0(a0)       (f1,f0) <- x
	 move.l  d0,movf_m_f1(a0)
	 bmi.s   f@@step2neg             branch if set sgn flag to negative
	    move.w  #1,-(sp)               set sgn flag to positive
	    bra.s   f@@sincs9
f@@step2neg move.w  #-1,-(sp)            sgn flag negative
	 cmp.l    #minuszero,d0         check for a -0
	 bne.s    stx@@3                 branch if not a -0
	    move.w  #1,(sp)                else change sign to +
stx@@3    tst.w   absl_f0_f0(a0)         make (f1,f0) positive
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
f@@sincs9 tst.w   movl_f0_f2(a0)         (f2,f3) <- abs(x) = y
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 bra.s   f@@sincos               (f1,f0) <- abs(x)
*
*  Entry point for the cosine routine.
*
flpt_cos move.l  4(sp),d0               get x
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated registers
	 moveq   #1,d3                  can't move immediate to A register
	 movea.w d3,a1                  set flag for in the cos routine
	 move.l  d1,movf_m_f0(a0)       (f0,f1) <- x
	 move.l  d0,movf_m_f1(a0)
	 bne.s   f@@cos_1                if non-zero continue
f@@cosret1   move.l  #$3ff00000,d0          else return 1 as the result
	    moveq   #0,d1
	    bra     f@@done                 (d0,d1) <- 1;
f@@cos_1  cmp.l   #minuszero,d0          check for a -0
	 beq.s   f@@cosret1
	 move.w  #1,-(sp)               set sgn flag to one
	 tst.w   absl_f0_f0(a0)         (f1,f0) <- abs(x)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ff921fb,movf_m_f3(a0)    pi/2
	 move.l  #$54442d18,movf_m_f2(a0)
	 tst.w   addl_f0_f2(a0)         (f2,f3) <- y = abs(x) + pi/2
	 movem.l bogus4(a0),d4-d5
*
*  Common point for both the sine and cosine routines.
*  (f1,f0) <- abs(x), (f3,f2) <- y
*
f@@sincos move.l  movf_f3_m(a0),d0       get y
	 move.l  movf_f2_m(a0),d1
	 move.l  #$41b1c583,d2          check argument not too large
	 move.l  #$1a000000,d3          ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr             branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,movf_m_f5(a0)  compute y * 1/pi
	 move.l  #$6dc9c883,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f5,f4) <- y*1/pi
	 movem.l bogus4(a0),d4-d5
	 btst    #q,status(a0)          see if had underflow
	 beq     f@@sin34                continue if no underflow
	    move.l  #0,movf_m_f5(a0)       else set result to 0
	    move.l  #0,movf_m_f4(a0)       and continue
f@@sin34  move.l  movf_f5_m(a0),d0       get the result
	 move.l  movf_f4_m(a0),d1
	 bsr     rellnt                 convert to a 32 bit integer
	 move.w  d0,d7                  scratch register
	 lsr.w   #1,d7                  determine if even or odd
	 bcc.s   f@@step8                branch if even
	    neg.w   (sp)                   sgn <- -sgn
f@@step8  move.l  d0,movil_m_f4(a0)      (f5,f4) <- xn (converted d0 to real)
	 movem.l bogus4(a0),d4-d5
*
*  See if adjustment necessary to xn. At this stage,
*  (f1,f0) <- abs(x), (f3,f2) <- y, and (f5,f4) <- xn.
*
	 move.w  a1,d6                  for the check
	 beq.s   f@@step10               branch if sin wanted
	    move.l  #$bfe00000,movf_m_f7(a0)  else adjust xn
	    move.l  #0,movf_m_f6(a0)          by -1/2
	    tst.w   addl_f6_f4(a0)         (f5,f4) <- xn = xn - 0.5
	    movem.l bogus4(a0),d4-d5
*
*  Compute the reduced argument f.
*
f@@step10 move.l  #$c0092200,movf_m_f7(a0)  get constant -c1
	 move.l  #0,movf_m_f6(a0)       (f7,f6) <- -c1
	 tst.w   mull_f4_f6(a0)         (f7,f6) <- -xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- abs(x) - xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3ee2aeef,movf_m_f7(a0) (f7,f6) <- c2
	 move.l  #$4b9ee59e,movf_m_f6(a0)
	 tst.w   mull_f6_f4(a0)         (f5,f4) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f1,f0) <- f = (abs(x) - xn*c1) + xn*c2
	 movem.l bogus4(a0),d4-d5
*
*  Check size of reduced argument. If too small, return f as result else
*  compute g and continue. At this point, (f1,f0) <- f.
*
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  d0,d6                  save the top part of f
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   f@@step12               branch if f not too small
	    move.l  d6,d0                  else return f as the answer
	    bra.s   f@@sign_tst             check for the correct sign
f@@step12 tst.w   movl_f0_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         g <- f*f
	 movem.l bogus4(a0),d4-d5
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result. At
*  this point, (f1,f0) <- f and (f3,f2) <- g.
*
	 movea.l movf_f3_m(a0),a4       number to be evaluated g
	 movea.l movf_f2_m(a0),a5
	 lea     cff_sin,a6             point to coefficients
	 moveq   #7,d0                  degree of polynomial
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- f (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 bsr     flpt_horner            compute p(g); result in (f1,f0)
	 movem.l a4-a5,movf_m_f3(a0)    restore g
	 tst.w   mull_f0_f2(a0)         (f3,f2) <- g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f2(a0)         (f3,f2) <- f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f6(a0)         (f6,f7) <- f + f*g*p(g)
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f7_m(a0),d0       (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
*
f@@sign_tst tst.w (sp)+          retrieve sgn
	 bpl.s   f@@done         branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
f@@done   movem.l (sp)+,a5-a6     restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_sin / soft_cos
*
*       Description: Compute the sine/cosine of the numeric item on the
*                    top of the stack (radians mode). This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o To check for -0 as a valid input
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large in magnitude returns an error.
*
*       References : radd, rmul, soft_horner, err_trigerr
*                    compare, lntrel, rellnt, cff_sin, sysglobals
*
*******************************************************************************

soft_sin move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bmi.s   step2neg       branch if set sgn flag to negative
	    move.w  #1,-(sp)       set sgn flag to positive
	    movea.l d0,a0          (a0,a1) <- x
	    movea.l d1,a1
	    bra.s   sincos         common point for both routines
step2neg move.w  #-1,-(sp)      sgn flag negative
	 cmp.l    #minuszero,d0 check for a -0
	 bne.s    sty@@3         branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sty@@3    bclr    #31,d0
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 bra.s   sincos
*
*  Entry point for the cosine routine.
*
soft_cos move.l  8(sp),d1
	 move.l  4(sp),d0
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bne.s   cos_1          if non-zero continue
cosret1     move.l  #$3ff00000,d0 else return 1 as the result
	    moveq   #0,d1
	    bra     done          (d0,d1) <- 1;
cos_1    cmp.l   #minuszero,d0  check for -0
	 beq.s   cosret1
	 move.w  #1,-(sp)       set sgn flag to one
	 bclr    #31,d0         abs(x)
	 movea.l d0,a0          (a0,a1) <- abs(x)
	 movea.l d1,a1
	 move.l  #$3ff921fb,d2  pi/2
	 move.l  #$54442d18,d3
	 bsr     radd           y = abs(x) + pi/2
*
*  Common point for both the sine and cosine routines.
*
sincos   movea.l d0,a2          (a2,a3) <- y
	 movea.l d1,a3
	 move.l  #$41b1c583,d2  check argument not too large
	 move.l  #$1a000000,d3  ymax = int(pi*2^(53/2))
	 bsr     compare
	 bge     err_trigerr    branch if y >= ymax
*
*  Argument in range. Compute n and xn. Note that underflow is possible here
*  if y is real small.
*
	 move.l  #$3fd45f30,d2  compute y * 1/pi
	 move.l  #$6dc9c883,d3
	    move.l  sysglobals-10(a5),-(sp)
	    pea     recover        in case of underflow
	    move.l  sp,sysglobals-10(a5)     new try block
	    bsr     rmul
	    addq.l  #4,sp          remove error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 bsr     rellnt         round result to a 32 bit integer
	 move.w  d0,d7          scratch register
	 lsr.w   #1,d7          determine if even or odd
	 bcc.s   step8          branch if even
	    neg.w   (sp)           sgn <- -sgn
step8    bsr     lntrel         (d0,d1) <- xn
	 movea.l a2,a4          (a4,a5) <- y
	 movea.l a3,a5
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  See if adjustment necessary to xn.
*
	 move.l  a0,d0          retrieve abs(x)
	 move.l  a1,d1
	 move.l  a4,d2          retrieve y
	 move.l  a5,d3
	 bsr     compare        check abs(x) = y
	 beq.s   step10a        branch if sin wanted
	    move.l  a2,d0          else adjust xn
	    move.l  a3,d1
	    move.l  #$bfe00000,d2  -1/2
	    moveq   #0,d3
	    bsr     radd           xn <- xn - 0.5
	    movea.l d0,a2          (a2,a3) <- xn
	    movea.l d1,a3
	    bra.s   step10
step10a  move.l  a2,d0          load up (d0,d1) with xn
	 move.l  a3,d1
*
*  Compute the reduced argument f.
*
step10   move.l  #$c0092200,d2  get constant -c1
	 moveq   #0,d3          (d0,d1) already has xn
	 bsr     rmul           -xn*c1
	 move.l  a0,d2          get abs(x)
	 move.l  a1,d3
	 bsr     radd           abs(x) - xn*c1
	 movea.l d0,a0          save in (a0,a1)
	 movea.l d1,a1          abs(x) no longer needed
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3ee2aeef,d2  c2
	 move.l  #$4b9ee59e,d3
	 bsr     rmul           xn*c2
	 move.l  a0,d2          retrieve intermediate result
	 move.l  a1,d3
	 bsr     radd           (abs(x) - xn*c1) + xn*c2
	 movea.l d0,a0          (a0,a1) <- f
	 movea.l d1,a1
*
*  Check size of reduced argument. If too small, return
*  f as result else compute g and continue.
*
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare
	 bge.s   step12         branch if f not too small
	    move.l  a0,d0          else return f as the answer
	    bra.s   sign_tst       still must check for the correct sign
step12   move.l  a0,d0          restore top part of f
	 move.l  d0,d2
	 move.l  d1,d3
	 bsr     rmul           g <- f*f
*
*  Compute  f + f*g*p(g), and then use sgn to determine sign of result.
*
	 movea.l d0,a4          number to be evaluated
	 movea.l d1,a5
	 lea     cff_sin,a6     point to coefficients
	 moveq   #7,d0          degree of polynomial
	 bsr     soft_horner    compute p(g)
	 move.l  a4,d2          retrieve g
	 move.l  a5,d3
	 bsr     rmul           g*p(g)
	 move.l  a0,d2          retrieve f
	 move.l  a1,d3
	 bsr     rmul           f*g*p(g)
	 move.l  a0,d2          retrieve f again
	 move.l  a1,d3
	 bsr     radd           f + f*g*p(g)
*
sign_tst tst.w   (sp)+          retrieve sgn
	 bpl.s   done           branch if positive sign
	    bchg    #31,d0         else result <- result * sgn
*
*  Place result on the stack and return.
*
done     movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d0,4(sp)        place on the stack
	 move.l  d1,8(sp)
	 rts
*
*  Argument reduction caused an underflow error, so the sine routine
*  must have been called. Therefore, return the original argument as the
*  result.
*
recover  move.l  (sp)+,sysglobals-10(a5)    restore old TRY block
	 move.l  a0,d0          get original argument
	 move.l  a1,d1
	 bra.s   sign_tst       determine the sign of original argument
	 page
*******************************************************************************
*
*       Procedure  : flpt_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : flpt_horner, rndnear, rellnt, adx, cff_expp, cff_expq
*                    compare, flpt_cardaddr, err_overflow, err_underflow
*
*******************************************************************************

flpt_exp move.l  4(sp),d0               get the operand
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow          underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6                  save top part of operand for later
	 bclr    #31,d0                 get the absolute value of the operand
	 move.l  #$3c900000,d2          threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   f@@exp_11               branch if operand in range
	    move.l  #$3ff00000,d0          else return answer of 1.0
	    moveq   #0,d1
	    bra     f@@donee1               place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
f@@exp_11 move.l  d6,d0                  restore top part of operand
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- x
	 move.l  #$3ff71547,movf_m_f3(a0)   (f2,f3) <- 1/ln(2)
	 move.l  #$652b82fe,movf_m_f2(a0)
	 tst.w   mull_f0_f2(a0)         (f2,f3) <- x * 1/ln(2)
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 move.l movf_f3_m(a0),d0        retrieve x * 1/ln(2)
	 move.l movf_f2_m(a0),d1
	 bsr     rndnear                (d0,d1) <- xn (conversion to int later)
	 movem.l d0-d1,movf_m_f3(a0)    (f2,f3) <- xn
*
*  Determine g. Have (f0,f1) <- x and (f2,f3) <- xn.
*
	 move.l  #$bfe63000,movf_m_f5(a0)  -0.543 octal = c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- x + xn*c1
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3f2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn*c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- (x + xn*c1) + xn*c2 = g
	 movem.l bogus4(a0),d4-d5
*
*  Have (f2,f3) <- xn and (f0,f1) <- g.
*  Save xn in (a2,a3) and compute z, p(z), and g*p(z), and q(z).
*
	 movea.l movf_f2_m(a0),a3       xn is not needed till much later
	 movea.l movf_f3_m(a0),a2
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- g (untouched by horner)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f0_f0(a0)         (f0,f1) <- g*g = z
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f0_m(a0),a5       (a4,a5) <- z
	 movea.l movf_f1_m(a0),a4
	 lea     cff_expp,a6            point to coefficients
	 moveq   #2,d0                  degree of p
	 bsr     flpt_horner            compute p(z); result in (f0,f1)
	 tst.w   mull_f0_f6(a0)         (f6,f7) <- g * p(z)
	 movem.l bogus4(a0),d4-d5
	 lea     cff_expq,a6            point to coefficients
	 moveq   #3,d0                  degree of q
	 bsr     flpt_horner            do the evaluation; (a4,a5) still has z
*
*  Have (f0,f1) <- q(z) and (f6,f7) <- g*p(z). Compute r(g).
*
	 tst.w   subl_f6_f0(a0)         (f0,f1) <- q(z) - g*p(z)
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f6(a0)         (f6,f7) <- g*p(z) / (q(z) - g*p(g))
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f1(a0) (f0,f1) <- 1/2
	 move.l  #0,movf_m_f0(a0)
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- r(g)
	 movem.l bogus4(a0),d4-d5
*
*  Compute integer value of xn, and finish computation.
*
	 move.l  a3,d1                  retrieve xn
	 move.l  a2,d0
	 bsr     rellnt                 32 bit integer (already been rounded)
	 addq.l  #1,d0                  part of step 9 in the algorithm
	 move.l  d0,d7                  augment with r to form result
	 move.l  movf_f1_m(a0),d0       retrieve r(g) from the chip
	 move.l  movf_f0_m(a0),d1
	 bsr     adx                    r(g) and n form the result
*
*  Place result on the stack.
*
f@@donee1 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_exp
*
*       Description: Compute the exponential of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large or too small returns an error.
*
*       References : radd, rmul, rdvd, soft_horner,
*                    compare, rndnear, rellnt, adx, cff_expp, cff_expq
*                    err_overflow, err_underflow
*
*******************************************************************************

soft_exp move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)            save dedicated Pascal registers
	 move.l  #$40862e42,d2          compare against the largest
	 move.l  #$fefa39ee,d3          number < ln(maximum machine number)
	 bsr     compare
	 bgt     err_overflow           overflow
	 move.l  #$c086232b,d2          compare against the smallest
	 move.l  #$dd7abcd1,d3          number > ln(minimum machine number)
	 bsr     compare
	 blt     err_underflow
*
*  Test for operand so small that 1.0 is the result.
*
	 move.l  d0,d6          save top part of operand for later
	 bclr    #31,d0         get the absolute value of the operand
	 move.l  #$3c900000,d2  threshold for answer = to 1
	 moveq   #0,d3
	 bsr     compare
	 bge.s   exp_11         branch if operand in range
	    move.l  #$3ff00000,d0  else return answer of 1.0
	    moveq   #0,d1
	    bra     donee1         place on stack and return
*
*  Proceed with step 6 - calculate xn.
*
exp_11   move.l  d6,d0          restore top part of operand and continue
	 movea.l d0,a0          (a0,a1) <- x
	 movea.l d1,a1
	 move.l  #$3ff71547,d2  1/ln(2)
	 move.l  #$652b82fe,d3
	 bsr     rmul           (d0,d1) <- x * 1/ln(2)
	 bsr     rndnear        (d0,d1) <- xn (conversion to integer later)
	 movea.l d0,a2          (a2,a3) <- xn
	 movea.l d1,a3
*
*  Determine g.
*
	 move.l  #$bfe63000,d2  -0.543 octal = c1
	 moveq   #0,d3
	 bsr     rmul           xn*c1
	 move.l  a0,d2          (d2,d3) <- x
	 move.l  a1,d3          (a0,a1) is now freed
	 bsr     radd           x + xn*c1
	 movea.l d0,a0          (a0,a1) <- x + xn*c1
	 movea.l d1,a1
	 move.l  a2,d0          (d0,d1) <- xn
	 move.l  a3,d1
	 move.l  #$3f2bd010,d2  get c2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           (d0,d1) <- xn*c2
	 move.l  a0,d2          get previous intermediate result
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <- (x + xn*c1) + xn*c2
*
*  Compute z, p(z), and g*p(z), and q(z).
*
	 movea.l d0,a0          save away g
	 movea.l d1,a1
	 move.l  d0,d2          compute z = g*g
	 move.l  d1,d3
	 bsr     rmul           (d0,d1) <- z
	 movem.l d0-d1,-(sp)    save z away
*
	 movea.l d0,a4          compute p(z)
	 movea.l d1,a5
	 lea     cff_expp,a6    point to coefficients
	 moveq   #2,d0          degree of p
	 bsr     soft_horner    do the evaluation
	 move.l  a0,d2          restore g
	 move.l  a1,d3
	 bsr     rmul           g*p(z)
	 movea.l d0,a0          (a0,a1) <- g*p(z)
	 movea.l d1,a1
*
	 movem.l (sp)+,a4-a5    restore z
	 lea     cff_expq,a6    point to coefficients
	 moveq   #3,d0          degree of q
	 bsr     soft_horner    do the evaluation
*
*  Compute r(g).
*
	 move.l a0,d2           (d2,d3) <- g*p(z)
	 move.l a1,d3
	 bsr    rsbt            (d0,d1) <- q(z) - g*p(z)
	 move.l d0,d2           to be used as divisor
	 move.l d1,d3
	 move.l a0,d0           (d0,d1) <- g*p(z)
	 move.l a1,d1
	 bsr    rdvd            (d0,d1) <- g*p(z) / (q(z)-g*p(z))
	 move.l #$3fe00000,d2   add 1/2
	 moveq  #0,d3
	 bsr    radd            (d0,d1) <- r(g)
*
*  Compute integer value of xn, and finish computation.
*
	 movea.l d0,a0          save r(g)
	 movea.l d1,a1
	 move.l  a2,d0          retrieve xn
	 move.l  a3,d1
	 bsr     rellnt         32 bit integer (already been rounded)
	 addq.l  #1,d0          part of step 9 in the algorithm
	 move.l  d0,d7          augment with r to form result
	 move.l  a0,d0          (d0,d1) <- r(g)
	 move.l  a1,d1
	 bsr     adx            r and n form the result
*
*  Place result on the stack.
*
donee1   movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - exponent of the argument
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : cff_expp, cff_expq, flpt_horner, flpt_hornera,
*                    flpt_cardaddr, intxp, setxp, err_logerr
*
*******************************************************************************

flpt_ln  move.l  4(sp),d0
	 ble     err_logerr             branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 lea     flpt_cardaddr,a0       point to the start of the hardware
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 bsr     intxp                  extract exponent; operand in (d0,d1)
	 movea.w d7,a1                  place exponent temporarily into a1
	 clr.w   d7                     map number into range [0.5,1)
	 bsr     setxp                  compute value of f
	 move.w  a1,d7                  save exponent in d7
	 movea.l d0,a2                  save f in (a2,a3)
	 movea.l d1,a3
	 move.l  #$bfe00000,d2          combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 movem.l d0-d3,movf_m_f3(a0)    (f0,f1) <- -0.5;  (f2,f3) <- f
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- f - 0.5 = znum
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,d0          (d0,d1) <-  0.5
	 moveq   #0,d1
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a2          upper part of constant sqrt(1/2)
	 bgt.s   f@@stepp10
	 blt.s   f@@step9
	    cmpa.l  #$667f3bcd,a3
	    bhi.s   f@@stepp10
f@@step9        movem.l d0-d1,movf_m_f3(a0) (f2,f3) <- 0.5
	       tst.w   movl_f2_f4(a0)      (f4,f5) <- 0.5
	       movem.l bogus4(a0),d4-d5    wait for the chip to finish
	       tst.w   mull_f0_f2(a0)      (f2,f3) <- znum * 0.5
	       movem.l bogus4(a0),d4-d5
	       tst.w   addl_f4_f2(a0)      (f2,f3) <- znum * 0.5 + 0.5
	       movem.l bogus4(a0),d4-d5
	       subq.w  #1,d7               don't forget to adjust exponent!
	       bra.s   f@@step11            (f2,f3) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
f@@stepp10 movem.l d0-d1,movf_m_f3(a0)   first, subtract 0.5 from znum
	 tst.w   subl_f2_f0(a0)         (f0,f1) <- znum - 0.5
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 movem.l a2-a3,movf_m_f5(a0)    (f4,f5) <- f
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- f * 0.5
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f2(a0)         (f2,f3) <- 0.5 + f * 0.5
	 movem.l bogus4(a0),d4-d5
*
*   Step 11. Have (f0,f1) <- znum and (f2,f3) <- zden. First compute z and w.
*
f@@step11 tst.w   divl_f2_f0(a0)         (f0,f1) <- znum / zden = z
	 movem.l bogus4(a0),d4-d5
	 tst.w   movl_f0_f2(a0)         (f2,f3) <- z
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f2_f2(a0)         (f2,f3) <- z * z = w
	 movem.l bogus4(a0),d4-d5
*
*  Evaluate A(w) and store the result in (a2,a3).
*
	 tst.w   movl_f0_f6(a0)         (f6,f7) <- z  (untouched by horner(a))
	 movem.l bogus4(a0),d4-d5
	 movea.l movf_f3_m(a0),a4       (a4,a5) <- w
	 movea.l movf_f2_m(a0),a5
	 lea     cff_loga,a6            address of the coefficients
	 moveq   #2,d0                  degree of the polynomial
	 bsr     flpt_horner            do the polynomial evaluation
	 movea.l movf_f1_m(a0),a2       (a2,a3) <- A(w)
	 movea.l movf_f0_m(a0),a3
*
*  Evaluate B(w), with the result in (f0,f1).
*
	 lea     cff_logb,a6            address of the coefficients
	 moveq   #3,d0                  degree of the polynomial
	 bsr     flpt_hornera           remember, (a4,a5) still has w!
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)). Remember that (f6,f7) <- z,
*  (a4,a5) <- w, (a2,a3) <- A(w), and (f0,f1) <- B(w).
*
	 movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- A(w)
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 movem.l a4-a5,movf_m_f1(a0)    (f0,f1) <- w
	 tst.w   mull_f2_f0(a0)         (f0,f1) <- w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   mull_f6_f0(a0)         (f0,f1) <- z*w*A(w)/B(w)
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f6_f0(a0)         (f0,f1) <- z + z*w*A(w)*B(w) = R(z)
	 movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
	 ext.l   d7                     extend the exponent of the argument
	 move.l  d7,movil_m_f2(a0)      (f2,f3) <- xn
	 movem.l bogus4(a0),d4-d5
	 move.l  #$bf2bd010,movf_m_f5(a0) (f4,f5) <- c2
	 move.l  #$5c610ca8,movf_m_f4(a0)
	 tst.w   mull_f2_f4(a0)         (f4,f5) <- xn * c2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f4_f0(a0)         (f0,f1) <- xn * c2 + R(z)
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe63000,movf_m_f5(a0) (f4,f5) <- c1
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f2(a0)         (f2,f3) <- xn * c1
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f0,f1) <- xn*c2+R(z) + xn*c1
	 movem.l bogus4(a0),d4-d5
*
*  Place result on the stack and return.
*
	 move.l  movf_f1_m(a0),d0       retrieve the result
	 move.l  movf_f0_m(a0),d1
	 movem.l (sp)+,a5-a6            restore Pascal dedicated registers
	 move.l  d0,4(sp)               get the result
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_ln
*
*       Description: Compute the natural logarithm of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument <= 0 returns an error.
*
*       References : radd, rmul, rdvd,
*                    soft_horner,soft_hornera, err_logerr
*                    intrel, intxp, setxp, adx, cff_loga, cff_logb
*
*******************************************************************************

soft_ln  move.l  4(sp),d0
	 ble     err_logerr     branch if less than or = to zero
	 move.l  8(sp),d1
*
*  Continue with the natural logarithm.
*
	 movem.l a5-a6,-(sp)    save dedicated registers
	 bsr     intxp          extract the exponent; operand in (d0,d1)
	 move.w  d7,-(sp)       place exponent into memory
	 clr.w   d7             map number into range [0.5,1)
	 bsr     setxp          compute value of f
	 movea.l d0,a0          save f in (a0,a1)
	 movea.l d1,a1
	 move.l  #$bfe00000,d2  combine f - 0.5 of step 9 and 10
	 moveq   #0,d3
	 bsr     radd           znum <-- (d0,d1)
*
*  Compare f against sqrt(1/2) to determine the correct branch.
*
	 cmpa.l  #$3fe6a09e,a0  upper part of constant sqrt(1/2)
	 bgt.s   stepp10
	 blt.s   step9
	    cmpa.l  #$667f3bcd,a1
	    bhi.s   stepp10
step9          movea.l d0,a2          save away znum in (a2,a3)
	       movea.l d1,a3
	       moveq   #-1,d7         zden <-- znum * 0.5 + 0.5
	       bsr     adx            znum * 0.5
	       move.l  #$3fe00000,d2  add the 0.5
	       moveq   #0,d3
	       bsr     radd
	       subq.w  #1,(sp)        don't forget to adjust exponent!
	       bra.s   step11         (d0,d1) equals zden
*
*  Step 10. Adjust znum and compute zden.
*
stepp10  move.l  #$bfe00000,d2  subtract 0.5
	 moveq   #0,d3
	 bsr     radd           znum correct, so now compute zden.
	 movea.l d0,a2          first, save znum away
	 movea.l d1,a3
	 moveq   #-1,d7         compute zden <-- f * 0.5 + 0.5
	 move.l  a0,d0
	 move.l  a1,d1
	 bsr     adx            f * 0.5
	 move.l  #$3fe00000,d2  add 0.5
	 moveq   #0,d3
	 bsr     radd           (d0,d1) contains zden; (a2,a3) has znum
*
*  Step 11. First compute z and w.
*
step11   move.l  d0,d2          place zden in correct registers for divide
	 move.l  d1,d3
	 move.l  a2,d0          z <-- znum / zden
	 move.l  a3,d1
	 bsr     rdvd
	 movea.l d0,a0          (a0,a1) <-- z
	 movea.l d1,a1
	 move.l  d0,d2          w <-- z * z
	 move.l  d1,d3
	 bsr     rmul
	 movea.l d0,a2          (a2,a3) <-- w
	 movea.l d1,a3
*
*  Evaluate A(w) and store the result on the stack.
*
	 movea.l d0,a4          place w in correct registers
	 movea.l d1,a5
	 lea     cff_loga,a6    address of the coefficients
	 moveq   #2,d0          degree of the polynomial
	 bsr     soft_horner    do the polynomial evaluation
	 movem.l d0-d1,-(sp)
*
*  Evaluate B(w) and leave result in (d0,d1).
*
	 movea.l a2,a4          place w in correct registers
	 movea.l a3,a5
	 lea     cff_logb,a6    address of the coefficients
	 moveq   #3,d0          degree of the polynomial
	 bsr     soft_hornera   do the polynomial evaluation
*
*  Evaluate R(z) = z + z * (w * A(w)/B(w)).
*
	 move.l  d0,d2          place B(w) in correct registers for divide
	 move.l  d1,d3
	 movem.l (sp)+,d0-d1    retrieve A(w)
	 bsr     rdvd           (d0,d1) <-- A(w)/B(w)
	 move.l  a2,d2          get w in (d2,d3)
	 move.l  a3,d3
	 bsr     rmul           (d0,d1) <-- w * A(w)/B(w)
	 move.l  a0,d2          place z in (d2,d3)
	 move.l  a1,d3
	 bsr     rmul           (d0,d1) <-- z * (w * A(w)/B(w))
	 move.l  a0,d2          (a0,a1) still has z
	 move.l  a1,d3
	 bsr     radd           (d0,d1) <-- z + z * (w * A(w)/B(w))
	 movea.l d0,a0          (a0,a1) <-- R(z)
	 movea.l d1,a1
*
*  Finish the computation.
*
	 move.w  (sp)+,d0       get integer exponent
	 ext.l   d0
	 bsr     lntrel         convert exponent into a real
	 movea.l d0,a2          (a2,a3) <-- xn
	 movea.l d1,a3
	 move.l  #$bf2bd010,d2
	 move.l  #$5c610ca8,d3
	 bsr     rmul           xn * c2
	 move.l  a0,d2          get R(z)
	 move.l  a1,d3
	 bsr     radd           xn * c2 + R(z)
	 movem.l d0-d1,-(sp)    save intermediate result
	 move.l  a2,d0          get xn
	 move.l  a3,d1
	 move.l  #$3fe63000,d2
	 moveq   #0,d3
	 bsr     rmul           xn * c1
	 movem.l (sp)+,d2-d3    restore intermediate result
	 bsr     radd           (xn * c2 + R(z)) + (xn * c1)
*
*  Place result on the stack and return.
*
	 movem.l (sp)+,a5-a6    restore dedicated registers
	 move.l  d1,8(sp)
	 move.l  d0,4(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_sqrt
*
*       Description: Compute the square root of the numeric item on top
*                    of the stack. This algorithm is taken from the book
*                    "Software Manual for the Elementary Functions" by
*                    William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                  : 2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - original exponent of argument
*                    (f6,f7)    - f
*                    (f0,f1)    - partial results
*                    d4,d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : intxp, setxp, adx, flpt_cardaddr, err_sqrterr
*
*******************************************************************************

flpt_sqrt move.l 8(sp),d1
	 move.l  4(sp),d0
	 bmi     errmaybe               branch if negative
	 bne.s   f@@sqrok                if non-zero, have positive number
	    rts                            else result = operand = 0
*
*  Continue with the square root.
*
f@@sqrok  lea     flpt_cardaddr,a0       point to the start of the hardware
	 bsr     intxp                  extract exponent
	 move.w  d7,d6                  save exponent
	 clr.w   d7                     new unbiased exponent
	 bsr     setxp                  (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movem.l d0-d1,movf_m_f7(a0)    f will be in (f7,f6) throughout
	 move.l  #$3fe2e297,movf_m_f1(a0) constant .59016
	 move.l  #$396d0918,movf_m_f0(a0) the rest of it
	 tst.w   mull_f6_f0(a0)         (f1,f0) <- .59016 * f
	 movem.l bogus4(a0),d4-d5       wait until the chip has finished
	 move.l  #$3fdab535,movf_m_f3(a0) constant .41731
	 move.l  #$0092ccf7,movf_m_f2(a0) the rest of it
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0
	 movem.l bogus4(a0),d4-d5
*
*  Compute z = (y0 + f/y0).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y0
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- y0 + f/y0 = z
	 movem.l bogus4(a0),d4-d5
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/z
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fd00000,movf_m_f5(a0) (f5,f4) <- .25
	 move.l  #0,movf_m_f4(a0)
	 tst.w   mull_f4_f0(a0)         (f1,f0) <- .25*z
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/z + .25*z = y2
	 movem.l bogus4(a0),d4-d5
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 tst.w   movl_f6_f2(a0)         (f3,f2) <- f
	 movem.l bogus4(a0),d4-d5
	 tst.w   divl_f0_f2(a0)         (f3,f2) <- f/y2
	 movem.l bogus4(a0),d4-d5
	 tst.w   addl_f2_f0(a0)         (f1,f0) <- f/y2 + y2
	 movem.l bogus4(a0),d4-d5
	 move.l  #$3fe00000,movf_m_f3(a0) (f3,f2) <- .5
	 move.l  #0,movf_m_f2(a0)
	 tst.w   mull_f2_f0(a0)         (f1,f0) <- .5 * (y2 + f/y2)
	 movem.l bogus4(a0),d4-d5
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  d6,d7                  save the original exponent
	 asr.w   #1,d7                  the original exponent
	 bcc.s   f@@evenexp              branch if the exponent was even
	    move.l  #$3fe6a09e,movf_m_f3(a0) (f3,f2) <- sqrt(1/2)
	    move.l  #$667f3bcd,movf_m_f2(a0)
	    tst.w   mull_f2_f0(a0)         (f1,f0) <- (f1,f0) * sqrt(1/2)
	    movem.l bogus4(a0),d4-d5
	    addq.w  #1,d6                  (n+1) / 2 --> m
f@@evenexp asr.w  #1,d6                  adjust the old exponent
	 move.l  movf_f1_m(a0),d0       retrieve the last partial result
	 move.l  movf_f0_m(a0),d1
	 move.w  d6,d7                  place here for the adx
	 bsr     adx                    put in the result exponent
*
* Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
*
*  Negative number, so check for sqrt(-0).
*
errmaybe cmp.l   #minuszero,d0          first, check for a -0
	 bne     err_sqrterr
	    rts                            else return with -0 as the result
	 page
*******************************************************************************
*
*       Procedure  : soft_sqrt
*
*       Description: Compute the square root of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as valid input
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument < 0 returns an error.
*
*       References : radd, rmul, rdvd, intxp, setxp, adx, err_sqrterr
*
*******************************************************************************

soft_sqrt move.l 8(sp),d1
	 move.l 4(sp),d0
	 bmi.s   errmaybe       branch if negative
	 bne.s   sqrok          if non-zero, have positive number
	    rts                    else result = operand = 0
*
*  Continue with the square root.
*
sqrok    bsr     intxp          extract exponent
	 movea.w d7,a4          save exponent
	 clr.w   d7             new unbiased exponent
	 bsr     setxp          (d0,d1) is now f
*
*  Compute initial guess of y0 = 0.41731 + 0.59016 * f.
*
	 movea.l d0,a0          (a0,a1) <-- f
	 movea.l d1,a1
	 move.l  #$3fe2e297,d2  constant 0.59016
	 move.l  #$396d0918,d3
	 bsr     rmul           (d0,d1) contains first term
	 move.l  #$3fdab535,d2  constant 0.41731
	 move.l  #$0092ccf7,d3
	 bsr     radd           (d0,d1) has initial guess for y
	 movea.l d0,a2          (a2,a3) <-- y
	 movea.l d1,a3
*
*  Compute z = (y0 + f/y0).
*
	 move.l  d0,d2          (d2,d3) <-- y0
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <-- f
	 move.l  a1,d1
	 bsr     rdvd           f/y0
	 move.l  a2,d2          (d2,d3) <-- y0
	 move.l  a3,d3
	 bsr     radd           (d0,d1) <-- z = y0 + f/y0
	 movea.l d0,a2          (a2,a3) <- z
	 movea.l d1,a3
*
*  Compute y2 = .25*z + f/z. Note that y1 is not computed.
*
	 move.l  d0,d2          (d2,d3) <- z
	 move.l  d1,d3
	 move.l  a0,d0          (d0,d1) <- f
	 move.l  a1,d1
	 bsr     rdvd           f/z
	 move.l  d0,d2          (d2,d3) <- f/z
	 move.l  d1,d3
	 move.l  a2,d0          (d0,d1) <- z
	 move.l  a3,d1
	 moveq   #-2,d7         'adx' does not affect (d2,d3) = f/z
	 bsr     adx            .25*x
	 bsr     radd           y2 <-- .25*x + f/z
	 movea.l d0,a2          (a2,a3) <- y2
	 movea.l d1,a3
*
*  Compute y3 = .5 * (y2 + f/y2).
*
	 move.l  d0,d2          place y2 in divisor registers
	 move.l  d1,d3
	 move.l  a0,d0          load up the value of f; y is in (d0,d1)
	 move.l  a1,d1
	 bsr     rdvd           f/y computed; result in (d0,d1)
	 move.l  a2,d2          get y2
	 move.l  a3,d3
	 bsr     radd           y2 + f/y2 computed; result in (d0,d1)
	 moveq   #-1,d7
	 bsr     adx            y = y3 <- 0.5 * (y2 + f/y2)
*
*  Test for even or odd exponent, and adjust accordingly.
*
	 move.w  a4,d7          get the initial exponent guess
	 asr.w   #1,d7          see if even or odd
	 bcc.s   evenexp        branch if even exponent
	    move.l  #$3fe6a09e,d2  else adjust mantissa accordingly
	    move.l  #$667f3bcd,d3  constant sqrt(1/2)
	    bsr     rmul           y <- y * sqrt(1/2)
	    move.w  a4,d7          get old exponent
	    addq.w  #1,d7          adjust it
	    asr.w   #1,d7          (n + 1) / 2  --> m
evenexp  bsr     adx            d7 has result exponent; (d0,d1) the rest
*
*  Place result on the stack.
*
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : flpt_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Hardware floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : a0         - address of the floating point card
*                    d7         - n
*                    d6         - sign of the argument
*                    d4-d5      - results of the bogus reads
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : An argument too large returns an error.
*
*       References : flpt_horner, flpt_hornera, compare, cff_atnp, cff_atnq,
*                    flpt_cardaddr
*
*******************************************************************************

flpt_arctan move.l 4(sp),d0             get the argument
	 move.l  8(sp),d1
	 lea     flpt_cardaddr,a0       must save all the fp registers
	 movem.l a5-a6,-(sp)            save Pascal dedicated registers
	 move.l  d0,d6                  save the sign
	 cmp.l   #minuszero,d6          check if a -0
	 bne.s   act@@1                  branch if not a -0
	    moveq   #0,d6                  set the sign to +
act@@1    bclr    #31,d0                 f <- abs(x)
	 movem.l d0-d1,movf_m_f1(a0)    (f0,f1) <- f
*
*  Adjust f if > 1. Note that underflow is possible if x is real large.
*  If underflowed, then the argument was real large, so return pi/2 as
*  the angle.
*
	 move.l  #$3ff00000,d2          floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   f@@invertf              branch if have to invert f
	    moveq   #0,d7                  else set n to 0
	    bra.s   f@@step7                and continue with the computation
f@@invertf movem.l d2-d3,movf_m_f3(a0)   (f2,f3) <- 1
	 tst.w   divl_f0_f2(a0)         (f2,f3) <- 1/f
	 movem.l bogus4(a0),d4-d5       wait for the chip to finish
	 btst    #q,status(a0)          see if had an underflow
	 beq     f@@arc34                branch if no underflow
	    move.l  #$3ff921fb,d0          top part of pi/2
	    move.l  #$54442d18,d1          rest of result of pi/2
	    tst.l   d6                     check sign of original operand
	    bpl     f@@donee                pos arguement yields positive result
	       bset   #31,d0                  if negative, result is negative
	       bra     f@@donee                place result on stack and return
f@@arc34  tst.w   movl_f2_f0(a0)         no error, so (f0,f1) <- f = 1/f
	 movem.l bogus4(a0),d4-d5
	 moveq   #2,d7                  n <- 2
*
*  Adjust f if > 2 - sqrt(3).
*
f@@step7  move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 move.l  #$3fd12614,d2          2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   f@@steep10              branch if no more adjusting of f or n
	    addq.w  #1,d7                  step 8; first adjust n
	    move.l  #$3ffbb67a,movf_m_f3(a0) (f2,f3) <- sqrt(3)
	    move.l  #$e8584caa,movf_m_f2(a0)
	    tst.w   addl_f0_f2(a0)         (f2,f3) <- f + sqrt(3)
	    movem.l bogus4(a0),d4-d5
	    move.l  #$3fe76cf5,movf_m_f5(a0) (f4,f5) <-  sqrt(3) - 1 = a
	    move.l  #$d0b09955,movf_m_f4(a0)
	    tst.w   mull_f0_f4(a0)         (f4,f5) <- a*f
	    movem.l bogus4(a0),d4-d5
	    move.l  #$bfe00000,movf_m_f7(a0) (f6,f7) <-  -1/2
	    move.l  #0,movf_m_f6(a0)
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- a*f - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w    addl_f6_f4(a0)        (f4,f5) <- (a*f - 1/2) - 1/2
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f4_f0(a0)         (f0,f1) <- ((a*f - 1/2) - 1/2) + f
	    movem.l bogus4(a0),d4-d5
	    tst.w   divl_f2_f0(a0)         (f0,f1) <- (f0,f1)/denominator = f
	    movem.l bogus4(a0),d4-d5
*
*  Evaluate the polynomials if required. (f0,f1) <- f.
*
f@@steep10  tst.w movl_f0_f6(a0)         result must be in (f6,f7) for later
	 movem.l bogus4(a0),d4-d5
	 move.l  movf_f1_m(a0),d0       get f
	 move.l  movf_f0_m(a0),d1
	 bclr    #31,d0                 abs(f)
	 move.l  #$3e46a09e,d2          eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare                is abs(f) < eps?
	 blt     f@@step15
	    tst.w   movl_f0_f2(a0)         (f2,f3) <- f
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f2_f2(a0)         (f2,f3) <- f*f = g
	    movem.l bogus4(a0),d4-d5
	    movea.l movf_f3_m(a0),a4       (a4,a5) <- g
	    movea.l movf_f2_m(a0),a5
	    moveq   #3,d0                  degree of the polynomial
	    lea     cff_atnp,a6            point to the coefficients
	    tst.w   movl_f0_f6(a0)         (f6,f7)<- f (untouched by horner(a))
	    movem.l bogus4(a0),d4-d5
	    bsr     flpt_horner            compute pg; result in (f0,f1)
	    movem.l a4-a5,movf_m_f3(a0)    (f2,f3) <- g
	    tst.w   mull_f0_f2(a0)         (f2,f3) <- g * p(g)
	    movem.l bogus4(a0),d4-d5
	    moveq   #4,d0                  degree for the next polynomial
	    lea     cff_atnq,a6
	    movea.l movf_f3_m(a0),a2       (a2,a3) <- g * p(g)
	    movea.l movf_f2_m(a0),a3
	    bsr     flpt_hornera           compute q(g); result in (f0,f1)
	    movem.l a2-a3,movf_m_f3(a0)    (f2,f3) <- g * p(g)
	    tst.w   divl_f0_f2(a0)         (f2,f3) <- g * p(g) / q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   mull_f6_f2(a0)         (f2,f3) <- f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
	    tst.w   addl_f2_f6(a0)         result= (f6,f7) <- f + f*g*p(g)/q(g)
	    movem.l bogus4(a0),d4-d5
*
*  Finish the computation.
*
f@@step15 tst.w   d7                     check n
	 beq.s   f@@checksgn             fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   f@@val23                branch if adjustment to result
	       move.l  #$3fe0c152,movf_m_f3(a0)  (f2,f3) <- a(1) = pi/6
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/6
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val23     tst.w  negl_f6_f6(a0)       else result <- -result
	    movem.l bogus4(a0),d4-d5
	    cmp.w   #2,d7               check n for either a 2 or 3
	    beq.s   f@@val2              branch if equal to 2
	       move.l  #$3ff0c152,movf_m_f3(a0)  (f2,f3) <- a(3) = pi/3
	       move.l  #$382d7366,movf_m_f2(a0)
	       tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/3
	       movem.l bogus4(a0),d4-d5
	       bra.s   f@@checksgn
f@@val2      move.l  #$3ff921fb,movf_m_f3(a0)  (f2,f3) <- a(2) = pi/2
	    move.l  #$54442d18,movf_m_f2(a0)
	    tst.w   addl_f2_f6(a0)         (f6,f7) <- res + pi/2
	    movem.l bogus4(a0),d4-d5
*
f@@checksgn move.l movf_f7_m(a0),d0      (d0,d1) <- result
	 move.l  movf_f6_m(a0),d1
	 tst.l   d6                     check sign of original argument
	 bpl.s   f@@donee
	    bchg    #31,d0                 negate sign of result
*
*  Place result on the stack and return.
*
f@@donee  movem.l  (sp)+,a5-a6           restore Pascal dedicated registers
	 move.l  d0,4(sp)
	 move.l  d1,8(sp)
	 rts
	 page
*******************************************************************************
*
*       Procedure  : soft_arctan
*
*       Description: Compute the arctangent of the numeric item on the
*                    top of the stack. This algorithm is taken
*                    from the book "Software Manual for the Elementary
*                    Functions" by William Cody and William Waite.
*
*       Author     : Paul Beiser
*
*       Revisions  : 1.0  06/01/81
*                    2.0  09/01/83  For:
*                            o Calls to software floating point
*                            o To check for -0 as a valid operand
*
*       Parameters : 4(sp)      - real argument
*
*       Registers  : See text of the code.
*
*       Result     : Returned on the top of the stack.
*
*       Error(s)   : None
*
*       References : radd, rmul, rdvd, soft_horner, soft_hornera, compare,
*                    cff_atnp, cff_atnq
*
*******************************************************************************

soft_arctan move.l  4(sp),d0
	 move.l  8(sp),d1
	 movem.l a5-a6,-(sp)    save dedicated registers
	 swap    d0             save the sign
	 move.w  d0,-(sp)
	 swap    d0             restore correct order of the operand
	 cmpi.l  #minuszero,d0  check for a -0
	 bne.s   sftat@@1        branch if not a -0
	    move.w  #1,(sp)        else change sign to +
sftat@@1  bclr    #31,d0         f <- abs(x)
*
*  Adjust f if > 1. Underflow is possible here if f is real large.
*
	 move.l  #$3ff00000,d2  floating point 1
	 moveq   #0,d3
	 bsr     compare
	 bgt.s   invertf        branch if have to invert f
	    clr.w   -(sp)          else set n to 0
	    bra.s   step7          and continue with the computation
invertf  exg     d0,d2          place 1 as the dividend, and
	 exg     d1,d3          f as the divisor
	    move.l  sysglobals-10(a5),-(sp)  TRY, could get real underflow
	    pea     recoverr       address for the RECOVER
	    move.l  sp,sysglobals-10(a5)     new TRY block
	    bsr     rdvd           reciprocate the argument
	    addq.l  #4,sp          pop off the error address
	    move.l  (sp)+,sysglobals-10(a5)  restore old TRY block
	 move.w  #2,-(sp)       n <- 2
*
*  Save value of n. Adjust f if > 2 - sqrt(3).
*
step7    move.l  #$3fd12614,d2  2 - sqrt(3)
	 move.l  #$5e9ecd56,d3
	 bsr     compare
	 ble.s   steep10         branch if no more adjusting of f or n required
	    addq.w  #1,(sp)        step 8; first adjust n
	    movea.l d0,a0          (a0,a1) <- f
	    movea.l d1,a1
	    move.l  #$3ffbb67a,d2  sqrt(3)
	    move.l  #$e8584caa,d3
	    bsr     radd           f + sqrt(3)
	    movea.l d0,a2          save denominator for now
	    movea.l d1,a3
	    move.l  #$3fe76cf5,d0  a = sqrt(3) - 1
	    move.l  #$d0b09955,d1
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           a * f
	    move.l  #$bfe00000,d2  -1/2
	    movea.l d2,a4          save for next radd
	    moveq   #0,d3
	    bsr     radd           a * f - 1/2
	    move.l  a4,d2          -1/2
	    moveq   #0,d3
	    bsr     radd           (a * f - 1/2) - 1/2
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           ( (a * f - 1/2) - 1/2) + f
	    move.l  a2,d2          restore f + sqrt(3)
	    move.l  a3,d3
	    bsr     rdvd           new f
*
*  Evaluate the polynomials if required.
*
steep10  movea.l d0,a0          save the sign of f
	 bclr    #31,d0         abs(f)
	 move.l  #$3e46a09e,d2  eps = 2^(-53/2)
	 move.l  #$667f3bcd,d3
	 bsr     compare        is abs(f) < eps?
	 blt.s   step12a
	    move.l  a0,d0          restore sign of f
	    movea.l d1,a1          (a0,a1) <- f
	    move.l  d0,d2
	    move.l  d1,d3
	    bsr     rmul           g <- f * f
	    movea.l d0,a4          (a4,a5) <- g
	    movea.l d1,a5
	    moveq   #3,d0          degree of the polynomial
	    lea     cff_atnp,a6    point to the coefficients
	    bsr     soft_horner
	    move.l  a4,d2          get g
	    move.l  a5,d3
	    bsr     rmul           g * p(g)
	    movea.l d0,a2          (a2,a3) <- g * p(g)
	    movea.l d1,a3
	    moveq   #4,d0          degree for the next polynomial
	    lea     cff_atnq,a6
	    bsr     soft_hornera   q(g)
	    move.l  d0,d2          divisor
	    move.l  d1,d3
	    move.l  a2,d0          dividend
	    move.l  a3,d1
	    bsr     rdvd           g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     rmul           f * g * p(g) / q(g)
	    move.l  a0,d2          get f
	    move.l  a1,d3
	    bsr     radd           result <- f + f*g*p(g)/q(g)
	    bra.s   step15
step12a  move.l  a0,d0          f is the result
*
*  Finish the computation.
*
step15   move.w  (sp)+,d7       retrieve n
	 beq.s   checksgn       fast path if n is zero
	    cmp.w   #1,d7
	    bne.s   val23          branch if adjustment to result necesary
	       move.l  #$3fe0c152,d2  a(1) = pi/6
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val23       bchg   #31,d0          else result <- -result
	    cmp.w   #2,d7          check n for either a 2 or 3
	    beq.s   val2           branch if equal to 2
	       move.l  #$3ff0c152,d2  a(3) = pi/3
	       move.l  #$382d7366,d3
	       bsr     radd
	       bra.s   checksgn
val2        move.l  #$3ff921fb,d2  a(2) = pi/2
	    move.l  #$54442d18,d3
	    bsr     radd
*
checksgn tst.w   (sp)+          check sign of original argument
	 bpl.s   donee
	    bchg    #31,d0         negate sign of result
*
*  Place result on the stack and return.
*
donee    movem.l  (sp)+,a5-a6   restore dedicated registers
	 move.l   d0,4(sp)
	 move.l   d1,8(sp)
	 rts
*
*  Argument was too large. Return pi/2 as the result.
*
recoverr move.l  (sp)+,sysglobals-10(a5)  restore TRY block
	 move.l  #$3ff921fb,d0  else underflowed, so get top part of pi/2
	 move.l  #$54442d18,d1  rest of result of pi/2
	 tst.w   (sp)+          check sign of original operand
	 bpl     donee          positive argument yields positive result
	    bset   #31,d0          if negative, result is negative
	    bra     donee          place result on stack and return
	page
*******************************************************************************
*
*       Procedures : Assorted
*
*       Description: The rest of the procedures are a collection of
*                    utility interface routines for the compiler.
*                    See the text of the procedures for information
*                    concerning them.
*
*       Author     : Brad Ritter
*
*       Revisions  : 1.0  06/01/81
*
*******************************************************************************

asm_bcdround equ *
	movea.l (sp)+,a0        return address
	movea.l (sp)+,a1        address of string
	move.w  (sp)+,d0        number of digits
	movea.l (sp)+,a2        address of bcd_strtype
	addq.l  #3,a1           point to s[3]
	movea.l a1,a3           save address of s[3]
	addq.l  #2,a2           point to first bcd digit
*
*  Move the digits to s[3..17]
*
	moveq   #8,d1           count
bcdr1   move.b  (a2)+,d3
	move.b  d3,d4
	andi.b  #$F,d4
	andi.b  #$F0,d3
	lsr.b   #4,d3
	move.b  d3,(a1)+
	move.b  d4,(a1)+
	subq.b  #1,d1
	bgt.s   bcdr1
*
*  Round to proper number of digits
*
	lea     0(a3,d0.w),a1   address off digit to round
	addq.b  #5,(a1)
bcdr2   cmpi.b  #10,(a1)
	blt.s   bcdr5
	subi.b  #10,(a1)
	cmpa.l  a1,a3
	beq.s   bcdr3           all done but final carry
	subq.l  #1,a1
	addq.b  #1,(a1)
	bra.s   bcdr2
*
bcdr3   move.b  #49,(a3)+       '1'
	subq.b  #1,d0
bcdr4   move.b  #48,(a3)+       '0'
	subi.b  #1,d0
	bge.s   bcdr4           add 1 extra 0
*
*  Increment exponent by 1
*
	addq.w  #1,(a2)
	jmp     (a0)
*
*  Convert to characters
*
bcdr5   addi.b  #48,(a3)+
	subi.b  #1,d0
	bgt.s   bcdr5
	jmp     (a0)


asm_pack movea.l (sp)+,a0       return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a1        destination
	movea.l (sp)+,a2        source
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   pack
	movea.l d5,a1
	move.w  #8,d4

pack    cmpi.w  #2,d2           unpacksize = word ?
	bne.s   pack1
	move.w  (a2)+,d3
	bra.s   pack3

pack1   cmpi.w  #1,d2           unpacksize = byte ?
	bne.s   pack2
	move.b  (a2)+,d3
	bra.s   pack3

pack2   move.l  (a2)+,d3        unpacksize = long

pack3   move.w  d4,d5           bit index
	subi.w  #32,d5
	add.w   d1,d5
	neg.w   d5              #32 - offset - width

	cmpi.w  #16,d1          fieldwidth = 16 ?
	bne.s   pack4
	move.l  #65535,d6
	bra.s   pack8

pack4   cmpi.w  #8,d1           fieldwidth = 8 ?
	bne.s   pack5
	move.l  #255,d6
	bra.s   pack8

pack5   cmpi.w  #4,d1           fieldwidth = 4 ?
	bne.s   pack6
	moveq   #15,d6
	bra.s   pack8

pack6   cmpi.w  #2,d1           fieldwidth = 2 ?
	bne.s   pack7
	move.l  #3,d6
	bra.s   pack8

pack7   moveq   #1,d6           fieldwidth = 1

pack8   lsl.l   d5,d6           position mask
	lsl.l   d5,d3           position source
	and.l   d6,d3           mask off source
	not.l   d6
	and.l   d6,(a1)         clr dest field
	or.l    d3,(a1)         store source in dest
	add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   pack9
	subi.w  #16,d4
	addq.l  #2,a1
pack9   subq.l  #1,d0
	bne.s   pack
	jmp     (a0)

asm_unpack movea.l (sp)+,a0     return address
	move.l  (sp)+,d0        count
	move.w  (sp)+,d1        field width (1,2,4,8,16)
	move.w  (sp)+,d2        unpacksize (1,2,4)
	movea.l (sp)+,a2        source
	movea.l (sp)+,a1        destination
	move.b  (sp)+,d3        signed fields ?
	clr.w   d4              bit index

	move.l  a1,d5
	bclr    #0,d5           make dest even
	beq.s   unpack
	movea.l d5,a1
	move.w  #8,d4

unpack  move.l  (a2),d5
	lsl.l   d4,d5           left justify field
	move.w  d1,d6
	subi.w  #32,d6
	neg.w   d6              32 - fieldwidth
	tst.b   d3
	bne.s   unpack1
	lsr.l   d6,d5           right justify unsigned
	bra.s   unpack2
unpack1 asr.l   d6,d5           right justify signed

unpack2 add.w   d1,d4           increment bit index
	cmpi.w  #15,d4
	ble.s   unpack3
	subi.w  #16,d4
	addq.l  #2,a2

unpack3 cmpi.w  #2,d2           unpacksize = 2 ?
	bne.s   unpack4
	move.w  d5,(a1)+
	bra.s   unpack6

unpack4 cmpi.w  #1,d2           unpacksize =1 ?
	bne.s   unpack5
	move.b  d5,(a1)+
	bra.s   unpack6

unpack5 move.l  d5,(a1)+

unpack6 subq.l  #1,d0
	bne.s   unpack
	jmp     (a0)

asm_hex movea.l 4(sp),a0        address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
h@@x1    clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   h@@x2
	subq.b  #1,d2
	bgt.s   h@@x1
	bra.s   error           {sb}
h@@x5    clr.l   d1
	move.b  (a0)+,d1
h@@x2    subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #9,d1
	ble.s   h@@x3
	subi.w  #17,d1          ord('A') = 65   {sb}
	blt.s   error
	cmpi.w  #5,d1           {sb}
	ble.s   h@@x6            {sb}
	subi.w  #32,d1          ord('a') = 97
	blt.s   error
	cmpi.w  #5,d1           {sb}
	bgt.s   error
h@@x6    addi.w  #10,d1          {sb}
h@@x3    move.l  d0,d3
	andi.l  #$F0000000,d3
	bne.s   error
	asl.l   #4,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   h@@x5
h@@x4    move.l  d0,4(sp)
	rts

tstblk  addi.w #48,d1
tstblk0 cmpi.b #32,d1           test for trailing blanks
	bne.s  error
	subq.b #1,d2
	ble.s  h@@x4
	move.b (a0)+,d1
	bra.s  tstblk0

error   move.w  #-8,sysglobals-2(a5)
	trap    #10             value range error

asm_octal movea.l 4(sp),a0      address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
oct@@l1  clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   oct@@l2
	subq.b  #1,d2
	bgt.s   oct@@l1
	bra.s   error           {sb}
oct@@l5  clr.l   d1
	move.b  (a0)+,d1
oct@@l2  subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #7,d1
	bgt.s   error
	move.l  d0,d3
	andi.l  #$E0000000,d3
	bne.s   error
	asl.l   #3,d0
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   oct@@l5
oct@@l4  move.l  d0,4(sp)
	rts

asm_binary movea.l 4(sp),a0     address of string
	clr.l   d0              result
	move.b  (a0)+,d2        length of string
	beq.s   error           {sb}
bin@@ry1 clr.l   d1
	move.b  (a0)+,d1
	cmpi.b  #32,d1          ord(' ') = 32
	bne.s   bin@@ry2
	subq.b  #1,d2
	bgt.s   bin@@ry1
	bra.s   error           {sb}
bin@@ry5 clr.l   d1
	move.b  (a0)+,d1
bin@@ry2 subi.w  #48,d1          ord('0') = 48
	blt.s   tstblk
	cmpi.w  #1,d1
	bgt.s   error
	asl.l   #1,d0
	bcs.s   error
	add.l   d1,d0
	subq.b  #1,d2
	bgt.s   bin@@ry5
bin@@ry4 move.l  d0,4(sp)
	rts

asm_addsetrange equ *
*************************************************
*       d3, d4, a4 are not used by addelement   *
*************************************************
	movea.l (sp)+,a4        return address
	move.w  (sp)+,d3        hivalue
	move.w  (sp)+,d4        lovalue
	cmp.w   d3,d4
	ble.s   e@@add
	move.l  (sp)+,(sp)
e@@end   jmp     (a4)
e@@add   ext.l   d4
	move.l  d4,-(sp)
	jsr     asm_adelement
	addq.w  #1,d4
	cmp.w   d3,d4
	bgt     e@@end
	move.l  (sp),-(sp)
	bra.s   e@@add

***********************************************************************

retfalse clr.b  -(sp)           false
	jmp     (a0)
rettrue move.b  #1,-(sp)        true
	jmp     (a0)

***********************************************************************

asm_eq  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	beq     rettrue
	bra     retfalse

asm_ne  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bne     rettrue
	bra     retfalse

asm_lt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	blt     rettrue
	bra     retfalse

asm_le  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	ble     rettrue
	bra     retfalse

asm_gt  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bgt     rettrue
	bra     retfalse

asm_ge  movea.l (sp)+,a0        return address
	movem.l (sp)+,d0-d3     d0,d1 - opnd1   d2,d3 - opnd2
	bsr     compare
	bge     rettrue
	bra     retfalse
	page
****************************************************************************
*
*  Code for all the math errors.
*
err_intover  trap    #4
err_divzero  move.w  #esc_flpt_divzer,sysglobals-2(a5)
	     trap    #10
err_overflow move.w  #esc_flpt_over,sysglobals-2(a5)
	     trap    #10
err_underflow move.w #esc_flpt_under,sysglobals-2(a5)
	     trap    #10
err_trigerr  move.w  #esc_flpt_sincos,sysglobals-2(a5)
	     trap    #10
err_logerr   move.w  #esc_flpt_natlog,sysglobals-2(a5)
	     trap    #10
err_sqrterr  move.w  #esc_flpt_sqrt,sysglobals-2(a5)
	     trap    #10
err_illnumbr move.w  #esc_flpt_relbcd,sysglobals-2(a5)
	     trap    #10
err_impvalue move.w  #esc_flpt_bcdrel,sysglobals-2(a5)
	     trap    #10
err_miscel   move.w  #esc_flpt_misc,sysglobals-2(a5)
	     trap    #10
	     end

@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.2
log
@Bug fix in compiler support by BAR
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d4852 1
a4852 1
	moveq   #31,d6
@


12.2
log
@Added Dragon "support", ie co-reside peacefully with Dragon which shares
address $5c0001 with Float card (98635) as DIO ID. We now check explicitly
to see if this ID is $0a (Float card id).
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@d67 1
d2630 1
d2642 5
@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
