Mercurial > hg > xemacs-beta

view tests/automated/weak-tests.el @ 4678:b5e1d4f6b66f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. lisp/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (ceiling*, floor*, round*, truncate*): Implement these in terms of the C functions; mark them as obsolete. (mod*, rem*): Use #'nth-value with the C functions, not #'nth with the CL emulation functions. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * lispref/numbers.texi (Bigfloat Basics): Correct this documentation (ignoring for the moment that it breaks off in mid-sentence). tests/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test the new Common Lisp-compatible rounding functions available in C. (generate-rounding-output): Provide a function useful for generating the data for the rounding functions tests. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): New macros, used in the implementation of the rounding functions. (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) (floor_two_fixnum, floor_two_bignum, floor_two_ratio) (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) (floor_two_float, floor_one_mundane_arg, round_two_fixnum) (round_two_bignum_1, round_two_bignum, round_two_ratio) (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) (round_one_bigfloat, round_two_float, round_one_float) (round_one_mundane_arg, truncate_two_fixnum) (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) (truncate_one_float, truncate_one_mundane_arg): New functions, used in the implementation of the rounding functions. (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) (Ffround, Fftruncate): Revise to fully support Common Lisp conventions. This means: -- All functions have optional DIVISOR arguments -- All functions return multiple values; see #'values -- All functions do their arithmetic with the correct number types according to the contamination rules. -- #'round and #'fround always round towards the even number in ambiguous cases. * doprnt.c (emacs_doprnt_1): * number.c (internal_coerce_number): Call Ftruncate with two arguments, not one. * floatfns.c (Ffloat): Correct this, if NUMBER is a bignum. * lisp.h: Declare Ftruncate as taking two arguments. * number.c: Provide scratch_ratio2, init it appropriately. * number.h: Make scratch_ratio2 available. * number.h (BIGFLOAT_ARITH_RETURN): * number.h (BIGFLOAT_ARITH_RETURN1): Correct these functions.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 11 Aug 2009 17:59:23 +0100
parents 7b628daa39d4
children 189fb67ca31a
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)