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) |
3649 |
#undef FUNC_NAME |
#undef FUNC_NAME |
3650 |
|
|
3651 |
|
|
3652 |
|
/* The code below for complex division is adapted from the GNU |
3653 |
|
libstdc++, which adapted it from f2c's libF77, and is subject to |
3654 |
|
this copyright: */ |
3655 |
|
|
3656 |
|
/**************************************************************** |
3657 |
|
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. |
3658 |
|
|
3659 |
|
Permission to use, copy, modify, and distribute this software |
3660 |
|
and its documentation for any purpose and without fee is hereby |
3661 |
|
granted, provided that the above copyright notice appear in all |
3662 |
|
copies and that both that the copyright notice and this |
3663 |
|
permission notice and warranty disclaimer appear in supporting |
3664 |
|
documentation, and that the names of AT&T Bell Laboratories or |
3665 |
|
Bellcore or any of their entities not be used in advertising or |
3666 |
|
publicity pertaining to distribution of the software without |
3667 |
|
specific, written prior permission. |
3668 |
|
|
3669 |
|
AT&T and Bellcore disclaim all warranties with regard to this |
3670 |
|
software, including all implied warranties of merchantability |
3671 |
|
and fitness. In no event shall AT&T or Bellcore be liable for |
3672 |
|
any special, indirect or consequential damages or any damages |
3673 |
|
whatsoever resulting from loss of use, data or profits, whether |
3674 |
|
in an action of contract, negligence or other tortious action, |
3675 |
|
arising out of or in connection with the use or performance of |
3676 |
|
this software. |
3677 |
|
****************************************************************/ |
3678 |
|
|
3679 |
SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); |
SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); |
3680 |
/* Divide the first argument by the product of the remaining |
/* Divide the first argument by the product of the remaining |
3681 |
arguments. If called with one argument @var{z1}, 1/@var{z1} is |
arguments. If called with one argument @var{z1}, 1/@var{z1} is |
3702 |
} else if (SCM_COMPLEXP (x)) { |
} else if (SCM_COMPLEXP (x)) { |
3703 |
double r = SCM_COMPLEX_REAL (x); |
double r = SCM_COMPLEX_REAL (x); |
3704 |
double i = SCM_COMPLEX_IMAG (x); |
double i = SCM_COMPLEX_IMAG (x); |
3705 |
double d = r * r + i * i; |
if (r <= i) { |
3706 |
return scm_make_complex (r / d, -i / d); |
double t = r / i; |
3707 |
|
double d = i * (1.0 + t * t); |
3708 |
|
return scm_make_complex (t / d, -1.0 / d); |
3709 |
|
} else { |
3710 |
|
double t = i / r; |
3711 |
|
double d = r * (1.0 + t * t); |
3712 |
|
return scm_make_complex (1.0 / d, -t / d); |
3713 |
|
} |
3714 |
} else { |
} else { |
3715 |
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
3716 |
} |
} |
3746 |
{ |
{ |
3747 |
double r = SCM_COMPLEX_REAL (y); |
double r = SCM_COMPLEX_REAL (y); |
3748 |
double i = SCM_COMPLEX_IMAG (y); |
double i = SCM_COMPLEX_IMAG (y); |
3749 |
double d = r * r + i * i; |
if (r <= i) { |
3750 |
return scm_make_complex ((a * r) / d, (-a * i) / d); |
double t = r / i; |
3751 |
|
double d = i * (1.0 + t * t); |
3752 |
|
return scm_make_complex ((a * t) / d, -a / d); |
3753 |
|
} else { |
3754 |
|
double t = i / r; |
3755 |
|
double d = r * (1.0 + t * t); |
3756 |
|
return scm_make_complex (a / d, -(a * t) / d); |
3757 |
|
} |
3758 |
} |
} |
3759 |
} else { |
} else { |
3760 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3837 |
} else if (SCM_COMPLEXP (y)) { |
} else if (SCM_COMPLEXP (y)) { |
3838 |
double ry = SCM_COMPLEX_REAL (y); |
double ry = SCM_COMPLEX_REAL (y); |
3839 |
double iy = SCM_COMPLEX_IMAG (y); |
double iy = SCM_COMPLEX_IMAG (y); |
3840 |
double d = ry * ry + iy * iy; |
if (ry <= iy) { |
3841 |
return scm_make_complex ((rx * ry + ix * iy) / d, |
double t = ry / iy; |
3842 |
(ix * ry - rx * iy) / d); |
double d = iy * (1.0 + t * t); |
3843 |
|
return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); |
3844 |
|
} else { |
3845 |
|
double t = iy / ry; |
3846 |
|
double d = ry * (1.0 + t * t); |
3847 |
|
return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); |
3848 |
|
} |
3849 |
} else { |
} else { |
3850 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3851 |
} |
} |