From de2d816c0a71e6027a0a6c8c8472087d1095bed2 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 22 Jun 1992 13:51:30 +0000
Subject: [PATCH] Added CODE-LOCATION-KIND.

---
 code/debug-int.lisp | 29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 59fd9a3ee..244b4f1b8 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.49 1992/06/22 11:17:39 hallgren Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.50 1992/06/22 13:51:30 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -52,8 +52,8 @@
 
 	  code-location-debug-function code-location-debug-block
 	  code-location-top-level-form-offset code-location-form-number
-	  code-location-debug-source code-location code-location-p
-	  code-location-unknown-p code-location=
+	  code-location-debug-source code-location-kind
+	  code-location code-location-p code-location-unknown-p code-location=
 
 	  debug-source-from debug-source-name debug-source-created
 	  debug-source-compiled debug-source-root-number
@@ -2222,6 +2222,29 @@
 		      (interpreted-code-location-ir1-node code-location)))))))
 	  (t form-num))))
 
+;;; CODE-LOCATION-KIND -- Public
+;;; 
+(defun code-location-kind (code-location)
+  "Return the kind of CODE-LOCATION, one of:
+     :interpreted, :unknown-return, :known-return, :internal-error,
+     :non-local-exit, :block-start, :call-site, :single-value-return,
+     :non-local-entry"
+  (when (code-location-unknown-p code-location)
+    (error 'unknown-code-location :code-location code-location))
+  (etypecase code-location
+    (compiled-code-location
+     (let ((kind (compiled-code-location-kind code-location)))
+       (cond ((not (eq kind :unparsed)) kind)
+             ((not (fill-in-code-location code-location))
+              ;; This check should be unnecessary.  We're missing
+              ;; debug info the compiler should have dumped.
+              (error "Unknown code location?  It should be known."))
+             (t
+              (compiled-code-location-kind code-location)))))
+    (interpreted-code-location
+     :interpreted)))
+
+
 ;;; COMPILED-CODE-LOCATION-LIVE-SET -- Internal.
 ;;;
 ;;; This returns the code-location's live-set if it is available.  If there
-- 
GitLab