tests/time.pure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package "CL-USER")
  13
  14 ;;; Test for monotonicity of GET-INTERNAL-RUN-TIME.
  15 #+nil ; FIXME: This test can't work as long as
  16       ;    (FUNCALL (COMPILE NIL (LAMBDA (X) (+ X 12))) 44)
  17       ; fails with
  18       ;    #<FUNCTION {5009BF31}> was defined in a non-null environment.
  19 (funcall (compile nil
  20                   (lambda (n-seconds)
  21                     (declare (type fixnum n-seconds))
  22                     (let* ((n-internal-time-units
  23                             (* n-seconds
  24                                internal-time-units-per-second))
  25                            (time0 (get-internal-run-time))
  26                            (time1 (+ time0 n-internal-time-units)))
  27                       (loop
  28                        (let ((time (get-internal-run-time)))
  29                          (assert (>= time time0))
  30                          (when (>= time time1)
  31                            (return)))))))
  32          3)
  33
  34 (locally
  35   (declare (notinline mapcar))
  36   (mapcar (lambda (args)
  37             (destructuring-bind (obj type-spec result) args
  38               (flet ((matches-result? (x)
  39                        (eq (if x t nil) result)))
  40                 (assert (matches-result? (typep obj type-spec)))
  41                 (assert (matches-result? (sb-kernel:ctypep
  42                                           obj
  43                                           (sb-kernel:specifier-type
  44                                            type-spec)))))))
  45           '((nil (or null vector)              t)
  46             (nil (or number vector)            nil)
  47             (12  (or null vector)              nil)
  48             (12  (and (or number vector) real) t))))
  49
  50