Mercurial > hg > xemacs-beta

view tests/automated/weak-tests.el @ 5253:b6a398dbb403

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist() src/ChangeLog addition: 2010-09-01 Aidan Kehoe <kehoea@parhasard.net> * fns.c (list_merge, list_array_merge_into_list) (list_array_merge_into_array): Avoid algorithmic complexity surprises when checking for circularity in these functions. (Freduce): Fix some formatting, in passing. (mapcarX): Drop the SOME_OR_EVERY argument to this function; instead, take CALLER, a symbol reflecting the Lisp-visible function that called mapcarX(). Use CALLER with mapping_interaction_error() when sequences are modified illegally. Don't cons with #'some, #'every, not even a little. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Call mapcarX() with its new arguments. (Fmapcan): Don't unnecessarily complicate the nconc call. (maplist): Take CALLER, a symbol reflecting the Lisp-visible function that called maplist(), rather than having separate arguments to indicate mapl vs. mapcon. Avoid algorithmic complexity surprises when checking for circularity. In #'mapcon, check a given stretch of result for well-formedness once, which was not previously the case, despite what the comments said. (Fmaplist, Fmapl, Fmapcon): Call maplist() with its new arguments.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 01 Sep 2010 12:51:32 +0100
parents 0f66906b6e37
children 308d34e9f07d
line wrap: on
line source

;; Copyright (C) 1998 Free Software Foundation, Inc.

;; Author: Mike Sperber <mike@xemacs.org>
;; Maintainer: Mike Sperber <mike@xemacs.org>
;; Created: 2002
;; Keywords: tests, database

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;;; Test implementation of weak boxes, ephemerons, and weak lists
;;; See test-harness.el

