/[guile]/guile/guile-core/libguile/numbers.c
ViewVC logotype

Diff of /guile/guile-core/libguile/numbers.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.135.2.6 by mdj, Sat Sep 22 21:42:14 2001 UTC revision 1.135.2.7 by mvo, Mon Mar 11 19:26:15 2002 UTC
# Line 1  Line 1 
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)
# Line 3645  scm_num2dbl (SCM a, const char *why) Line 3649  scm_num2dbl (SCM a, const char *why)
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
# Line 3671  scm_divide (SCM x, SCM y) Line 3702  scm_divide (SCM x, SCM y)
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      }      }
# Line 3708  scm_divide (SCM x, SCM y) Line 3746  scm_divide (SCM x, SCM y)
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);
# Line 3792  scm_divide (SCM x, SCM y) Line 3837  scm_divide (SCM x, SCM y)
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      }      }

Legend:
Removed from v.1.135.2.6  
changed lines
  Added in v.1.135.2.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26