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.
5 ;;;; This software is part of the SBCL system. See the README file for
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
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.
16 (in-package "SB-KERNEL")
18 (/show
"beginning tests/info.before-xc.lisp")
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
)))
25 (in-package "SB-IMPL")
27 (let ((foo-iv (packed-info-insert +nil-packed-infos
+ +no-auxiliary-key
+
29 (bar-iv (packed-info-insert +nil-packed-infos
+ +no-auxiliary-key
+
31 (baz-iv (packed-info-insert +nil-packed-infos
+ 'mumble
34 ;; removing nonexistent types returns NIL
35 (assert (equal nil
(packed-info-remove foo-iv
+no-auxiliary-key
+
37 (assert (equal nil
(packed-info-remove baz-iv
'mumble
'(4 6 7))))
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))
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)))))
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
+)
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
))
59 (let (result) ; => ((name . ((type . val) (type . val))) ...)
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
))))
67 (unless (equal (mapc (lambda (cell)
68 (rplacd cell
(nreverse (cdr cell
))))
71 (error "Failed test ~S" ans
)))))
72 (iv-put 0 12 "info#12")
73 (verify `((,s
(12 .
"info#12"))))
75 (iv-put 'cas
3 "CAS-info#3")
76 (verify `((,s
(12 .
"info#12"))
77 ((CAS ,s
) (3 .
"CAS-info#3"))))
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"))))
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"))))
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"))))
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"))
103 (,+fdefn-info-num
+ .
"FROB-fdefn") (15 .
"FROB-info#15"))))
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"))
110 (,+fdefn-info-num
+ .
"FROB-fdefn") (15 .
"FROB-info#15"))))
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"))))
122 (verify `(((CAS ,s
) (3 .
"CAS-info#3"))
123 ((FROB ,s
) (15 .
"FROB-info#15"))))
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"))))))
130 (/show
"done with tests/info.before-xc.lisp")