Commit 0936f9a5 authored by pfdietz's avatar pfdietz

Moved more functions from ansi-aux.lsp off to more specific aux files. Added...

Moved more functions from ansi-aux.lsp off to more specific aux files.  Added package-aux.lsp, types-aux.lsp
parent 91294450
This diff is collapsed.
......@@ -4,6 +4,9 @@
;;;; Contains: Tests of DEFPACKAGE
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
(declaim (optimize (safety 3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -4,6 +4,9 @@
;;;; Contains: Tests of DO-EXTERNAL-SYMBOLS
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
(declaim (optimize (safety 3)))
(defun collect-external-symbols (pkg)
......
......@@ -4,6 +4,9 @@
;;;; Contains: Tests of DO-SYMBOLS
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
(declaim (optimize (safety 3)))
(deftest do-symbols.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "numbers-aux.lsp")
(deftest epsilons.1
(loop for e in (list short-float-epsilon single-float-epsilon
double-float-epsilon long-float-epsilon)
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
;;; Create a package name that does not collide with an existing package
;;; name or nickname
(defvar *import-package-test-name*
......
......@@ -8,6 +8,29 @@
(eval-when (load eval)
(compile-and-load "random-aux.lsp"))
;;; Binary search on reals
(defun float-binary-search (fn lo hi)
"FN is a function that, if true for X, is true for all Y > X.
Find the smallest float in [lo,hi] for which the function
return true."
(assert (functionp fn))
(assert (floatp lo))
(assert (floatp hi))
(assert (<= lo hi))
(assert (funcall fn hi))
(loop while (<= lo hi)
do (let ((mid (/ (+ lo hi) 2)))
(if (funcall fn mid)
(if (= mid hi)
(return hi)
(setq hi mid))
(if (= mid lo)
(return hi)
(setq lo mid))))))
(defun eqlzt (x y)
"Return T if (eql x y) or if both are zero of the same type."
(cond
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jun 21 20:59:17 2004
;;;; Contains: Aux. functions for package tests
(in-package :cl-test)
(defmacro test-with-package-iterator (package-list-expr &rest symbol-types)
"Build an expression that tests the with-package-iterator form."
(let ((name (gensym))
(cht-var (gensym))
(pkg-list-var (gensym)))
`(let ((,cht-var (make-hash-table))
(,pkg-list-var ,package-list-expr)
(fail-count 0))
(with-package-iterator (,name ,pkg-list-var
,@(copy-list symbol-types))
;; For each symbol, check that name is returning appropriate
;; things
(loop
(block fail
(multiple-value-bind (more sym access pkg)
(,name)
(unless more (return nil))
(setf (gethash sym ,cht-var) t) ;; note presence of symbol
;; Check that its access status is in the list,
;; that pkg is a package,
;; that the symbol is in the package,
;; and that (in the package) it has the correct access type
(unless (member access (quote ,(copy-list symbol-types)))
(unless (> fail-count +fail-count-limit+)
(format t "Bad access type: ~S ==> ~A~%" sym access))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (packagep pkg)
(unless (> fail-count +fail-count-limit+)
(format t "Not a package: ~S ==> ~S~%" sym pkg))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(multiple-value-bind (sym2 access2)
(find-symbol (symbol-name sym) pkg)
(unless (or (eqt sym sym2)
(member sym2 (package-shadowing-symbols pkg)))
(unless (> fail-count +fail-count-limit+)
(format t "Not same symbol: ~S ~S~%" sym sym2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (eqt access access2)
(unless (> fail-count +fail-count-limit+)
(format t "Not same access type: ~S ~S ~S~%"
sym access access2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil)))))))
;; now, check that each symbol in each package has
;; been properly found
(loop
for p in ,pkg-list-var do
(block fail
(do-symbols (sym p)
(multiple-value-bind (sym2 access)
(find-symbol (symbol-name sym) p)
(unless (eqt sym sym2)
(unless (> fail-count +fail-count-limit+)
(format t "Not same symbol (2): ~S ~S~%"
sym sym2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (or (not (member access
(quote ,(copy-list symbol-types))))
(gethash sym ,cht-var))
(format t "Symbol not found: ~S~%" sym)
(incf fail-count)
(return-from fail nil))))))
(or (zerop fail-count) fail-count))))
(defun with-package-iterator-internal (packages)
(test-with-package-iterator packages :internal))
(defun with-package-iterator-external (packages)
(test-with-package-iterator packages :external))
(defun with-package-iterator-inherited (packages)
(test-with-package-iterator packages :inherited))
(defun with-package-iterator-all (packages)
(test-with-package-iterator packages :internal :external :inherited))
(defun num-external-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-external-symbols (s p num)
(declare (ignorable s))
(incf num))))
(defun external-symbols-in-package (p)
(let ((symbols nil))
(do-external-symbols (s p)
(push s symbols))
(sort symbols #'(lambda (s1 s2) (string< (symbol-name s1)
(symbol-name s2))))))
(defun num-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-symbols (s p num)
(declare (ignorable s))
(incf num))))
(defun sort-symbols (sl)
(sort (copy-list sl)
#'(lambda (x y)
(or
(string< (symbol-name x)
(symbol-name y))
(and (string= (symbol-name x)
(symbol-name y))
(string< (package-name (symbol-package x))
(package-name (symbol-package y))))))))
(defun sort-package-list (x)
(sort (copy-list x)
#'string<
:key #'package-name))
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; *array-element-types* is defined in ansi-aux.lsp
(deftest subtypep.array.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; SUBTYPEP on CONS types
(defvar *cons-types*
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
(deftest subtypep.eql.1
(let ((s1 (copy-seq "abc"))
(s2 (copy-seq "abc")))
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;;;;;;
(deftest subtypep.float.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
(deftest subtypep.fixnum-or-bignum
(check-equivalence '(or fixnum bignum) 'integer)
nil)
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; SUBTYPEP on MEMBER types
(deftest subtypep.member.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; SUBTYPEP on rational types
(deftest subtypep.rational.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; SUBTYPEP on real types
(deftest subtypep.real.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; More subtypep tests are in types-and-class.lsp
(deftest subtypep.order.1
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
;;; Union of a type with its complement is universal
(deftest type-or-not-type-is-everything
......
......@@ -7,6 +7,8 @@
(in-package :cl-test)
(compile-and-load "types-aux.lsp")
(declaim (optimize (safety 3)))
(deftest boolean-type.1
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jun 21 20:14:38 2004
;;;; Contains: Aux. functions for types tests
(in-package :cl-test)
(defun classes-are-disjoint (c1 c2)
"If either c1 or c2 is a builtin class or the name of a builtin
class, then check for disjointness. Return a non-NIL list
of failed subtypep relationships, if any."
(and (or (is-builtin-class c1)
(is-builtin-class c2))
(check-disjointness c1 c2)))
(declaim (special *subtype-table*))
(defun types.6-body ()
(loop
for p in *subtype-table*
for tp = (car p)
append
(and (not (member tp '(sequence cons list t)))
(let ((message (check-subtypep tp 'atom t t)))
(if message (list message))))))
(defparameter *type-list* nil)
(defparameter *supertype-table* nil)
(defun types.9-body ()
(let ((tp-list (append '(keyword atom list)
(loop for p in *subtype-table* collect (car p))))
(result-list))
(setf tp-list (remove-duplicates tp-list))
;; TP-LIST is now a list of unique CL type names
;; Store it in *TYPE-LIST* so we can inspect it later if this test
;; fails. The variable is also used in test TYPES.9A
(setf *type-list* tp-list)
;; Compute all pairwise SUBTYPEP relationships among
;; the elements of *TYPE-LIST*.
(let ((subs (make-hash-table :test #'eq))
(sups (make-hash-table :test #'eq)))
(loop
for x in tp-list do
(loop
for y in tp-list do
(multiple-value-bind (result good)
(subtypep* x y)
(declare (ignore good))
(when result
(pushnew x (gethash y subs))
(pushnew y (gethash x sups))))))
;; Store the supertype relations for later inspection
;; and use in test TYPES.9A
(setf *supertype-table* sups)
;; Check that the relation we just computed is transitive.
;; Return a list of triples on which transitivity fails.
(loop
for x in tp-list do
(let ((sub-list (gethash x subs))
(sup-list (gethash x sups)))
(loop
for t1 in sub-list do
(loop
for t2 in sup-list do
(multiple-value-bind (result good)
(subtypep* t1 t2)
(when (and good (not result))
(pushnew (list t1 x t2) result-list
:test #'equal)))))))
result-list)))
;;; TYPES.9-BODY returns a list of triples (T1 T2 T3)
;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3)))
;;; (and where SUBTYPEP succeeds in each case, returning true as its
;;; second return value.)
(defun types.9a-body ()
(cond
((not (and *type-list* *supertype-table*))
(format nil "Run test type.9 first~%")
nil)
(t
(loop
for tp in *type-list*
sum
(let ((sups (gethash tp *supertype-table*)))
(loop
for x in *universe*
sum
(handler-case
(cond
((not (typep x tp)) 0)
(t
(loop
for tp2 in sups
count
(handler-case
(and (not (typep x tp2))
(progn
(format t "Found element of ~S not in ~S: ~S~%"
tp tp2 x)
t))
(condition (c) (format t "Error ~S occured: ~S~%"
c tp2)
t)))))
(condition (c) (format t "Error ~S occured: ~S~%" c tp)
1))))))))
(defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
(multiple-value-bind
(sub valid)
(subtypep type1 type2)
(unless (constantp type1) (setq type1 (list 'quote type1)))
(unless (constantp type2) (setq type2 (list 'quote type2)))
(if (or (and valid sub (not is-sub))
(and valid (not sub) is-sub)
(and (not valid) should-be-valid))
`(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid))
nil)))
;;; Check that the subtype relationships implied
;;; by disjointness are not contradicted. Return NIL
;;; if ok, or a list of error messages if not.
;;; Assumes the types are nonempty.
(defun check-disjointness (type1 type2)
(append
(check-subtypep type1 type2 nil)
(check-subtypep type2 type1 nil)
(check-subtypep type1 `(not ,type2) t)
(check-subtypep type2 `(not ,type1) t)
(check-subtypep `(and ,type1 ,type2) nil t)
(check-subtypep `(and ,type2 ,type1) nil t)
(check-subtypep `(and ,type1 (not ,type2)) type1 t)
(check-subtypep `(and (not ,type2) ,type1) type1 t)
(check-subtypep `(and ,type2 (not ,type1)) type2 t)
(check-subtypep `(and (not ,type1) ,type2) type2 t)
;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t)
;;; (check-subtypep type1 `(or (not ,type2) ,type1) t)
;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t)
;;; (check-subtypep type2 `(or (not ,type1) ,type2) t)
(check-subtypep t `(or (not ,type1) (not ,type2)) t)
(check-subtypep t `(or (not ,type2) (not ,type1)) t)
))
(defun check-equivalence (type1 type2)
(append
(check-subtypep type1 type2 t)
(check-subtypep type2 type1 t)
(check-subtypep `(not ,type1) `(not ,type2) t)
(check-subtypep `(not ,type2) `(not ,type1) t)
(check-subtypep `(and ,type1 (not ,type2)) nil t)
(check-subtypep `(and ,type2 (not ,type1)) nil t)
(check-subtypep `(and (not ,type2) ,type1) nil t)
(check-subtypep `(and (not ,type1) ,type2) nil t)
(check-subtypep t `(or ,type1 (not ,type2)) t)
(check-subtypep t `(or ,type2 (not ,type1)) t)
(check-subtypep t `(or (not ,type2) ,type1) t)
(check-subtypep t `(or (not ,type1) ,type2) t)))
(defun check-all-subtypep (type1 type2)
(append
(check-subtypep type1 type2 t)
(check-subtypep `(not ,type2) `(not ,type1) t)
(check-subtypep `(and ,type1 (not ,type2)) nil t)
(check-subtypep t `(or (not ,type1) ,type2) t)))
(defun check-all-not-subtypep (type1 type2)
(append
(check-subtypep type1 type2 nil)
(check-subtypep `(not ,type2) `(not ,type1) nil)))
(defun subtypep-and-contrapositive-are-consistent (t1 t2)
(multiple-value-bind (sub1 success1)
(subtypep* t1 t2)
(multiple-value-bind (sub2 success2)
(subtypep* `(not ,t2) `(not ,t1))
(or (not success1)
(not success2)
(eqlt sub1 sub2)))))
......@@ -4,6 +4,9 @@
;;;; Contains: Tests of UNUSE-PACKAGE
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
(declaim (optimize (safety 3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -4,6 +4,9 @@
;;;; Contains: Tests of USE-PACKAGE
(in-package :cl-test)
(compile-and-load "package-aux.lsp")
(declaim (optimize (safety 3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -6,6 +6,8 @@
(in-package :cl-test)
(declaim (optimize (safety 3)))
(compile-and-load "package-aux.lsp")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; with-package-iterator
......
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