/[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.157 by dirk, Fri Mar 1 00:19:20 2002 UTC revision 1.158 by mvo, Mon Mar 11 19:10:01 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 3691  scm_num2dbl (SCM a, const char *why) Line 3695  scm_num2dbl (SCM a, const char *why)
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
# Line 3724  scm_divide (SCM x, SCM y) Line 3755  scm_divide (SCM x, SCM y)
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      }      }
# Line 3765  scm_divide (SCM x, SCM y) Line 3803  scm_divide (SCM x, SCM y)
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);
# Line 3870  scm_divide (SCM x, SCM y) Line 3915  scm_divide (SCM x, SCM y)
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      }      }

Legend:
Removed from v.1.157  
changed lines
  Added in v.1.158

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