From 50eb784bfcf15ee3c6b0b53d747db92673395040 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:34 -0800
Subject: Import Upstream version 5e3

---
 Transcen.scm | 170 ++++++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 105 insertions(+), 65 deletions(-)

(limited to 'Transcen.scm')

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)))
-- 
cgit v1.2.3