From 8f8522b5e5c54f1f77a419bff8f766fa05e5c45c Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 5 Nov 1991 16:29:35 +0000
Subject: [PATCH] Updated to understand function header subtypes.

---
 compiler/rt/macros.lisp | 31 ++++++++++++++++++++++++-------
 1 file changed, 24 insertions(+), 7 deletions(-)

diff --git a/compiler/rt/macros.lisp b/compiler/rt/macros.lisp
index abd5dc3cf..27549dbaa 100644
--- a/compiler/rt/macros.lisp
+++ b/compiler/rt/macros.lisp
@@ -289,7 +289,8 @@
 
 ;;; TEST-TYPE-AUX -- Internal.
 ;;;
-(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs)
+(defun test-type-aux (reg temp target drop-through not-p lowtags immed hdrs
+			  function-p)
   (let* ((fixnump (and (member even-fixnum-type lowtags :test #'eql)
 		       (member odd-fixnum-type lowtags :test #'eql)))
 	 (lowtags (sort (if fixnump
@@ -299,6 +300,9 @@
 				    :test #'eql)
 			    (copy-list lowtags))
 			#'<))
+	 (lowtag (if function-p
+		     vm:function-pointer-type
+		     vm:other-pointer-type))
 	 (hdrs (sort (copy-list hdrs) #'<))
 	 (immed (sort (copy-list immed) #'<)))
     (append
@@ -337,15 +341,19 @@
 		 (emit-label ,fall-through))))
 	   (gen-range-test temp target drop-through not-p lowtags)))
      (when hdrs
-       `((inst c ,temp other-pointer-type)
+       `((inst c ,temp ,lowtag)
 	 (inst bnc :eq ,(if not-p target drop-through))
-	 (load-type ,temp ,reg other-pointer-type)
+	 (load-type ,temp ,reg ,lowtag)
 	 ,@(gen-range-test temp target drop-through not-p
 			   hdrs type-separation min-type))))))
 
 (defconstant immediate-types
   (list base-character-type unbound-marker-type))
 
+(defconstant function-subtypes
+  (list funcallable-instance-header-type closure-header-type
+	function-header-type closure-function-header-type))
+
 ;;; TEST-TYPE -- Interface.
 ;;;
 ;;; This is used in type-vops.lisp.
@@ -361,7 +369,8 @@
 	 (lowtags (remove lowtag-limit type-codes :test #'<))
 	 (extended (remove lowtag-limit type-codes :test #'>))
 	 (immediates (intersection extended immediate-types :test #'eql))
-	 (headers (set-difference extended immediate-types :test #'eql)))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p nil))
     (unless type-codes
       (error "Must supply at least on type for test-type."))
     (when (and headers (member other-pointer-type lowtags))
@@ -372,6 +381,11 @@
 		   (member other-immediate-1-type lowtags)))
       (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
       (setf immediates nil))
+    (when (intersection headers function-subtypes)
+      (unless (subsetp headers function-subtypes)
+	(error "Can't test for mix of function subtypes and normal ~
+		header types."))
+      (setq function-p t))
     (let ((n-reg (gensym))
 	  (n-temp (gensym))
 	  (n-target (gensym))
@@ -383,13 +397,16 @@
 	 (declare (ignorable ,n-temp))
 	 ,@(if (constantp not-p)
 	       (test-type-aux n-reg n-temp n-target drop-through
-			      (eval not-p) lowtags immediates headers)
+			      (eval not-p) lowtags immediates headers
+			      function-p)
 	       `((cond (,not-p
 			,@(test-type-aux n-reg n-temp n-target drop-through t
-					 lowtags immediates headers))
+					 lowtags immediates headers
+					 function-p))
 		       (t
 			,@(test-type-aux n-reg n-temp n-target drop-through nil
-					 lowtags immediates headers)))))
+					 lowtags immediates headers
+					 function-p)))))
 	 (emit-label ,drop-through)))))
 
 
-- 
GitLab