(condition-case err
    (require 'test-harness)
  (file-error
   (when (and (boundp 'load-file-name) (stringp load-file-name))
     (push (file-name-directory load-file-name) load-path)
     (require 'test-harness))))

(garbage-collect)

;; tests for weak-boxes
(let ((w (make-weak-box (cons 2 3))))
  (Assert (equal (cons 2 3) (weak-box-ref w)))
  (garbage-collect)
  (Assert (not (weak-box-ref w))))

(garbage-collect)

;; tests for ephemerons
(let* ((p (cons 3 4))
       (finalized-p nil)
       (eph1 (make-ephemeron (cons 1 2) p
			     #'(lambda (value)
                                 (setq finalized-p t))))
       (eph2 (make-ephemeron p p)))
  (Assert (eq p (ephemeron-ref (make-ephemeron (cons 1 2) p))))
  (Assert (ephemeron-p (make-ephemeron (cons 1 2) p)))

  (garbage-collect)
  (garbage-collect) ; ensure the post-gc hook runs

  (Assert finalized-p)
  (Assert (not (ephemeron-ref eph1)))

  (garbage-collect)
  
  (Assert (eq p (ephemeron-ref eph2))))

(garbage-collect)

;; tests for simple weak-lists
(let* ((a (cons 23 42))
       (b (cons 42 65))
       (testlist (list a b))
       (weaklist1 (make-weak-list 'simple))
       (weaklist2 (make-weak-list 'simple))
       (weaklist3 (make-weak-list 'simple))
       (weaklist4 (make-weak-list 'simple)))
  (set-weak-list-list weaklist1 testlist)
  (set-weak-list-list weaklist2 (list (cons 1 2) a b))
  (set-weak-list-list weaklist3 (list a (cons 1 2) b))
  (set-weak-list-list weaklist4 (list a b (cons 1 2)))
  (Assert (weak-list-p weaklist1))
  (Assert (eq (weak-list-type weaklist1) 'simple))
  (Assert (weak-list-p weaklist2))
  (Assert (eq (weak-list-type weaklist2) 'simple))
  (Assert (weak-list-p weaklist3))
  (Assert (eq (weak-list-type weaklist3) 'simple))
  (Assert (weak-list-p weaklist4))
  (Assert (eq (weak-list-type weaklist4) 'simple))

  (garbage-collect)

  (Assert (eq (weak-list-list weaklist1) testlist))
  (Assert (equal (weak-list-list weaklist2) testlist))
  (Assert (equal (weak-list-list weaklist3) testlist))
  (Assert (equal (weak-list-list weaklist4) testlist)))

(garbage-collect)

;; tests for assoc weak-lists
(let* ((a (cons 23 42))
       (b (cons a a))
       (testlist (list b b))
       (weaklist1 (make-weak-list 'assoc))
       (weaklist2 (make-weak-list 'assoc))
       (weaklist3 (make-weak-list 'assoc))
       (weaklist4 (make-weak-list 'assoc)))
  (set-weak-list-list weaklist1 testlist)
  (set-weak-list-list weaklist2 (list b (cons (cons 1 2) a) b))
  (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b))
  (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b))
  (Assert (weak-list-p weaklist1))
  (Assert (eq (weak-list-type weaklist1) 'assoc))
  (Assert (weak-list-p weaklist2))
  (Assert (eq (weak-list-type weaklist2) 'assoc))
  (Assert (weak-list-p weaklist3))
  (Assert (eq (weak-list-type weaklist3) 'assoc))
  (Assert (weak-list-p weaklist4))
  (Assert (eq (weak-list-type weaklist4) 'assoc))

  (garbage-collect)

  (Assert (eq (weak-list-list weaklist1) testlist))
  (Assert (equal (weak-list-list weaklist2) testlist))
  (Assert (equal (weak-list-list weaklist3) testlist))
  (Assert (equal (weak-list-list weaklist4) testlist)))

(garbage-collect)

;; tests for key-assoc weak-lists
(let* ((a (cons 23 42))
       (b (cons a a))
       (testlist (list b b))
       (weaklist1 (make-weak-list 'key-assoc))
       (weaklist2 (make-weak-list 'key-assoc))
       (weaklist3 (make-weak-list 'key-assoc))
       (weaklist4 (make-weak-list 'key-assoc)))
  (set-weak-list-list weaklist1 testlist)
  (set-weak-list-list weaklist2 (list b (cons (cons 1 2) a) b))
  (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b))
  (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b))
  (Assert (weak-list-p weaklist1))
  (Assert (eq (weak-list-type weaklist1) 'key-assoc))
  (Assert (weak-list-p weaklist2))
  (Assert (eq (weak-list-type weaklist2) 'key-assoc))
  (Assert (weak-list-p weaklist3))
  (Assert (eq (weak-list-type weaklist3) 'key-assoc))
  (Assert (weak-list-p weaklist4))
  (Assert (eq (weak-list-type weaklist4) 'key-assoc))

  (garbage-collect)

  (Assert (eq (weak-list-list weaklist1) testlist))
  (Assert (equal (weak-list-list weaklist2) testlist))
  (Assert (equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b)))
  (Assert (equal (weak-list-list weaklist4) testlist)))

(garbage-collect)

;; tests for value-assoc weak-lists
(let* ((a (cons 23 42))
       (b (cons a a))
       (testlist (list b b))
       (weaklist1 (make-weak-list 'value-assoc))
       (weaklist2 (make-weak-list 'value-assoc))
       (weaklist3 (make-weak-list 'value-assoc))
       (weaklist4 (make-weak-list 'value-assoc)))
  (set-weak-list-list weaklist1 testlist)
  (set-weak-list-list weaklist2 (list b (cons (cons 1 2) a) b))
  (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b))
  (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b))
  (Assert (weak-list-p weaklist1))
  (Assert (eq (weak-list-type weaklist1) 'value-assoc))
  (Assert (weak-list-p weaklist2))
  (Assert (eq (weak-list-type weaklist2) 'value-assoc))
  (Assert (weak-list-p weaklist3))
  (Assert (eq (weak-list-type weaklist3) 'value-assoc))
  (Assert (weak-list-p weaklist4))
  (Assert (eq (weak-list-type weaklist4) 'value-assoc))

  (garbage-collect)

  (Assert (eq (weak-list-list weaklist1) testlist))
  (Assert (equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b)))
  (Assert (equal (weak-list-list weaklist3) testlist))
  (Assert (equal (weak-list-list weaklist4) testlist)))

(garbage-collect)

;; tests for full-assoc weak-lists
(let* ((a (cons 23 42))
       (b (cons a a))
       (testlist (list b b))
       (weaklist1 (make-weak-list 'full-assoc))
       (weaklist2 (make-weak-list 'full-assoc))
       (weaklist3 (make-weak-list 'full-assoc))
       (weaklist4 (make-weak-list 'full-assoc)))
  (set-weak-list-list weaklist1 testlist)
  (set-weak-list-list weaklist2 (list b (cons (cons 1 2) a) b))
  (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b))
  (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b))
  (Assert (weak-list-p weaklist1))
  (Assert (eq (weak-list-type weaklist1) 'full-assoc))
  (Assert (weak-list-p weaklist2))
  (Assert (eq (weak-list-type weaklist2) 'full-assoc))
  (Assert (weak-list-p weaklist3))
  (Assert (eq (weak-list-type weaklist3) 'full-assoc))
  (Assert (weak-list-p weaklist4))
  (Assert (eq (weak-list-type weaklist4) 'full-assoc))

  (garbage-collect)

  (Assert (eq (weak-list-list weaklist1) testlist))
  (Assert (equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b)))
  (Assert (equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b)))
  (Assert (equal (weak-list-list weaklist4) testlist)))

(garbage-collect)

;; test the intended functionality of the fixpoint iteration used for marking
;; weak data structures like the ephermerons. Basically this tests gc_internals
;; to work properly but it also ensures the ephemerons behave according to the
;; specification

(let* ((inner_cons (cons 1 2))
       (weak1 (make-ephemeron inner_cons
			      (make-ephemeron inner_cons
					      (cons 1 2)
					      '(lambda (v) t))
			      #'(lambda (v) t))))
  (Assert (ephemeron-ref (ephemeron-ref weak1)))
  (garbage-collect)
  ;; assure the inner ephis are still there
  (Assert (ephemeron-ref (ephemeron-ref weak1)))
  ;; delete the key reference and force cleaning up the garbage
  (setq inner_cons (cons 3 4))
  (garbage-collect)
  (Assert (not (ephemeron-ref weak1)))
)

(garbage-collect)