From 0dc42ff488606130ed661870925ea0fa038eabd3 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 6 Jun 1990 14:52:33 +0000
Subject: [PATCH] COERCE-TO-FUNCTION => FAST-SAFE-COERCE-TO-FUNCTION. Added new
 type-checking COERCE-TO-FUNCTION.

---
 compiler/old-rt/type-vops.lisp | 30 +++++++++++++++++++++++++++++-
 1 file changed, 29 insertions(+), 1 deletion(-)

diff --git a/compiler/old-rt/type-vops.lisp b/compiler/old-rt/type-vops.lisp
index 55c37560b..85bb1ed14 100644
--- a/compiler/old-rt/type-vops.lisp
+++ b/compiler/old-rt/type-vops.lisp
@@ -234,7 +234,7 @@ simple-integer-vector-p?
 ;;; Since we test for a function rather than the unbound marker, this works on
 ;;; NIL.
 ;;;
-(define-vop (coerce-to-function)
+(define-vop (fast-safe-coerce-to-function)
   (:args (thing :scs (descriptor-reg)
 		:target res))
   (:results (res :scs (descriptor-reg)))
@@ -257,3 +257,31 @@ simple-integer-vector-p?
 	  (test-simple-type res temp done-lab nil system:%function-type)
 	  (error-call clc::error-symbol-undefined thing-temp))))))
 
+
+(define-vop (coerce-to-function)
+  (:args (thing :scs (descriptor-reg)
+		:target res))
+  (:results (res :scs (descriptor-reg)))
+  (:node-var node)
+  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
+  (:temporary (:scs (descriptor-reg)) thing-temp)
+  (:generator 0
+    (let ((not-fun-lab (gen-label))
+	  (done-lab (gen-label))
+	  (not-sym-lab (gen-label)))
+      (test-simple-type thing temp not-fun-lab t system:%function-type)
+      (unless (location= thing res)
+	(inst lr res thing))
+      (emit-label done-lab)
+
+      (unassemble
+	(assemble-elsewhere node
+	  (emit-label not-fun-lab)
+	  (test-simple-type thing temp not-sym-lab t system:%symbol-type)
+	  (inst lr thing-temp thing)
+	  (loadw res thing (/ clc::symbol-definition 4))
+	  (test-simple-type res temp done-lab nil system:%function-type)
+	  (error-call clc::error-symbol-undefined thing-temp)
+
+	  (emit-label not-sym-lab)
+	  (error-call clc::error-object-not-function-or-symbol thing))))))
-- 
GitLab