Import Upstream version 3a5upstream/3a5

1 files changed, 52 insertions, 4 deletions

diff --git a/jscheme.init b/jscheme.init
index 241a2d8..9e568b7 100644
--- a/jscheme.init
+++ b/jscheme.init
@@ -37,7 +37,7 @@
 
 ;;@ (scheme-implementation-version) should return a string describing
 ;;; the version the scheme implementation loading this file.
-(define (scheme-implementation-version) "6.2")
+(define (scheme-implementation-version) "7.2")
 
 ;;@ (implementation-vicinity) should be defined to be the pathname of
 ;;; the directory where any auxillary files to your Scheme
@@ -235,6 +235,9 @@
 
 	))
 
+;;@ (FILE-POSITION <port> . <k>)
+(define (file-position . args) #f)
+
 ;;@ (OUTPUT-PORT-WIDTH <port>)
 (define (output-port-width . arg) 79)
 
@@ -262,9 +265,9 @@
 
 ;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
 ;;; use this definition if your system doesn't have such a procedure.
-(define (force-output . arg)
-  (.flush  (if (pair? arg) (car args)
-	       (current-output-port))))
+(define (force-output . args)
+  (.flush (if (pair? args) (car args)
+	      (current-output-port))))
 
 ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
 ;;; port versions of CALL-WITH-*PUT-FILE.
@@ -289,6 +292,51 @@
 ;;@ SLIB:EVAL is single argument eval using the top-level (user) environment.
 (define slib:eval eval)
 
+;;;; Fix numeric functions (per R5RS)
+
+(define gcd
+  (let ((gcd gcd))
+    (lambda args (if (null? args) 0 (apply gcd args)))))
+
+(define lcm
+  (let ((lcm lcm))
+    (lambda args (if (null? args) 1 (apply lcm args)))))
+
+(define round
+  (let ((round round))
+    (lambda (x) (if (inexact? x)
+		    (exact->inexact (round x))
+		    (round x)))))
+
+(define atan
+  (let ((atan atan))
+    (lambda (z . y)
+      (if (null? y)
+	  (atan z)
+	  (atan (/ z (car y)))))))
+
+(define (integer-expt n k)
+  (if (= 1 (abs n))
+      (if (even? k) (* n n) n)
+      (do ((x n (* x x))
+	   (j k (quotient j 2))
+	   (acc 1 (if (even? j) acc (* x acc))))
+	  ((<= j 1)
+	   (case j
+	     ((0) acc)
+	     ((1) (* x acc))
+	     (else (slib:error 'integer-expt n k)))))))
+
+(define expt
+  (let ((expt expt))
+    (lambda (z1 z2)
+      (cond ((and (exact? z2)
+		  (exact? z1)
+		  (not (and (zero? z1) (negative? z2))))
+	     (integer-expt z1 z2))
+	    ((zero? z2) (+ 1 (* z1 z2)))
+	    (else (expt z1 z2))))))
+
 ;; If your implementation provides R4RS macros:
 ;(define macro:eval slib:eval)
 ;(define macro:load load)