/usr/share/common-lisp/source/trivial-garbage/tests.lisp is in cl-trivial-garbage 20130312-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; tests.lisp --- trivial-garbage tests.
;;;
;;; This software is placed in the public domain by Luis Oliveira
;;; <loliveira@common-lisp.net> and is provided with absolutely no
;;; warranty.
(defpackage #:trivial-garbage-tests
(:use #:cl #:trivial-garbage #:regression-test)
(:nicknames #:tg-tests))
(in-package #:trivial-garbage-tests)
;;;; Weak Pointers
(deftest pointers.1
(weak-pointer-p (make-weak-pointer 42))
t)
(deftest pointers.2
(weak-pointer-value (make-weak-pointer 42))
42)
;;;; Weak Hashtables
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun sbcl-without-weak-hash-tables-p ()
(if (and (find :sbcl *features*)
(not (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")))
'(:and)
'(:or))))
#+(or corman scl #.(tg-tests::sbcl-without-weak-hash-tables-p))
(progn
(pushnew 'hashtables.weak-key.1 rt::*expected-failures*)
(pushnew 'hashtables.weak-key.2 rt::*expected-failures*)
(pushnew 'hashtables.weak-value.1 rt::*expected-failures*))
(deftest hashtables.weak-key.1
(let ((ht (make-weak-hash-table :weakness :key)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :key)
(deftest hashtables.weak-key.2
(let ((ht (make-weak-hash-table :weakness :key :test 'eq)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :key)
(deftest hashtables.weak-value.1
(let ((ht (make-weak-hash-table :weakness :value)))
(values (hash-table-p ht)
(hash-table-weakness ht)))
t :value)
(deftest hashtables.not-weak.1
(hash-table-weakness (make-hash-table))
nil)
;;;; Finalizers
;;;
;;; These tests are, of course, not very reliable.
(defun dummy (x)
(declare (ignore x))
nil)
(defun test-finalizers-aux (count extra-action)
(let ((cons (list 0))
(obj (string (gensym))))
(dotimes (i count)
(finalize obj (lambda () (incf (car cons)))))
(when extra-action
(cancel-finalization obj)
(when (eq extra-action :add-again)
(dotimes (i count)
(finalize obj (lambda () (incf (car cons)))))))
(setq obj (gensym))
(setq obj (dummy obj))
cons))
(defvar *result*)
;;; I don't really understand this, but it seems to work, and stems
;;; from the observation that typing the code in sequence at the REPL
;;; achieves the desired result. Superstition at its best.
(defmacro voodoo (string)
`(funcall
(compile nil `(lambda ()
(eval (let ((*package* (find-package :tg-tests)))
(read-from-string ,,string)))))))
(defun test-finalizers (count &optional remove)
(gc :full t)
(voodoo (format nil "(setq *result* (test-finalizers-aux ~S ~S))"
count remove))
(voodoo "(gc :full t)")
;; Normally done by a background thread every 0.3 sec:
#+openmcl (ccl::drain-termination-queue)
;; (an alternative is to sleep a bit)
(voodoo "(car *result*)"))
(deftest finalizers.1
(test-finalizers 1)
1)
(deftest finalizers.2
(test-finalizers 1 t)
0)
(deftest finalizers.3
(test-finalizers 5)
5)
(deftest finalizers.4
(test-finalizers 5 t)
0)
(deftest finalizers.5
(test-finalizers 5 :add-again)
5)
|