ttests.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
 (HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) Tags
 (DIR) LICENSE
       ---
       ttests.lisp (3562B)
       ---
            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 (pushnew 'hashtables.weak-value.1 rt::*expected-failures*)
           49 
           50 (deftest hashtables.weak-key.1
           51     (let ((ht (make-weak-hash-table :weakness :key)))
           52       (values (hash-table-p ht)
           53               (hash-table-weakness ht)))
           54   t :key)
           55 
           56 (deftest hashtables.weak-key.2
           57     (let ((ht (make-weak-hash-table :weakness :key :test 'eq)))
           58       (values (hash-table-p ht)
           59               (hash-table-weakness ht)))
           60   t :key)
           61 
           62 (deftest hashtables.weak-value.1
           63     (let ((ht (make-weak-hash-table :weakness :value)))
           64       (values (hash-table-p ht)
           65               (hash-table-weakness ht)))
           66   t :value)
           67 
           68 (deftest hashtables.not-weak.1
           69     (hash-table-weakness (make-hash-table))
           70   nil)
           71 
           72 ;;;; Finalizers
           73 ;;;
           74 ;;; These tests are, of course, not very reliable.
           75 
           76 (defun dummy (x)
           77   (declare (ignore x))
           78   nil)
           79 
           80 (defun test-finalizers-aux (count extra-action)
           81   (let ((cons (list 0))
           82         (obj (string (gensym))))
           83     (dotimes (i count)
           84       (finalize obj (lambda () (incf (car cons)))))
           85     (when extra-action
           86       (cancel-finalization obj)
           87       (when (eq extra-action :add-again)
           88         (dotimes (i count)
           89           (finalize obj (lambda () (incf (car cons)))))))
           90     (setq obj (gensym))
           91     (setq obj (dummy obj))
           92     cons))
           93 
           94 (defvar *result*)
           95 
           96 ;;; I don't really understand this, but it seems to work, and stems
           97 ;;; from the observation that typing the code in sequence at the REPL
           98 ;;; achieves the desired result. Superstition at its best.
           99 (defmacro voodoo (string)
          100   `(funcall
          101     (compile nil `(lambda ()
          102                     (eval (let ((*package* (find-package :tg-tests)))
          103                             (read-from-string ,,string)))))))
          104 
          105 (defun test-finalizers (count &optional remove)
          106   (gc :full t)
          107   (voodoo (format nil "(setq *result* (test-finalizers-aux ~S ~S))"
          108                   count remove))
          109   (voodoo "(gc :full t)")
          110   ;; Normally done by a background thread every 0.3 sec:
          111   #+openmcl (ccl::drain-termination-queue)
          112   ;; (an alternative is to sleep a bit)
          113   (voodoo "(car *result*)"))
          114 
          115 (deftest finalizers.1
          116     (test-finalizers 1)
          117   1)
          118 
          119 (deftest finalizers.2
          120     (test-finalizers 1 t)
          121   0)
          122 
          123 (deftest finalizers.3
          124     (test-finalizers 5)
          125   5)
          126 
          127 (deftest finalizers.4
          128     (test-finalizers 5 t)
          129   0)
          130 
          131 (deftest finalizers.5
          132     (test-finalizers 5 :add-again)
          133   5)