tests.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
tests.lisp (3901B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; tests.lisp --- trivial-garbage tests. | |
4 ;;; | |
5 ;;; This software is placed in the public domain by Luis Oliveira | |
6 ;;; <[email protected]> and is provided with absolutely no | |
7 ;;; warranty. | |
8 | |
9 (defpackage #:trivial-garbage-tests | |
10 (:use #:cl #:trivial-garbage #:regression-test) | |
11 (:nicknames #:tg-tests) | |
12 (:export #:run)) | |
13 | |
14 (in-package #:trivial-garbage-tests) | |
15 | |
16 (defun run () | |
17 (let ((*package* (find-package :trivial-garbage-tests))) | |
18 (do-tests) | |
19 (null (set-difference (regression-test:pending-tests) | |
20 rtest::*expected-failures*)))) | |
21 | |
22 ;;;; Weak Pointers | |
23 | |
24 (deftest pointers.1 | |
25 (weak-pointer-p (make-weak-pointer 42)) | |
26 t) | |
27 | |
28 (deftest pointers.2 | |
29 (weak-pointer-value (make-weak-pointer 42)) | |
30 42) | |
31 | |
32 ;;;; Weak Hashtables | |
33 | |
34 (eval-when (:compile-toplevel :load-toplevel :execute) | |
35 (defun sbcl-without-weak-hash-tables-p () | |
36 (if (and (find :sbcl *features*) | |
37 (not (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT"))) | |
38 '(:and) | |
39 '(:or)))) | |
40 | |
41 #+(or corman scl #.(tg-tests::sbcl-without-weak-hash-tables-p)) | |
42 (progn | |
43 (pushnew 'hashtables.weak-key.1 rt::*expected-failures*) | |
44 (pushnew 'hashtables.weak-key.2 rt::*expected-failures*) | |
45 (pushnew 'hashtables.weak-value.1 rt::*expected-failures*)) | |
46 | |
47 #+clasp | |
48 (progn | |
49 (pushnew 'pointers.1 rt::*expected-failures*) | |
50 (pushnew 'pointers.2 rt::*expected-failures*) | |
51 (pushnew 'hashtables.weak-value.1 rt::*expected-failures*)) | |
52 | |
53 (deftest hashtables.weak-key.1 | |
54 (let ((ht (make-weak-hash-table :weakness :key))) | |
55 (values (hash-table-p ht) | |
56 (hash-table-weakness ht))) | |
57 t :key) | |
58 | |
59 (deftest hashtables.weak-key.2 | |
60 (let ((ht (make-weak-hash-table :weakness :key :test 'eq))) | |
61 (values (hash-table-p ht) | |
62 (hash-table-weakness ht))) | |
63 t :key) | |
64 | |
65 (deftest hashtables.weak-value.1 | |
66 (let ((ht (make-weak-hash-table :weakness :value))) | |
67 (values (hash-table-p ht) | |
68 (hash-table-weakness ht))) | |
69 t :value) | |
70 | |
71 (deftest hashtables.not-weak.1 | |
72 (hash-table-weakness (make-hash-table)) | |
73 nil) | |
74 | |
75 ;;;; Finalizers | |
76 ;;; | |
77 ;;; These tests are, of course, not very reliable. | |
78 | |
79 (defun dummy (x) | |
80 (declare (ignore x)) | |
81 nil) | |
82 | |
83 (defun test-finalizers-aux (count extra-action) | |
84 (let* ((cons (list 0)) | |
85 ;; lbd should not be defined in a lexical scope where obj is | |
86 ;; present to prevent closing over the variable on compilers | |
87 ;; which does not optimize away unused lexenv variables (i.e | |
88 ;; ecl's bytecmp). | |
89 (lbd (lambda () (incf (car cons)))) | |
90 (obj (string (gensym)))) | |
91 (dotimes (i count) | |
92 (finalize obj lbd)) | |
93 (when extra-action | |
94 (cancel-finalization obj) | |
95 (when (eq extra-action :add-again) | |
96 (dotimes (i count) | |
97 (finalize obj lbd)))) | |
98 (setq obj (gensym)) | |
99 (setq obj (dummy obj)) | |
100 cons)) | |
101 | |
102 (defvar *result*) | |
103 | |
104 ;;; I don't really understand this, but it seems to work, and stems | |
105 ;;; from the observation that typing the code in sequence at the REPL | |
106 ;;; achieves the desired result. Superstition at its best. | |
107 (defmacro voodoo (string) | |
108 `(funcall | |
109 (compile nil `(lambda () | |
110 (eval (let ((*package* (find-package :tg-tests))) | |
111 (read-from-string ,,string))))))) | |
112 | |
113 (defun test-finalizers (count &optional remove) | |
114 (gc :full t) | |
115 (voodoo (format nil "(setq *result* (test-finalizers-aux ~S ~S))" | |
116 count remove)) | |
117 (voodoo "(gc :full t)") | |
118 ;; Normally done by a background thread every 0.3 sec: | |
119 #+openmcl (ccl::drain-termination-queue) | |
120 ;; (an alternative is to sleep a bit) | |
121 (voodoo "(car *result*)")) | |
122 | |
123 (deftest finalizers.1 | |
124 (test-finalizers 1) | |
125 1) | |
126 | |
127 (deftest finalizers.2 | |
128 (test-finalizers 1 t) | |
129 0) | |
130 | |
131 (deftest finalizers.3 | |
132 (test-finalizers 5) | |
133 5) | |
134 | |
135 (deftest finalizers.4 | |
136 (test-finalizers 5 t) | |
137 0) | |
138 | |
139 (deftest finalizers.5 | |
140 (test-finalizers 5 :add-again) | |
141 5) |