summaryrefslogtreecommitdiffstats
path: root/Transcen.scm
diff options
context:
space:
mode:
authorThomas Bushnell <tb@debian.org>2006-10-23 23:31:59 -0700
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:35 -0800
commit906cc4f0899080f1b832af98b7ccbcc257b8a64e (patch)
tree14e3ec231debdca4da9c1a3ccc0536033c1c8a4b /Transcen.scm
parent3d573fa54db0fdcae8b2a20356faa46c8e335206 (diff)
parent50eb784bfcf15ee3c6b0b53d747db92673395040 (diff)
downloadscm-906cc4f0899080f1b832af98b7ccbcc257b8a64e.tar.gz
scm-906cc4f0899080f1b832af98b7ccbcc257b8a64e.zip
Import Debian changes 5e3-1debian/5e3-1
scm (5e3-1) unstable; urgency=low * New upstream release. * debian/control (Architecture): Add ia64 to list of supported archs. Now everything but s390 is listed. (Closes: #335980) (Build-Depends): Require at least version 3a4 of slib. * Change to continue.h from version 5e1-2 repeated here. * Change to xgen.scm from version 5e2-4 repeated here. * Change to scm.1 from version 5e2-4 repeated here.
Diffstat (limited to 'Transcen.scm')
-rw-r--r--Transcen.scm170
1 files changed, 105 insertions, 65 deletions
diff --git a/Transcen.scm b/Transcen.scm
index 3b87837..fe0330d 100644
--- a/Transcen.scm
+++ b/Transcen.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1992, 1993, 1995, 1997, 2005 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1993, 1995, 1997, 2005, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -45,122 +45,162 @@
(define compile-allnumbers #t) ;for HOBBIT compiler
-(define $pi (* 4 ($atan 1)))
+;;;; Legacy real function names
+(cond
+ ((defined? $exp)
+ (define real-sqrt $sqrt)
+ (define real-exp $exp)
+ (define real-expt $expt)
+ (define real-ln $log)
+ (define real-log10 $log10)
+
+ (define real-sin $sin)
+ (define real-cos $cos)
+ (define real-tan $tan)
+ (define real-asin $asin)
+ (define real-acos $acos)
+ (define real-atan $atan)
+
+ (define real-sinh $sinh)
+ (define real-cosh $cosh)
+ (define real-tanh $tanh)
+ (define real-asinh $asinh)
+ (define real-acosh $acosh)
+ (define real-atanh $atanh))
+
+ (else
+ (define $sqrt real-sqrt)
+ (define $exp real-exp)
+ (define $expt real-expt)
+ (define $log real-ln)
+ (define $log10 real-log10)
+
+ (define $sin real-sin)
+ (define $cos real-cos)
+ (define $tan real-tan)
+ (define $asin real-asin)
+ (define $acos real-acos)
+ (define $atan real-atan)
+
+ (define $sinh real-sinh)
+ (define $cosh real-cosh)
+ (define $tanh real-tanh)
+ (define $asinh real-asinh)
+ (define $acosh real-acosh)
+ (define $atanh real-atanh)))
+
+(define $pi (* 4 (real-atan 1)))
(define pi $pi)
(define (pi* z) (* $pi z))
(define (pi/ z) (/ $pi z))
+;;;; Complex functions
+
(define (exp z)
- (if (real? z) ($exp z)
- (make-polar ($exp (real-part z)) (imag-part z))))
+ (if (real? z) (real-exp z)
+ (make-polar (real-exp (real-part z)) (imag-part z))))
-(define (log z)
+(define (ln z)
(if (and (real? z) (>= z 0))
- ($log z)
- (make-rectangular ($log (magnitude z)) (angle z))))
+ (real-ln z)
+ (make-rectangular (real-ln (magnitude z)) (angle z))))
+(define log ln)
(define (sqrt z)
(if (real? z)
- (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
- ($sqrt z))
- (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
+ (if (negative? z) (make-rectangular 0 (real-sqrt (- z)))
+ (real-sqrt z))
+ (make-polar (real-sqrt (magnitude z)) (/ (angle z) 2))))
(define (sinh z)
- (if (real? z) ($sinh z)
+ (if (real? z) (real-sinh z)
(let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sinh x) ($cos y))
- (* ($cosh x) ($sin y))))))
+ (make-rectangular (* (real-sinh x) (real-cos y))
+ (* (real-cosh x) (real-sin y))))))
(define (cosh z)
- (if (real? z) ($cosh z)
+ (if (real? z) (real-cosh z)
(let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cosh x) ($cos y))
- (* ($sinh x) ($sin y))))))
+ (make-rectangular (* (real-cosh x) (real-cos y))
+ (* (real-sinh x) (real-sin y))))))
(define (tanh z)
- (if (real? z) ($tanh z)
+ (if (real? z) (real-tanh z)
(let* ((x (* 2 (real-part z)))
(y (* 2 (imag-part z)))
- (w (+ ($cosh x) ($cos y))))
- (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
+ (w (+ (real-cosh x) (real-cos y))))
+ (make-rectangular (/ (real-sinh x) w) (/ (real-sin y) w)))))
(define (asinh z)
- (if (real? z) ($asinh z)
+ (if (real? z) (real-asinh z)
(log (+ z (sqrt (+ (* z z) 1))))))
(define (acosh z)
(if (and (real? z) (>= z 1))
- ($acosh z)
+ (real-acosh z)
(log (+ z (sqrt (- (* z z) 1))))))
(define (atanh z)
(if (and (real? z) (> z -1) (< z 1))
- ($atanh z)
+ (real-atanh z)
(/ (log (/ (+ 1 z) (- 1 z))) 2)))
(define (sin z)
- (if (real? z) ($sin z)
+ (if (real? z) (real-sin z)
(let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sin x) ($cosh y))
- (* ($cos x) ($sinh y))))))
+ (make-rectangular (* (real-sin x) (real-cosh y))
+ (* (real-cos x) (real-sinh y))))))
(define (cos z)
- (if (real? z) ($cos z)
+ (if (real? z) (real-cos z)
(let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cos x) ($cosh y))
- (- (* ($sin x) ($sinh y)))))))
+ (make-rectangular (* (real-cos x) (real-cosh y))
+ (- (* (real-sin x) (real-sinh y)))))))
(define (tan z)
- (if (real? z) ($tan z)
+ (if (real? z) (real-tan z)
(let* ((x (* 2 (real-part z)))
(y (* 2 (imag-part z)))
- (w (+ ($cos x) ($cosh y))))
- (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
+ (w (+ (real-cos x) (real-cosh y))))
+ (make-rectangular (/ (real-sin x) w) (/ (real-sinh y) w)))))
(define (asin z)
(if (and (real? z) (>= z -1) (<= z 1))
- ($asin z)
+ (real-asin z)
(* -i (asinh (* +i z)))))
(define (acos z)
(if (and (real? z) (>= z -1) (<= z 1))
- ($acos z)
+ (real-acos z)
(+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
(define (atan z . y)
(if (null? y)
- (if (real? z) ($atan z)
+ (if (real? z)
+ (real-atan z)
(/ (log (/ (- +i z) (+ +i z))) +2i))
($atan2 z (car y))))
;;;; SRFI-70
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2))))
- (integer-expt z1 z2))
- ((zero? z2) (+ 1 (* z1 z2)))
- ((and (real? z2) (real? z1) (positive? z1))
- ($expt z1 z2))
- (else
- (exp (* (if (zero? z1) (real-part z2) z2) (log z1))))))))
-
-(define quo
- (let ((integer-quotient quotient))
- (lambda (x1 x2)
- (if (and (exact? x1) (exact? x2))
- (integer-quotient x1 x2)
- (truncate (/ x1 x2))))))
-
-(define rem
- (let ((integer-remainder remainder))
- (lambda (x1 x2)
- (if (and (exact? x1) (exact? x2))
- (integer-remainder x1 x2)
- (- x1 (* x2 (quotient x1 x2)))))))
-
-(define mod
- (let ((integer-modulo modulo))
- (lambda (x1 x2)
- (if (and (exact? x1) (exact? x2))
- (integer-modulo x1 x2)
- (- x1 (* x2 (floor (/ x1 x2))))))))
+(define (expt z1 z2)
+ (cond ((and (exact? z2) (not (and (zero? z1) (negative? z2))))
+ (integer-expt z1 z2))
+ ((zero? z2) (+ 1 (* z1 z2)))
+ ((and (real? z2) (real? z1) (positive? z1))
+ (real-expt z1 z2))
+ (else
+ (exp (* (if (zero? z1) (real-part z2) z2) (log z1))))))
+
+(define (quo x1 x2)
+ (if (and (exact? x1) (exact? x2))
+ (quotient x1 x2)
+ (truncate (/ x1 x2))))
+
+(define (rem x1 x2)
+ (if (and (exact? x1) (exact? x2))
+ (remainder x1 x2)
+ (- x1 (* x2 (quo x1 x2)))))
+
+(define (mod x1 x2)
+ (if (and (exact? x1) (exact? x2))
+ (modulo x1 x2)
+ (- x1 (* x2 (floor (/ x1 x2))))))
(define (exact-round x) (inexact->exact (round x)))
(define (exact-floor x) (inexact->exact (floor x)))