Commit fcda692a authored by pfdietz's avatar pfdietz

Add tests for *modules*, require, provide. Move some aux functions to...

Add tests for *modules*, require, provide.  Move some aux functions to ansi-aux.lsp.  Get rid of warning in ftruncate.lsp
parent 57371c7e
...@@ -324,8 +324,8 @@ the condition to go uncaught if it cannot be classified." ...@@ -324,8 +324,8 @@ the condition to go uncaught if it cannot be classified."
(or (not (second results)) (or (not (second results))
(not (first results)))))) (not (first results))))))
(declaim (ftype (function (&rest function) (values function &optional)) ;; (declaim (ftype (function (&rest function) (values function &optional))
compose)) ;; compose))
(defun compose (&rest fns) (defun compose (&rest fns)
(let ((rfns (reverse fns))) (let ((rfns (reverse fns)))
...@@ -1039,3 +1039,21 @@ the condition to go uncaught if it cannot be classified." ...@@ -1039,3 +1039,21 @@ the condition to go uncaught if it cannot be classified."
;;; Approximate equality function ;;; Approximate equality function
(defun approx= (x y &optional (eps (epsilon x))) (defun approx= (x y &optional (eps (epsilon x)))
(<= (abs (/ (- x y) (max (abs x) 1))) eps)) (<= (abs (/ (- x y) (max (abs x) 1))) eps))
(defun epsilon (number)
(etypecase number
(complex (* 2 (epsilon (realpart number)))) ;; crude
(short-float short-float-epsilon)
(single-float single-float-epsilon)
(double-float double-float-epsilon)
(long-float long-float-epsilon)
(rational 0)))
(defun negative-epsilon (number)
(etypecase number
(complex (* 2 (negative-epsilon (realpart number)))) ;; crude
(short-float short-float-negative-epsilon)
(single-float single-float-negative-epsilon)
(double-float double-float-negative-epsilon)
(long-float long-float-negative-epsilon)
(rational 0)))
...@@ -20,3 +20,7 @@ ...@@ -20,3 +20,7 @@
(deftest features.3 (deftest features.3
(not (member :cltl2 *features*)) (not (member :cltl2 *features*))
t) t)
(deftest features.4
(notnot (every #'symbolp *features*))
t)
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
(in-package :cl-test) (in-package :cl-test)
(compile-and-load "numbers-aux.lsp") (compile-and-load "numbers-aux.lsp")
(ignore-errors (compile-and-load "ftruncate-aux.lsp")) (compile-and-load "ftruncate-aux.lsp")
;;; Error tests ;;; Error tests
......
...@@ -8,7 +8,6 @@ ...@@ -8,7 +8,6 @@
(load "describe.lsp") (load "describe.lsp")
(load "disassemble.lsp") (load "disassemble.lsp")
(load "environment-functions.lsp") (load "environment-functions.lsp")
(load "features.lsp")
(load "room.lsp") (load "room.lsp")
(load "time.lsp") (load "time.lsp")
(load "trace.lsp") (load "trace.lsp")
......
...@@ -8,5 +8,5 @@ ...@@ -8,5 +8,5 @@
(load "compile-file.lsp") (load "compile-file.lsp")
(load "load.lsp") (load "load.lsp")
(load "with-compilation-unit.lsp") (load "with-compilation-unit.lsp")
(load "features.lsp")
(load "modules.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Apr 30 19:51:06 2005
;;;; Contains: Tests of *MODULES*, PROVIDE, and REQUIRE
(in-package :cl-test)
(deftest modules.1
(notnot (every #'stringp *modules*))
t)
(deftest modules.2
(let ((*modules* *modules*))
(provide "FOO")
(notnot (member "FOO" *modules* :test #'string=)))
t)
(deftest modules.3
(let ((*modules* *modules*))
(provide "FOO")
(provide "FOO")
(count "FOO" *modules* :test #'string=))
1)
(deftest modules.4
(let ((*modules* *modules*))
(provide "FOO")
(require "FOO")
(values)))
(deftest modules.5
(let ((*modules* *modules*))
(provide :|FOO|)
(notnot (member "FOO" *modules* :test #'string=)))
t)
(deftest modules.6
(let ((*modules* *modules*))
(provide "FOO")
(require :|FOO|)
(values)))
(deftest modules.7
(let ((*modules* *modules*)
(fn 'modules7-fun))
(when (fboundp fn) (fmakunbound fn))
(require "MODULES-7" #p"modules7.lsp")
(funcall fn))
:good)
(deftest modules.8
(let ((*modules* *modules*)
(fns '(modules8a-fun modules8b-fun)))
(dolist (fn fns)
(when (fboundp fn) (fmakunbound fn)))
(require "MODULES-8" '(#p"modules8a.lsp" #p"modules8b.lsp"))
(mapcar #'funcall fns))
(:good :also-good))
(deftest modules.9
(signals-error (require "AB7djaCgaaL") error)
t)
(deftest modules.10
(do-special-strings
(s "FOO")
(let ((*modules* *modules*))
(provide s)
(assert (member "FOO" *modules* :test #'string=))))
nil)
(deftest modules.11
(do-special-strings
(s "FOO")
(let ((*modules* *modules*))
(provide "FOO")
(require s)
(values)))
nil)
(deftest modules.12
(unless (member "Z" *modules* :test #'string=)
(let ((*modules* *modules*))
(provide #\Z)
(not (member "Z" *modules* :test #'string=))))
nil)
(deftest modules.13
(unless (member "Z" *modules* :test #'string=)
(let ((*modules* *modules*))
(provide "Z")
(require #\Z)
nil))
nil)
\ No newline at end of file
(in-package :cl-test)
(defun modules7-fun () :good)
(in-package :cl-test)
(defun modules8a-fun () :good)
(in-package :cl-test)
(defun modules8b-fun () :also-good)
...@@ -299,24 +299,6 @@ ...@@ -299,24 +299,6 @@
(floating-point-overflow () t)) (floating-point-overflow () t))
collect (list x y (min x y))))) collect (list x y (min x y)))))
(defun epsilon (number)
(etypecase number
(complex (* 2 (epsilon (realpart number)))) ;; crude
(short-float short-float-epsilon)
(single-float single-float-epsilon)
(double-float double-float-epsilon)
(long-float long-float-epsilon)
(rational 0)))
(defun negative-epsilon (number)
(etypecase number
(complex (* 2 (negative-epsilon (realpart number)))) ;; crude
(short-float short-float-negative-epsilon)
(single-float single-float-negative-epsilon)
(double-float double-float-negative-epsilon)
(long-float long-float-negative-epsilon)
(rational 0)))
;;; Compute the number of digits that can be added to 1.0 in the appropriate ;;; Compute the number of digits that can be added to 1.0 in the appropriate
;;; float type, a rational representation of the smallest radix^(-k) s.t. ;;; float type, a rational representation of the smallest radix^(-k) s.t.
;;; 1.0 + radix^(-k) /= 1.0, and the float representation of that value. ;;; 1.0 + radix^(-k) /= 1.0, and the float representation of that value.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment