1 ;;;; generic type testing and checking apparatus
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
13 (defparameter *immediate-types*
14 (list* unbound-marker-widetag character-widetag
15 (when (= sb!vm::n-word-bits 64)
16 (list single-float-widetag))))
18 (defparameter *fun-header-widetags*
19 (list funcallable-instance-header-widetag
20 simple-fun-header-widetag
21 closure-header-widetag))
23 (defun canonicalize-headers (headers)
27 (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
29 (results (if (= start prev)
32 (dolist (header (sort headers #'<))
36 ((= header (+ prev delta))
45 (defmacro test-type (value target not-p
48 &key &allow-other-keys)
49 ;; Determine what interesting combinations we need to test for.
50 (let* ((type-codes (mapcar #'eval type-codes))
51 (fixnump (and (every (lambda (lowtag)
52 (member lowtag type-codes))
53 '#.(mapcar #'symbol-value fixnum-lowtags))
55 (lowtags (remove lowtag-limit type-codes :test #'<))
56 (extended (remove lowtag-limit type-codes :test #'>))
57 (immediates (intersection extended *immediate-types* :test #'eql))
58 (headers (set-difference extended *immediate-types* :test #'eql))
59 (function-p (if (intersection headers *fun-header-widetags*)
60 (if (subsetp headers *fun-header-widetags*)
62 (error "can't test for mix of function subtypes ~
63 and normal header types"))
66 (error "At least one type must be supplied for TEST-TYPE."))
69 (when (remove-if (lambda (x)
70 (member x '#.(mapcar #'symbol-value fixnum-lowtags)))
72 (error "can't mix fixnum testing with other lowtags"))
74 (error "can't mix fixnum testing with function subtype testing"))
76 ((and (= sb!vm:n-word-bits 64) immediates headers)
77 `(%test-fixnum-immediate-and-headers ,value ,target ,not-p
79 ',(canonicalize-headers
83 (if (= sb!vm:n-word-bits 64)
84 `(%test-fixnum-and-immediate ,value ,target ,not-p
87 (error "can't mix fixnum testing with other immediates")))
89 `(%test-fixnum-and-headers ,value ,target ,not-p
90 ',(canonicalize-headers headers)
93 `(%test-fixnum ,value ,target ,not-p
98 (if (= sb!vm:n-word-bits 64)
99 `(%test-immediate-and-headers ,value ,target ,not-p
101 ',(canonicalize-headers headers)
103 (error "can't mix testing of immediates with testing of headers")))
105 (error "can't mix testing of immediates with testing of lowtags"))
107 (error "can't test multiple immediates at the same time"))
109 `(%test-immediate ,value ,target ,not-p ,(car immediates)
113 (error "can't test multiple lowtags at the same time"))
115 (error "can't test non-fixnum lowtags and headers at the same time"))
116 `(%test-lowtag ,value ,target ,not-p ,(car lowtags) ,@other-args))
118 `(%test-headers ,value ,target ,not-p ,function-p
119 ',(canonicalize-headers headers)
122 (error "nothing to test?")))))