3rdparties/software/trivial-garbage-20200325-git/tests.lisp (3901 bytes)
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 ;;; <loliveira@common-lisp.net> 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)