Skip to content
Newer
Older
100644 130 lines (83 sloc) 3.04 KB
fb1bc7d first commit Git not Darcs
Nick Allen authored
1 ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; -*-
2 ;; Sun Oct 21 17:22:01 2007 by Nick Allen <nallen05@gmail.com>
3 ;; pretty-function-test.lisp
4
5
6 ;; note: these tests require ptester, see http://www.cliki.net/ptester
7
8 ;; note: I had trouble forcing GC during this file on some lisps, so to check
9 ;; if the pretty functions are really being garbage collected you have
10 ;; to do it yourself
11
12 ;; 1. run the tests in this file
13 ;; 2. force a full garbage collection
14 ;; 3. run: (print-pretty-function-table)
15
16 ;; if you don't see anything like #<TEST-1234567> or
17 ;; #<test-pretty-function-printer> then the functions from these
18 ;; tests were garbage collected
19
20
21 (defpackage :pretty-function.test
22 (:use :cl :pretty-function))
23
24 (in-package :pretty-function.test)
25
26 (setf ptester:*break-on-test-failures* t)
27
28
29
30 ;suport
31
32 (defparameter *supported* nil)
33
34 (ptester:test #+(or allegro clisp cmu lispworks mcl sbcl) t
35 #-(or allegro clisp cmu lispworks mcl sbcl) nil
36 (setf *supported*
37 (not (not (find "pretty-function" *modules* :test #'string-equal)))))
38
39 (ptester:test *supported* *pretty-function-printing-supported-p*)
40
41
42
43 ;enabling
44
45 ;should this work on a temporary table?
46
47 (if *supported*
48 (ptester:test-no-warning (enable-pretty-function-printing))
49 (ptester:test-warning (enable-pretty-function-printing)))
50
51
52
53 ;fn-printer
54
55 (defparameter *printer-string* "#<test-pretty-function-printer>")
56
57 (defparameter *printer*
58 (lambda (s) (write-string *printer-string* s)))
59
60 (let ((fn (lambda () (print 5))))
61
62 (ptester:test nil (get-function-printer fn))
63
64 (ptester:test-no-error (setf (get-function-printer fn) *printer*))
65
66 (ptester:test *printer* (get-function-printer fn))
67
68 (ptester:test t
69 (progn
70 #+(or allegro clisp lispworks mcl)
71 (block finding
72 (maphash (lambda (fn printer)
73 (declare (ignore fn))
74 (if (eq *printer* printer)
75 (return-from finding t)))
76 pretty-function::*weak-fn-ht*)
77 nil)
78
79 #+(or cmu sbcl)
80 (not (not (find *printer*
81 pretty-function::*weak-fn-alist*
82 :key #'rest))))))
83
84
85
86 ;make sure function printer prints correctly
87
88 (if *supported*
89 (ptester:test *printer-string*
90 (with-output-to-string (out)
91 (write (with-function-printer *printer*
92 (lambda () (print 5)))
93 :stream out
94 :pretty t))
95 :test #'string=))
96
97
98
99 ;WITH-FUNCTION-PRINTER
100
101 (ptester:test (if *supported*
102 *printer*)
103 (get-function-printer (with-function-printer *printer*
104 (lambda () (print 5)))))
105
106
107
108 ;named-lambda*
109
110 (ptester:test *supported*
111 (not (not (search "TEST-1234567"
112 (with-output-to-string (out)
113 (write (named-lambda* (concatenate 'string
114 "TEST-"
115 "123"
116 "4567")
117 () (print 5))
118 :stream out
119 :pretty t))))))
120
121
122
123 ;named-lambda
124
125 (ptester:test *supported*
126 (not (not (search "TEST-1234567"
127 (with-output-to-string (out)
128 (write (named-lambda "TEST-1234567" () (print 5))
129 :stream out
130 :pretty t))))))
Something went wrong with that request. Please try again.