From d4957beb0c59bf1b6caa1e4f16035396c20ab847 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sun, 22 Feb 2004 14:56:32 +0000 Subject: [PATCH] Move rational-safely to ansi-aux.lsp to avoid gcl eval-when breakage --- ansi-tests/ansi-aux.lsp | 17 +++++++++++++++-- ansi-tests/numbers-aux.lsp | 17 ----------------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 77627e8c..174f804d 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -1613,5 +1613,18 @@ the condition to go uncaught if it cannot be classified." (return hi) (setq lo mid)))))) - - \ No newline at end of file +(defun rational-safely (x) + "Rational a floating point number, making sure the rational + number isn't 'too big'. This is important in implementations such + as clisp where the floating bounds can be very large." + (assert (floatp x)) + (multiple-value-bind (significand exponent sign) + (integer-decode-float x) + (let ((limit 1000) + (radix (float-radix x))) + (cond + ((< exponent (- limit)) + (* significand (expt radix (- limit)) sign)) + ((> exponent limit) + (* significand (expt radix limit) sign)) + (t (rational x)))))) \ No newline at end of file diff --git a/ansi-tests/numbers-aux.lsp b/ansi-tests/numbers-aux.lsp index cd5bdd5d..c1f78d61 100644 --- a/ansi-tests/numbers-aux.lsp +++ b/ansi-tests/numbers-aux.lsp @@ -19,23 +19,6 @@ (eqlt (abs x) (abs y))) (t (eqlt x y)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun rational-safely (x) - "Rational a floating point number, making sure the rational - number isn't 'too big'. This is important in implementations such - as clisp where the floating bounds can be very large." - (assert (floatp x)) - (multiple-value-bind (significand exponent sign) - (integer-decode-float x) - (let ((limit 1000) - (radix (float-radix x))) - (cond - ((< exponent (- limit)) - (* significand (expt radix (- limit)) sign)) - ((> exponent limit) - (* significand (expt radix limit) sign)) - (t (rational x))))))) - (defconstant +rational-most-negative-short-float+ (rational-safely most-negative-short-float)) -- GitLab