source: trunk/tests/ansi-tests/package-aux.lsp @ 9045

Last change on this file since 9045 was 9045, checked in by gz, 12 years ago

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

File size: 4.4 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Jun 21 20:59:17 2004
4;;;; Contains: Aux. functions for package tests
5
6(in-package :cl-test)
7
8(defmacro test-with-package-iterator (package-list-expr &rest symbol-types)
9  "Build an expression that tests the with-package-iterator form."
10  (let ((name (gensym))
11        (cht-var (gensym))
12        (pkg-list-var (gensym)))
13    `(let ((,cht-var (make-hash-table))
14           (,pkg-list-var ,package-list-expr)
15           (fail-count 0))
16         (with-package-iterator (,name ,pkg-list-var
17                                       ,@(copy-list symbol-types))
18           ;; For each symbol, check that name is returning appropriate
19           ;; things
20           (loop
21             (block fail
22               (multiple-value-bind (more sym access pkg)
23                   (,name)
24                 (unless more (return nil))
25                 (setf (gethash sym ,cht-var) t)  ;; note presence of symbol
26                 ;; Check that its access status is in the list,
27                 ;;  that pkg is a package,
28                 ;;  that the symbol is in the package,
29                 ;;  and that (in the package) it has the correct access type
30                 (unless (member access (quote ,(copy-list symbol-types)))
31                   (unless (> fail-count +fail-count-limit+)
32                     (format t "Bad access type: ~S ==> ~A~%" sym access))
33                   (when (= fail-count +fail-count-limit+)
34                     (format t "Further messages suppressed~%"))
35                   (incf fail-count)
36                   (return-from fail nil))
37                 
38                 (unless (packagep pkg)
39                   (unless (> fail-count +fail-count-limit+)
40                     (format t "Not a package: ~S ==> ~S~%" sym pkg))
41                   (when (= fail-count +fail-count-limit+)
42                     (format t "Further messages suppressed~%"))
43                   (incf fail-count)
44                   (return-from fail nil))
45                 (multiple-value-bind (sym2 access2)
46                     (find-symbol (symbol-name sym) pkg)
47                   (unless (or (eqt sym sym2)
48                               (member sym2 (package-shadowing-symbols pkg)))
49                     (unless (> fail-count +fail-count-limit+)
50                       (format t "Not same symbol: ~S ~S~%" sym sym2))
51                     (when (= fail-count +fail-count-limit+)
52                       (format t "Further messages suppressed~%"))
53                     (incf fail-count)
54                     (return-from fail nil))
55                   (unless  (eqt access access2)
56                     (when *test-verbose*
57                       (unless (> fail-count +fail-count-limit+)
58                         (format t "Not same access type: ~S ~S ~S~%"
59                                 sym access access2))
60                       (when (= fail-count +fail-count-limit+)
61                         (format t "Further messages suppressed~%")))
62                     (incf fail-count)
63                     (return-from fail nil)))))))
64         ;; now, check that each symbol in each package has
65         ;; been properly found
66         (loop
67             for p in ,pkg-list-var do
68               (block fail
69                 (do-symbols (sym p)
70                   (multiple-value-bind (sym2 access)
71                       (find-symbol (symbol-name sym) p)
72                     (unless (eqt sym sym2)
73                       (unless (> fail-count +fail-count-limit+)
74                         (format t "Not same symbol (2): ~S ~S~%"
75                                 sym sym2))
76                       (when (= fail-count +fail-count-limit+)
77                         (format t "Further messages suppressed~%"))
78                       (incf fail-count)
79                       (return-from fail nil))
80                     (unless (or (not (member access
81                                              (quote ,(copy-list symbol-types))))
82                                 (gethash sym ,cht-var))
83                       (format t "Symbol not found: ~S~%" sym)
84                       (incf fail-count)
85                       (return-from fail nil))))))
86         (or (zerop fail-count) fail-count))))
87
88(defun with-package-iterator-internal (packages)
89  (test-with-package-iterator packages :internal))
90
91(defun with-package-iterator-external (packages)
92  (test-with-package-iterator packages :external))
93
94(defun with-package-iterator-inherited (packages)
95  (test-with-package-iterator packages :inherited))
96
97(defun with-package-iterator-all (packages)
98  (test-with-package-iterator packages :internal :external :inherited))
99
100(defun num-external-symbols-in-package (p)
101  (let ((num 0))
102    (declare (fixnum num))
103    (do-external-symbols (s p num)
104      (declare (ignorable s))                   
105      (incf num))))
106
107(defun external-symbols-in-package (p)
108  (let ((symbols nil))
109    (do-external-symbols (s p)
110      (push s symbols))
111    (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1)
112                                             (symbol-name s2))))))
113
114(defun num-symbols-in-package (p)
115  (let ((num 0))
116    (declare (fixnum num))
117    (do-symbols (s p num)
118      (declare (ignorable s))                   
119      (incf num))))
120
121(defun sort-symbols (sl)
122  (sort (copy-list sl)
123        #'(lambda (x y)
124            (or
125             (string< (symbol-name x)
126                      (symbol-name y))
127             (and (string= (symbol-name x)
128                           (symbol-name y))
129                  (string< (package-name (symbol-package x))
130                           (package-name (symbol-package y))))))))
131
132(defun sort-package-list (x)
133  (sort (copy-list x)
134        #'string<
135        :key #'package-name))
Note: See TracBrowser for help on using the repository browser.