source: trunk/source/tests/ansi-tests/describe.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 2.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Dec 12 13:22:13 2004
4;;;; Contains: Tests of DESCRIBE
5
6(in-package :cl-test)
7
8(defun harness-for-describe (fn)
9  (let (s1 s2)
10    (with-open-stream
11     (*standard-output* (make-string-output-stream))
12     (with-open-stream
13      (tio-input (make-string-input-stream "X"))
14      (with-open-stream
15       (tio-output (make-string-output-stream))
16       (with-open-stream
17        (*terminal-io* (make-two-way-stream tio-input tio-output))
18        (let ((*print-circle* t)
19              (*print-readably* nil))
20          (assert (null (multiple-value-list (funcall fn))))))
21       (setq s2 (get-output-stream-string tio-output)))
22      (assert (equal (read-char tio-input) #\X)))
23     (setq s1 (get-output-stream-string *standard-output*)))
24    (values s1 s2)))
25
26(deftest describe.1
27  (loop for x in *universe*
28        for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x))))
29        when (and (equal s1 "") (equal s2 ""))
30        collect x)
31  nil)
32
33(deftest describe.2
34  (loop for x in *universe*
35        for s1 = nil
36        for s2 = nil
37        for s3 = (with-output-to-string (s)
38                     (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s)))))
39        when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1)))
40        collect (list x s1 s2 s3))
41  nil)
42
43(deftest describe.3
44  (loop for x in *universe*
45        for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t))))
46        when (or (equal "" s2) (not (equal "" s1)))
47        collect (list x s1 s2))
48  nil)
49
50(deftest describe.4
51  (loop for x in *universe*
52        for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil))))
53        when (or (equal "" s1) (not (equal "" s2)))
54        collect (list x s1 s2))
55  nil)
56
57;;; Defining methods for describe-object
58
59(defclass describe-object-test-class-01 () ((s1 :initarg :s1) (s2 :initarg :s2) (s3 :initarg :s3)))
60
61(defmethod describe-object ((obj describe-object-test-class-01) stream)
62  (format stream "ABCDE ~A ~A ~A XYZ" (slot-value obj 's1) (slot-value obj 's2) (slot-value obj 's3)))
63
64(deftest describe.5
65  (let ((obj (make-instance 'describe-object-test-class-01 :s1 2 :s2 6 :s3 17)))
66    (multiple-value-bind (str1 str2) (harness-for-describe #'(lambda () (describe obj)))
67      (if (or (search "ABCDE 2 6 17 XYZ" str1)
68              (search "ABCDE 2 6 17 XYZ" str2))
69          :good
70        (list str1 str2))))
71  :good)
72
73;;; Error cases
74
75(deftest describe.error.1
76  (signals-error (describe) program-error)
77  t)
78
79(deftest describe.error.2
80  (signals-error (with-output-to-string (s) (describe nil s nil)) program-error)
81  t)
82
Note: See TracBrowser for help on using the repository browser.