tests/info.before-xc.lisp

   1 ;;;; tests of the INFO compiler database, initially with particular
   2 ;;;; reference to knowledge of constants, intended to be executed as
   3 ;;;; soon as the cross-compiler is built.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (in-package "SB-KERNEL")
  17
  18 (/show "beginning tests/info.before-xc.lisp")
  19
  20 ;;; It's possible in general for a constant to have the value NIL, but
  21 ;;; not for vector-data-offset, which must be a number:
  22 (assert (cl:constantp 'sb-vm:vector-data-offset))
  23 (assert (integerp (symbol-value 'sb-vm:vector-data-offset)))
  24
  25 (in-package "SB-IMPL")
  26
  27 (let ((foo-iv (packed-info-insert +nil-packed-infos+ +no-auxiliary-key+
  28                                   5 "hi 5"))
  29       (bar-iv (packed-info-insert +nil-packed-infos+ +no-auxiliary-key+
  30                                   6 "hi 6"))
  31       (baz-iv (packed-info-insert +nil-packed-infos+ 'mumble
  32                                   9 :phlebs)))
  33
  34   ;; removing nonexistent types returns NIL
  35   (assert (equal nil (packed-info-remove foo-iv +no-auxiliary-key+
  36                                          '(4 6 7))))
  37   (assert (equal nil (packed-info-remove baz-iv 'mumble '(4 6 7))))
  38
  39   ;; removing the one info shrinks the vector to nothing
  40   ;; and all values of nothing are EQ
  41   (assert (equalp (packed-info-remove foo-iv +no-auxiliary-key+ '(5))
  42                   +nil-packed-infos+))
  43   (assert (eq (packed-info-remove foo-iv +no-auxiliary-key+ '(5))
  44               (packed-info-remove bar-iv +no-auxiliary-key+ '(6))))
  45   (assert (eq (packed-info-remove foo-iv +no-auxiliary-key+ '(5))
  46               (packed-info-remove baz-iv 'mumble '(9)))))
  47
  48 ;; Test that the packing invariants are maintained:
  49 ;; 1. if an FDEFINITION is present in an info group, it is the *first* info
  50 ;; 2. if SETF is an auxiliary key, it is the *first* aux key
  51 (let ((vect +nil-packed-infos+)
  52       (s 'foo))
  53   (flet ((iv-put (aux-key number val)
  54            (setq vect (packed-info-insert vect aux-key number val)))
  55          (iv-del (aux-key number)
  56            (awhen (packed-info-remove vect aux-key (list number))
  57              (setq vect it)))
  58          (verify (ans)
  59            (let (result) ; => ((name . ((type . val) (type . val))) ...)
  60              (%call-with-each-info
  61               (lambda (name info-number value)
  62                 (let ((pair (cons info-number value)))
  63                   (if (equal name (caar result))
  64                       (push pair (cdar result))
  65                       (push (list name pair) result))))
  66               vect s)
  67              (unless (equal (mapc (lambda (cell)
  68                                     (rplacd cell (nreverse (cdr cell))))
  69                                   (nreverse result))
  70                             ans)
  71                (error "Failed test ~S" ans)))))
  72     (iv-put 0 12 "info#12")
  73     (verify `((,s (12 . "info#12"))))
  74
  75     (iv-put 'cas 3 "CAS-info#3")
  76     (verify `((,s (12 . "info#12"))
  77               ((CAS ,s) (3 . "CAS-info#3"))))
  78
  79     ;; SETF moves in front of (CAS)
  80     (iv-put 'setf 6 "SETF-info#6")
  81     (verify `((,s (12 . "info#12"))
  82               ((SETF ,s) (6 . "SETF-info#6"))
  83               ((CAS ,s) (3 . "CAS-info#3"))))
  84
  85     (iv-put 'frob 15 "FROB-info#15")
  86     (verify `((,s (12 . "info#12"))
  87               ((SETF ,s) (6 . "SETF-info#6"))
  88               ((CAS ,s) (3 . "CAS-info#3"))
  89               ((FROB ,s) (15 . "FROB-info#15"))))
  90
  91     (iv-put 'cas +fdefn-info-num+ "CAS-fdefn") ; pretend
  92     ;; fdefinition for (CAS) moves in front of its info type #3
  93     (verify `((,s (12 . "info#12"))
  94               ((SETF ,s) (6 . "SETF-info#6"))
  95               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
  96               ((FROB ,s) (15 . "FROB-info#15"))))
  97
  98     (iv-put 'frob +fdefn-info-num+ "FROB-fdefn")
  99     (verify `((,s (12 . "info#12"))
 100               ((SETF ,s) (6 . "SETF-info#6"))
 101               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
 102               ((FROB ,s)
 103                (,+fdefn-info-num+ . "FROB-fdefn") (15 . "FROB-info#15"))))
 104
 105     (iv-put 'setf +fdefn-info-num+ "SETF-fdefn")
 106     (verify `((,s (12 . "info#12"))
 107               ((SETF ,s) (,+fdefn-info-num+ . "SETF-fdefn") (6 . "SETF-info#6"))
 108               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
 109               ((FROB ,s)
 110                (,+fdefn-info-num+ . "FROB-fdefn") (15 . "FROB-info#15"))))
 111
 112     (iv-del 'cas +fdefn-info-num+)
 113     (iv-del 'setf +fdefn-info-num+)
 114     (iv-del 'frob +fdefn-info-num+)
 115     (verify `((,s (12 . "info#12"))
 116               ((SETF ,s) (6 . "SETF-info#6"))
 117               ((CAS ,s) (3 . "CAS-info#3"))
 118               ((FROB ,s) (15 . "FROB-info#15"))))
 119
 120     (iv-del 'setf 6)
 121     (iv-del 0 12)
 122     (verify `(((CAS ,s) (3 . "CAS-info#3"))
 123               ((FROB ,s) (15 . "FROB-info#15"))))
 124
 125     (iv-put 'setf +fdefn-info-num+ "fdefn")
 126     (verify `(((SETF ,s) (,+fdefn-info-num+ . "fdefn"))
 127               ((CAS ,s) (3 . "CAS-info#3"))
 128               ((FROB ,s) (15 . "FROB-info#15"))))))
 129
 130 (/show "done with tests/info.before-xc.lisp")