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 (assert (eq (sb!int:info :variable :kind 'sb!vm:vector-data-offset)
  21             :constant))
  22 ;;; It's possible in general for a constant to have the value NIL, but
  23 ;;; not for vector-data-offset, which must be a number:
  24 (assert (boundp 'sb!vm:vector-data-offset))
  25 (assert (integerp (symbol-value 'sb!vm:vector-data-offset)))
  26
  27 (in-package "SB!C")
  28
  29 (let ((foo-iv (packed-info-insert +nil-packed-infos+ +no-auxilliary-key+
  30                                   5 "hi 5"))
  31       (bar-iv (packed-info-insert +nil-packed-infos+ +no-auxilliary-key+
  32                                   6 "hi 6"))
  33       (baz-iv (packed-info-insert +nil-packed-infos+ 'mumble
  34                                   9 :phlebs)))
  35
  36   ;; removing nonexistent types returns NIL
  37   (assert (equal nil (packed-info-remove foo-iv +no-auxilliary-key+
  38                                          '(4 6 7))))
  39   (assert (equal nil (packed-info-remove baz-iv 'mumble '(4 6 7))))
  40
  41   ;; removing the one info shrinks the vector to nothing
  42   ;; and all values of nothing are EQ
  43   (assert (equalp #(0) (packed-info-remove foo-iv +no-auxilliary-key+ '(5))))
  44   (assert (eq (packed-info-remove foo-iv +no-auxilliary-key+ '(5))
  45               (packed-info-remove bar-iv +no-auxilliary-key+ '(6))))
  46   (assert (eq (packed-info-remove foo-iv +no-auxilliary-key+ '(5))
  47               (packed-info-remove baz-iv 'mumble '(9)))))
  48
  49 ;; Test that the packing invariants are maintained:
  50 ;; 1. if an FDEFINITION is present in an info group, it is the *first* info
  51 ;; 2. if SETF is an auxilliary key, it is the *first* aux key
  52 (let ((vect +nil-packed-infos+)
  53       (s 'foo))
  54   (flet ((iv-put (aux-key number val)
  55            (setq vect (packed-info-insert vect aux-key number val)))
  56          (iv-del (aux-key number)
  57            (awhen (packed-info-remove vect aux-key (list number))
  58              (setq vect it)))
  59          (verify (ans)
  60            (let (result) ; => ((name . ((type . val) (type . val))) ...)
  61              (%call-with-each-info
  62               (lambda (name info-number value)
  63                 (let ((pair (cons info-number value)))
  64                   (if (equal name (caar result))
  65                       (push pair (cdar result))
  66                       (push (list name pair) result))))
  67               vect s)
  68              (unless (equal (mapc (lambda (cell)
  69                                     (rplacd cell (nreverse (cdr cell))))
  70                                   (nreverse result))
  71                             ans)
  72                (error "Failed test ~S" ans)))))
  73     (iv-put 0 12 "info#12")
  74     (verify `((,s (12 . "info#12"))))
  75
  76     (iv-put 'cas 3 "CAS-info#3")
  77     (verify `((,s (12 . "info#12"))
  78               ((CAS ,s) (3 . "CAS-info#3"))))
  79
  80     ;; SETF moves in front of (CAS)
  81     (iv-put 'setf 6 "SETF-info#6")
  82     (verify `((,s (12 . "info#12"))
  83               ((SETF ,s) (6 . "SETF-info#6"))
  84               ((CAS ,s) (3 . "CAS-info#3"))))
  85
  86     (iv-put 'frob 15 "FROB-info#15")
  87     (verify `((,s (12 . "info#12"))
  88               ((SETF ,s) (6 . "SETF-info#6"))
  89               ((CAS ,s) (3 . "CAS-info#3"))
  90               ((FROB ,s) (15 . "FROB-info#15"))))
  91
  92     (iv-put 'cas +fdefn-info-num+ "CAS-fdefn") ; pretend
  93     ;; fdefinition for (CAS) moves in front of its info type #3
  94     (verify `((,s (12 . "info#12"))
  95               ((SETF ,s) (6 . "SETF-info#6"))
  96               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
  97               ((FROB ,s) (15 . "FROB-info#15"))))
  98
  99     (iv-put 'frob +fdefn-info-num+ "FROB-fdefn")
 100     (verify `((,s (12 . "info#12"))
 101               ((SETF ,s) (6 . "SETF-info#6"))
 102               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
 103               ((FROB ,s)
 104                (,+fdefn-info-num+ . "FROB-fdefn") (15 . "FROB-info#15"))))
 105
 106     (iv-put 'setf +fdefn-info-num+ "SETF-fdefn")
 107     (verify `((,s (12 . "info#12"))
 108               ((SETF ,s) (,+fdefn-info-num+ . "SETF-fdefn") (6 . "SETF-info#6"))
 109               ((CAS ,s) (,+fdefn-info-num+ . "CAS-fdefn") (3 . "CAS-info#3"))
 110               ((FROB ,s)
 111                (,+fdefn-info-num+ . "FROB-fdefn") (15 . "FROB-info#15"))))
 112
 113     (iv-del 'cas +fdefn-info-num+)
 114     (iv-del 'setf +fdefn-info-num+)
 115     (iv-del 'frob +fdefn-info-num+)
 116     (verify `((,s (12 . "info#12"))
 117               ((SETF ,s) (6 . "SETF-info#6"))
 118               ((CAS ,s) (3 . "CAS-info#3"))
 119               ((FROB ,s) (15 . "FROB-info#15"))))
 120
 121     (iv-del 'setf 6)
 122     (iv-del 0 12)
 123     (verify `(((CAS ,s) (3 . "CAS-info#3"))
 124               ((FROB ,s) (15 . "FROB-info#15"))))
 125
 126     (iv-put 'setf +fdefn-info-num+ "fdefn")
 127     (verify `(((SETF ,s) (,+fdefn-info-num+ . "fdefn"))
 128               ((CAS ,s) (3 . "CAS-info#3"))
 129               ((FROB ,s) (15 . "FROB-info#15"))))))
 130
 131 (let ((ht (make-info-hashtable)))
 132   (setf (info-gethash '(hairy name) ht) :whatever)
 133   (assert (eq (info-gethash (list 'hairy 'name) ht) :whatever)))
 134
 135 (/show "done with tests/info.before-xc.lisp")