1 |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
|
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories |
4 |
|
* and Bellcore. See scm_divide. |
5 |
|
* |
6 |
|
* |
7 |
* This program is free software; you can redistribute it and/or modify |
* This program is free software; you can redistribute it and/or modify |
8 |
* it under the terms of the GNU General Public License as published by |
* it under the terms of the GNU General Public License as published by |
9 |
* the Free Software Foundation; either version 2, or (at your option) |
* the Free Software Foundation; either version 2, or (at your option) |
3695 |
#undef FUNC_NAME |
#undef FUNC_NAME |
3696 |
|
|
3697 |
|
|
3698 |
|
/* The code below for complex division is adapted from the GNU |
3699 |
|
libstdc++, which adapted it from f2c's libF77, and is subject to |
3700 |
|
this copyright: */ |
3701 |
|
|
3702 |
|
/**************************************************************** |
3703 |
|
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. |
3704 |
|
|
3705 |
|
Permission to use, copy, modify, and distribute this software |
3706 |
|
and its documentation for any purpose and without fee is hereby |
3707 |
|
granted, provided that the above copyright notice appear in all |
3708 |
|
copies and that both that the copyright notice and this |
3709 |
|
permission notice and warranty disclaimer appear in supporting |
3710 |
|
documentation, and that the names of AT&T Bell Laboratories or |
3711 |
|
Bellcore or any of their entities not be used in advertising or |
3712 |
|
publicity pertaining to distribution of the software without |
3713 |
|
specific, written prior permission. |
3714 |
|
|
3715 |
|
AT&T and Bellcore disclaim all warranties with regard to this |
3716 |
|
software, including all implied warranties of merchantability |
3717 |
|
and fitness. In no event shall AT&T or Bellcore be liable for |
3718 |
|
any special, indirect or consequential damages or any damages |
3719 |
|
whatsoever resulting from loss of use, data or profits, whether |
3720 |
|
in an action of contract, negligence or other tortious action, |
3721 |
|
arising out of or in connection with the use or performance of |
3722 |
|
this software. |
3723 |
|
****************************************************************/ |
3724 |
|
|
3725 |
SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); |
SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); |
3726 |
/* Divide the first argument by the product of the remaining |
/* Divide the first argument by the product of the remaining |
3727 |
arguments. If called with one argument @var{z1}, 1/@var{z1} is |
arguments. If called with one argument @var{z1}, 1/@var{z1} is |
3755 |
} else if (SCM_COMPLEXP (x)) { |
} else if (SCM_COMPLEXP (x)) { |
3756 |
double r = SCM_COMPLEX_REAL (x); |
double r = SCM_COMPLEX_REAL (x); |
3757 |
double i = SCM_COMPLEX_IMAG (x); |
double i = SCM_COMPLEX_IMAG (x); |
3758 |
double d = r * r + i * i; |
if (r <= i) { |
3759 |
return scm_make_complex (r / d, -i / d); |
double t = r / i; |
3760 |
|
double d = i * (1.0 + t * t); |
3761 |
|
return scm_make_complex (t / d, -1.0 / d); |
3762 |
|
} else { |
3763 |
|
double t = i / r; |
3764 |
|
double d = r * (1.0 + t * t); |
3765 |
|
return scm_make_complex (1.0 / d, -t / d); |
3766 |
|
} |
3767 |
} else { |
} else { |
3768 |
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
3769 |
} |
} |
3803 |
{ |
{ |
3804 |
double r = SCM_COMPLEX_REAL (y); |
double r = SCM_COMPLEX_REAL (y); |
3805 |
double i = SCM_COMPLEX_IMAG (y); |
double i = SCM_COMPLEX_IMAG (y); |
3806 |
double d = r * r + i * i; |
if (r <= i) { |
3807 |
return scm_make_complex ((a * r) / d, (-a * i) / d); |
double t = r / i; |
3808 |
|
double d = i * (1.0 + t * t); |
3809 |
|
return scm_make_complex ((a * t) / d, -a / d); |
3810 |
|
} else { |
3811 |
|
double t = i / r; |
3812 |
|
double d = r * (1.0 + t * t); |
3813 |
|
return scm_make_complex (a / d, -(a * t) / d); |
3814 |
|
} |
3815 |
} |
} |
3816 |
} else { |
} else { |
3817 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3915 |
} else if (SCM_COMPLEXP (y)) { |
} else if (SCM_COMPLEXP (y)) { |
3916 |
double ry = SCM_COMPLEX_REAL (y); |
double ry = SCM_COMPLEX_REAL (y); |
3917 |
double iy = SCM_COMPLEX_IMAG (y); |
double iy = SCM_COMPLEX_IMAG (y); |
3918 |
double d = ry * ry + iy * iy; |
if (ry <= iy) { |
3919 |
return scm_make_complex ((rx * ry + ix * iy) / d, |
double t = ry / iy; |
3920 |
(ix * ry - rx * iy) / d); |
double d = iy * (1.0 + t * t); |
3921 |
|
return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); |
3922 |
|
} else { |
3923 |
|
double t = iy / ry; |
3924 |
|
double d = ry * (1.0 + t * t); |
3925 |
|
return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); |
3926 |
|
} |
3927 |
} else { |
} else { |
3928 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3929 |
} |
} |