From 300b7156958e481b0b7666192c0b1d863fb6085a Mon Sep 17 00:00:00 2001
From: chiles <chiles>
Date: Fri, 20 Apr 1990 16:24:12 +0000
Subject: [PATCH] Initial revision

---
 code/debug-int.lisp | 1894 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1894 insertions(+)
 create mode 100644 code/debug-int.lisp

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
new file mode 100644
index 000000000..1cd088d14
--- /dev/null
+++ b/code/debug-int.lisp
@@ -0,0 +1,1894 @@
+;;; -*- Mode: completion; Log: debug.log; Package: debug-internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains the implementation of the programmer's interface
+;;; to writing debugging tools.
+;;;
+;;; Written by Bill Chiles.
+;;; Designed by Rob Maclachlan and Bill Chiles.
+;;;
+
+(in-package "DEBUG-INTERNALS" :nicknames '("DI"))
+
+;;; The compiler's debug-source structure is almost exactly what we want, so
+;;; just get these symbols and export them.
+;;;
+(import '(c::debug-source-from c::debug-source-name c::debug-source-created
+	  c::debug-source-compiled c::debug-source-start-positions
+	  c::debug-source c::debug-source-p))
+
+(export '(debug-variable-name debug-variable-package debug-variable-symbol
+	  debug-variable-id debug-variable-value debug-variable-validity
+	  debug-variable-valid-value debug-variable debug-variable-p
+
+	  top-frame frame-down frame-up frame-debug-function
+	  frame-code-location eval-in-frame return-from-frame frame-catches
+	  frame-number frame frame-p
+
+	  do-blocks debug-function-lambda-list do-debug-function-variables
+	  debug-function-symbol-variables ambiguous-debug-variables
+	  preprocess-for-eval function-debug-function debug-function-function
+	  debug-function-kind debug-function-name debug-function
+	  debug-function-p
+
+	  do-debug-block-locations debug-block-successors debug-block
+	  debug-block-p debug-block-elsewhere-p
+
+	  make-breakpoint activate-breakpoint deactivate-breakpoint
+	  breakpoint-hook-function breakpoint-info breakpoint-kind
+	  breakpoint-what breakpoint breakpoint-p
+
+	  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
+	  unknown-code-location unknown-code-location-p
+
+	  debug-source-from debug-source-name debug-source-created
+	  debug-source-compiled debug-source-root-number
+	  debug-source-start-positions form-number-translations
+	  source-path-context debug-source debug-source-p
+
+	  debug-condition no-debug-info no-debug-function-returns
+	  no-debug-blocks lambda-list-unavailable
+
+	  debug-error unhandled-condition invalid-control-stack-pointer
+	  unknown-code-location unknown-debug-variable invalid-value))
+
+
+
+;;;; Conditions.
+
+;;; The interface to building debugging tools signals conditions that prevent
+;;; it from adhering to its contract.  These are serious-conditions because the
+;;; program using the interface must handle them before it can correctly
+;;; continue execution.  These debugging conditions are not errors since it is
+;;; no fault of the programmers that the conditions occur.  The interface does
+;;; not provide for programs to detect these situations other than calling a
+;;; routine that detects them and signals a condition.  For example,
+;;; programmers call A which may fail to return successfully due to a lack of
+;;; debug information, and there is no B the they could have called to realize
+;;; A would fail.  It is not an error to have called A, but it is an error for
+;;; the program to then ignore the signal generated by A since it cannot
+;;; continue without A's correctly returning a value or performing some
+;;; operation.
+;;;
+;;; Use DEBUG-SIGNAL to signal these conditions.
+;;;
+
+(define-condition debug-condition (serious-condition)
+  ()
+  (:documentation
+   "All debug-conditions inherit from this type.  These are serious conditions
+    that must be handled, but they are not programmer errors."))
+
+(define-condition no-debug-info (debug-condition)
+  ()
+  (:documentation "There is absolutely no debugging information available.")
+  (:report (lambda (condition stream)
+	     (declare (ignore condition))
+	     (write-line "No debugging information available." stream))))
+
+(define-condition no-debug-function-returns (debug-condition)
+  (debug-function)
+  (:documentation
+   "The system could not return values from a frame with debug-function since
+    it lacked information about returning values.")
+  (:report (lambda (condition stream)
+	     (let ((fun (debug-function-function
+			 (no-debug-function-returns-debug-function condition))))
+	       (format stream
+		       "Cannot return values from ~:[frame~;~:*~S~] since the ~
+			debug information lacks details about returning values ~
+			here."
+		       fun)))))
+
+(define-condition no-debug-blocks (debug-condition)
+  (debug-function)
+  (:documentation "The debug-function has no debug-block information.")
+  (:report (lambda (condition stream)
+	     (format stream "~S has no debug-block information."
+		     (no-debug-blocks-debug-function condition)))))
+
+(define-condition lambda-list-unavailable (debug-condition)
+  (debug-function)
+  (:documentation
+   "The debug-function has no lambda-list since argument debug-variables are
+    unavailable.")
+  (:report (lambda (condition stream)
+	     (format stream "~S has no lambda-list information available."
+		     (lambda-list-unavailable-debug-function condition)))))
+
+
+
+;;;; Errors and DEBUG-SIGNAL.
+
+;;; The debug internals code tries to signal all programmer errors as
+;;; subtypes of debug-error.  There are calls to ERROR signalling simple-errors,
+;;; but these dummy checks in the code and shouldn't come up.
+;;;
+;;; While under development, this code also signals errors in code branches
+;;; that remain unimplemented.
+;;;
+
+(define-condition debug-error (error) ()
+  (:documentation
+   "All programmer errors from using the interface for building debugging
+    tools inherit from this type."))
+
+(define-condition unhandled-condition (debug-error)
+  ((condition))
+  (:report (lambda (condition stream)
+	     (format stream "~&Unhandled debug-condition:~%~A"
+		     condition))))
+
+(define-condition invalid-control-stack-pointer (debug-error)
+  ()
+  (:report (lambda (condition stream)
+	     (declare (ignore condition))
+	     (write-string "Invalid control stack pointer." stream))))
+
+(define-condition unknown-code-location (debug-error)
+  ((code-location))
+  (:report (lambda (condition stream)
+	     (format stream "Invalid use of an unknown code-location -- ~S."
+		     (unknown-code-location-code-location condition)))))
+
+(define-condition unknown-debug-variable (debug-error)
+  ((debug-variable)
+   (debug-function))
+  (:report (lambda (condition stream)
+	     (format stream "~S not in ~S."
+		     (unknown-debug-variable-debug-variable condition)
+		     (unknown-debug-variable-debug-function condition)))))
+
+(define-condition invalid-value (debug-error)
+  ((debug-variable)
+   (frame))
+  (:report (lambda (condition stream)
+	     (format stream "~S has :invalid or :unknown value in ~S."
+		     (invalid-value-debug-variable condition)
+		     (invalid-value-frame condition)))))
+
+
+;;; DEBUG-SIGNAL -- Internal.
+;;;
+;;; This signals debug-conditions.  If they go unhandled, then signal an
+;;; unhandled-condition error.
+;;;
+;;; ??? Get SIGNAL in the right package!
+;;;
+(defmacro debug-signal (datum &rest arguments)
+  `(let ((condition (ext:signal ,datum ,@arguments)))
+     (error 'unhandled-condition :condition condition)))
+
+
+
+;;;; Structures.
+
+;;; Most of these structures model information stored in internal data
+;;; structures created by the compiler.  Whenever comments preface an object or
+;;; type with "compiler", they refer to the internal compiler thing, not to the
+;;; object or type with the same name in the "DI" package.
+;;;
+
+
+;;;
+;;; Debug-variables
+;;;
+
+;;; These exist for caching data stored in packed binary form in compiler
+;;; debug-functions.  Debug-functions store these.
+;;;
+(defstruct (debug-variable (:print-function print-debug-variable)
+			   (:constructor make-debug-variable
+					 (name package id alive-p sc-offset
+					  save-sc-offset)))
+  ;;
+  ;; String name of variable.
+  (name nil :type simple-string)
+  ;;
+  ;; String name of package.  Nil when variable's name is uninterned.
+  (package nil :type (or null simple-string))
+  ;;
+  ;; Unique integer identification relative to other variables with the same
+  ;; name and package.
+  (id 0 :type c::index)
+  ;;
+  ;; Whether the variable always has a valid value.
+  (alive-p nil :type c::boolean)
+  ;;
+  ;; Storage class and offset.  (unexported).
+  (sc-offset nil :type c::sc-offset)
+  ;;
+  ;; Storage class and offset when saved somewhere.
+  (save-sc-offset nil :type (or c::sc-offset null)))
+
+(defun print-debug-variable (obj str n)
+  (declare (ignore n))
+  (format str "#<Debug-variable ~A:~A:~A>"
+	  (debug-variable-package obj)
+	  (debug-variable-name obj)
+	  (debug-variable-id obj)))
+
+(setf (documentation 'debug-variable-name 'function)
+  "Returns the name of the debug-variable.  The name is the name of the symbol
+   used as an identifier when writing the code.")
+
+(setf (documentation 'debug-variable-package 'function)
+  "Returns the package name of the debug-variable.  This is the package name of
+   the symbol used as an identifier when writing the code.")
+
+(setf (documentation 'debug-variable-id 'function)
+  "Returns the integer that makes debug-variable's name and package name unique
+   with respect to other debug-variable's in the same function.")
+
+;;;
+;;; Frames
+;;;
+
+;;; These represents call-frames on the stack.
+;;;
+(defstruct (frame (:print-function print-frame)
+		  (:constructor make-frame
+				(pointer up debug-function code-location number
+				 &optional escaped)))
+  ;;
+  ;; Next frame up.  Null when top frame.
+  (up nil :type (or frame null))
+  ;;
+  ;; Previous frame down.  Nil when the bottom frame.  Before computing the
+  ;; next frame down, this slot holds the frame pointer to the control stack
+  ;; for the given frame.  This lets us get the next frame down and the
+  ;; return-pc for that frame.
+  (%down :unparsed :type (or frame (member nil :unparsed)))
+  ;;
+  ;; Debug-function for function whose call this frame represents.
+  (debug-function nil :type debug-function)
+  ;;
+  ;; Code-location to continue upon return to frame.
+  (code-location nil :type code-location)
+  ;;
+  ;; A-list of catch-tags to code-locations.
+  (%catches :unparsed :type (or list (member :unparsed)))
+  ;;
+  ;; Pointer to frame on control stack.  (unexported)
+  pointer
+  ;;
+  ;; Indicates whether someone interrupted frame.  (unexported).
+  ;; If escaped, this is a pointer to the escape frame on the control stack.
+  escaped
+  ;;
+  ;; This is the frame's number for prompt printing.  Top is zero.
+  number)
+
+(defun print-frame (obj str n)
+  (declare (ignore n))
+  (format str "#<Frame ~S~:[~;, interrupted~]>"
+	  (debug-function-name (frame-debug-function obj))
+	  (frame-escaped obj)))
+
+(setf (documentation 'frame-up 'function)
+  "Returns the frame immediately above frame on the stack.  When frame is
+   the top of the stack, this returns nil.")
+
+(setf (documentation 'frame-debug-function 'function)
+  "Returns the debug-function for the function whose call frame represents.")
+
+(setf (documentation 'frame-code-location 'function)
+  "Returns the code-location where the frame's debug-function will continue
+   running when program execution returns to this frame.  If someone
+   interrupted this frame, the result could be an unknown code-location.")
+
+;;;
+;;; Debug-functions
+;;;
+
+;;; These exist for caching data stored in packed binary form in compiler
+;;; debug-functions.  *compiled-debug-functions* maps a c::debug-function to a
+;;; debug-function.  There should only be one debug-function in existence for
+;;; any function; that is, all code-locations and other objects that reference
+;;; debug-functions point to unique objects.  This is due to the overhead in
+;;; cached information.
+;;;
+(defstruct (debug-function (:print-function print-debug-function))
+  ;;
+  ;; Some representation of the function arguments.  See
+  ;; DEBUG-FUNCTION-LAMBDA-LIST.
+  ;; NOTE: must parse vars before parsing arg list stuff.
+  (%lambda-list :unparsed)
+  ;;
+  ;; Cached Debug-variable information.  (unexported).
+  ;; These are sorted by their name.
+  (debug-vars :unparsed :type (or simple-vector (member :unparsed)))
+  ;;
+  ;; Cached Debug-block information.  This is nil when we have tried to parse
+  ;; the packed binary info, but none is available.
+  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
+  ;;
+  ;; The actual function if available.
+  (%function :unparsed :type (or null function (member :unparsed))))
+
+(defun print-debug-function (obj str n)
+  (declare (ignore n))
+  (format str "#<Debug-function ~S>" (debug-function-name obj)))
+
+
+(defstruct (compiled-debug-function
+	    (:include debug-function)
+	    (:constructor %make-compiled-debug-function
+			  (compiler-debug-fun component)))
+  ;;
+  ;; Compiler's dumped debug-function information.  (unexported).
+  (compiler-debug-fun nil :type c::compiled-debug-function)
+  ;;
+  ;; Code object.  (unexported).
+  component)
+
+;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we
+;;; can get at cached stuff and not duplicate compiled-debug-function
+;;; structures.
+;;;
+(defvar *compiled-debug-functions* (make-hash-table :test #'eq))
+
+;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal.
+;;;
+;;; Makes a compiled-debug-function for a c::compiler-debug-function and its
+;;; component.  This maps the latter to the former in
+;;; *compiled-debug-functions*.  If there already is a compiled-debug-function,
+;;; then this returns it from *compiled-debug-functions*.
+;;;
+(defun make-compiled-debug-function (compiler-debug-fun component)
+  (or (gethash compiler-debug-fun *compiled-debug-functions*)
+      (setf (gethash compiler-debug-fun *compiled-debug-functions*)
+	    (%make-compiled-debug-function compiler-debug-fun component))))
+
+
+(defstruct (interpreted-debug-function (:include debug-function)))
+
+;;;
+;;; Debug-blocks.
+;;;
+
+;;; These exist for caching data stored in packed binary form in compiler
+;;; debug-blocks.
+;;;
+(defstruct (debug-block (:print-function print-debug-block)
+			(:constructor make-debug-block
+				      (code-locations successors elsewhere-p)))
+  ;;
+  ;; Code-location information for the block.
+  (code-locations nil :type simple-vector)
+  ;;
+  ;; Code-locations where execution continues after this block.
+  (successors nil :type list)
+  ;;
+  ;; This notes the block as a special glob of code shared by various functions
+  ;; and tucked away elsewhere in a component.  This kind of block has not
+  ;; start code-location.
+  (elsewhere-p nil :type c::boolean))
+
+(defun print-debug-block (obj str n)
+  (declare (ignore n))
+  (format str "#<Debug-block ~S>"
+	  ;; Fix up, for now assuming always have a code-location in 0.
+	  (debug-block-function-name obj)))
+
+(setf (documentation 'debug-block-successors 'function)
+  "Returns the list of possible code-locations where execution may continue
+   when the basic-block represented by debug-block completes its execution.")
+
+(setf (documentation 'debug-block-elsewhere-p 'function)
+  "Returns whether debug-block represents elsewhere code.")
+
+;;;
+;;; Breakpoints.
+;;;
+
+(defstruct (breakpoint (:print-function print-breakpoint)
+		       (:constructor %make-breakpoint))
+  hook-function	      ;Function takes frame, breakpoint, and optional values.
+  what		      ;Code-location or debug-function.
+  kind		      ;:code-location, :function-start, or :function-end.
+  info		      ;User settable and usable information.
+  active-p)	      ;Whether this breakpoint is in effect.
+
+(defun print-breakpoint (obj str n)
+  (declare (ignore n))
+  (let ((what (breakpoint-what obj)))
+    (format str "#<Breakpoint ~S~:[~;~:*~S~]>"
+	    (etypecase what
+	      (code-location what)
+	      (debug-function (debug-function-name what)))
+	    (etypecase what
+	      (code-location nil)
+	      (debug-function (breakpoint-kind obj))))))
+
+;;;
+;;; Code-locations.
+;;;
+
+(defstruct (code-location (:print-function print-code-location)
+			  (:constructor make-code-location
+					(pc debug-function &optional
+					 %tlf-offset %form-number %live-set kind
+					 ;; Any optional means it's known.
+					 (%unknown-p (not kind))))
+			  (:constructor make-unknown-code-location
+					(pc debug-function &aux (%unknown-p t))))
+  ;;
+  ;; This is an index into debug-function's component slot.
+  (pc nil :type c::index)
+  ;;
+  ;; This is the debug-function containing code-location.
+  (debug-function nil :type debug-function)
+  ;;
+  ;; This is initially :unsure.  Upon first trying to access an :unparsed slot,
+  ;; if the data is unavailable, then this becomes t, and the code-location is
+  ;; unknown.  If the data is available, this becomes nil, a known location.
+  ;; We can't use a separate type code-location for this since we must return
+  ;; code-locations before we can tell whether they're known or unknown.  For
+  ;; example, when parsing the stack, we don't want to unpack all the variables
+  ;; and blocks just to make frames.
+  (%unknown-p :unsure :type (member t nil :unsure))
+  ;;
+  ;; This is the debug-block containing code-location.
+  ;; Possibly toss this out and just find it in the blocks cache in
+  ;; debug-function.
+  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
+  ;;
+  ;; This is the number of forms processed by the compiler or loader before
+  ;; the top-level form containing this code-location.
+  (%tlf-offset :unparsed :type (or c::index (member :unparsed)))
+  ;;
+  ;; This is the depth-first number of the node that begins code-location
+  ;; within its top-level form.
+  (%form-number :unparsed :type (or c::index (member :unparsed)))
+  ;;
+  ;; This is a bit-vector indexed by a variable's position in
+  ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid
+  ;; value at this code-location.  (unexported).
+  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
+  ;;
+  ;; (unexported)
+  (kind :unparsed :type (member :unparsed :unknown-return :known-return
+				:internal-error :non-local-exit :block-start)))
+
+(defun print-code-location (obj str n)
+  (declare (ignore n))
+  (format str "#<~A ~S>"
+	  (ecase (code-location-unknown-p obj)
+	    ((nil) "Code-Location")
+	    ((t) "Unknown-Code-Location"))
+	  (debug-function-name (code-location-debug-function obj))))
+
+(setf (documentation 'code-location-debug-function 'function)
+  "Returns the debug-function representing information about the function
+   corresponding to the code-location.")
+
+;;;
+;;; Debug-sources
+;;;
+
+(proclaim '(inline debug-source-root-number))
+;;;
+(defun debug-source-root-number (debug-source)
+  "Returns the number of top-level forms processed by the compiler before
+   compiling this source.  If this source is uncompiled, this is zero.  This
+   may be zero even if the source is compiled since the first form in the first
+   file compiled in one compilation, for example, must have a root number of
+   zero -- the compiler saw no other top-level forms before it."
+  (c::debug-source-source-root debug-source))
+
+(setf (documentation 'c::debug-source-from 'function)
+  "Returns an indication of the type of source.  The following are the possible
+   values:
+      :file    from a file (obtained by COMPILE-FILE if compiled).
+      :lisp    from Lisp (obtained by COMPILE if compiled).
+      :stream  from a non-file stream.")
+
+(setf (documentation 'c::debug-source-name 'function)
+  "Returns the actual source in some sense represented by debug-source, which
+   is related to DEBUG-SOURCE-FROM:
+      :file    the pathname of the file.
+      :lisp    a lambda-expression.
+      :stream  some descriptive string that's otherwise useless.")
+
+(setf (documentation 'c::debug-source-created 'function)
+  "Returns the universal time someone created the source.  This may be nil if
+   it is unavailable.")
+
+(setf (documentation 'c::debug-source-compiled 'function)
+  "Returns the time someone compiled the source.  This is nil if the source
+   is uncompiled.")
+
+(setf (documentation 'c::debug-source-p 'function)
+  "Returns whether object is a debug-source.")
+
+;;;
+;;; Interpreted-debug-infos.
+;;;
+
+(defstruct (interpreted-debug-info
+	    (:print-function print-interpreted-debug-info))
+  )
+
+(defun print-interpreted-debug-info (obj str n)
+  (declare (ignore n obj))
+  (write-string "#<Interpreted-Debug-Info>" str))
+
+
+
+;;;; Frames.
+
+(proclaim '(inline pointer+offset pointer- stack-ref env-valid-p
+		   cstack-pointer-valid-p %set-stack-ref))
+
+(defun pointer- (next previous)
+  (system:%primitive pointer- next previous))
+
+(defun pointer+offset (x y)
+  (system:%primitive sap+ x (ash y 2)))
+
+(defun stack-ref (s n)
+  (system:%primitive read-control-stack (pointer+offset s n)))
+
+(defun %set-stack-ref (s n value)
+  (system:%primitive write-control-stack (pointer+offset s n) value))
+;;;
+(defsetf stack-ref %set-stack-ref)
+
+(defun env-valid-p (env)
+  (and (functionp env)
+       (eql (system:%primitive get-vector-subtype env)
+	    system:%function-constants-subtype)))
+
+(defun cstack-pointer-valid-p (x)
+  (and (system:%primitive pointer< x (system:%primitive current-sp))
+       (not (system:%primitive pointer< x
+			       (system:%primitive make-immediate-type 0
+						  system:%control-stack-type)))))
+
+
+;;; These are the names of all the functions that the system could have called
+;;; while interpreting.  We need to detect these when parsing the stack and
+;;; make frames representing the code the intepreter is evaluating.
+;;;
+(defconstant interpreter-function-names nil)
+
+;;; TOP-FRAME -- Public.
+;;;
+(defun top-frame ()
+  "Returns the top frame of the control stack as it was before calling this
+   function."
+  (compute-calling-frame (system:%primitive current-cont) nil))
+
+(defun frame-down (frame)
+  "Returns the frame immediately below frame on the stack.  When frame is
+   the bottom of the stack, this returns nil."
+  (let ((down (frame-%down frame)))
+    (if (eq down :unparsed)
+	(setf (frame-%down frame)
+	      (compute-calling-frame (frame-pointer frame) frame))
+	down)))
+
+;;; COMPUTE-CALLING-FRAME -- Internal.
+;;;
+;;; This returns a frame for the one existing in time immediately prior to the
+;;; frame referenced by current-fp.  This is current-fp's caller or the next
+;;; frame down the control stack.  If there is no down frame, this returns nil
+;;; for the bottom of the stack.  Up-frame is the up link for the resulting
+;;; frame object, and it is nil when we call this to get the top of the stack.
+;;;
+;;; The current frame contains the pointer to the temporally previous frame we
+;;; want, and the current frame contains the pc at which we will continue
+;;; executing upon returning to that previous frame.
+;;;
+(defun compute-calling-frame (current-fp up-frame)
+  (let ((caller (stack-ref current-fp c::old-cont-save-offset)))
+    (unless (cstack-pointer-valid-p caller)
+      (return-from compute-calling-frame nil))
+    (multiple-value-bind (env env-fp escaped)
+			 (fp-env caller current-fp)
+      (cond (escaped
+	     ;; If env-fp is escaped, then caller is the escape frame.
+	     (multiple-value-bind
+		 (env pc)
+		 (pc-offset (escape-register caller c::return-pc-offset)
+			    env up-frame)
+	       (let ((d-fun (debug-function-from-pc env pc)))
+		 (make-frame env-fp up-frame d-fun
+			     (code-location-from-pc d-fun pc)
+			     (if up-frame (1+ (frame-number up-frame)) 0)
+			     escaped))))
+	  #|((member (system:%primitive header-ref env
+					system:%function-name-slot)
+		     interpreter-function-names)
+	     ;; Just print calls within the interpreter as ... uh ... real calls
+	     ;; for now
+	     )|#
+	  (t
+	   (multiple-value-bind
+	       (env pc)
+	       (pc-offset (stack-ref current-fp c::return-pc-save-offset)
+			  env up-frame)
+	     (let ((d-fun (debug-function-from-pc env pc)))
+	       ;; env-fp = caller.
+	       (make-frame env-fp up-frame d-fun
+			   (code-location-from-pc d-fun pc)
+			   (if up-frame (1+ (frame-number up-frame)) 0)))))))))
+
+;;; PC-OFFSET -- Internal.
+;;;
+;;; THIS FUNCTION BECOMES TOTALLY UNNECESSARY IN THE NEW SYSTEM WHEN PC'S
+;;; ALWAYS DIRECTLY POINT TO COMPONENTS (OR ENVIRONMENTS).
+;;;
+;;; This takes a pc in the form of an interior pointer, the environment (code
+;;; component) in which to interpret the pc, and next frame up the stack.
+;;; Conceptually, we fetch the code vector from the environment and subtract
+;;; the code vector's address from pc, turning pc into an offset.  We also
+;;; subtract off the code vector's header size.  This leaves a pc that is an
+;;; offset into the code vector.
+;;;
+;;; We actually have to be careful performing the above activity.  Sometimes
+;;; the argument env is not a function or environment due to funny calling
+;;; conventions.  That is, someone accessed a slot in a frame to get the env,
+;;; but the particular calling convention used blew off storing a valid env in
+;;; the slot.  In this situation, use the frame's debug-function's environment
+;;; and call CHECK-PC to compute and check the offset's validity, signalling
+;;; an error if for some weird reason we still don't have a valid environment.
+;;;
+;;; Otherwise, assume the argument env is the environment and call CHECK-PC
+;;; without signalling an error when env is invalid.  The problem here is the
+;;; test described in the previous paragraph could yield a valid environment
+;;; object, but it isn't our environment as determined by CHECK-PC on the pc's
+;;; offset validity.  In this situation, as above, use the frame's
+;;; debug-function's environment and call CHECK-PC signalling an error if we
+;;; don't have a good environment still.
+;;;
+;;; CHECK-PC:
+;;;    We check the offset's validity by making sure it is a valid index into
+;;; the code vector.  If the pc, as an interior pointer, pointed into some
+;;; other code vector, then the address arithmetic would yield an invalid
+;;; index.  When the index is invalid, so is the environment, and we have to
+;;; iterate up the stack to find a frame that saved the appropriate
+;;; environment.  Not every frame saves its environment due to optimized local
+;;; calling conventions.  In this code, we always know someone has saved the
+;;; environment because before we get here, we know someone has used the full
+;;; call sequence (due to calling a debugger routine, calling ERROR, etc.), or
+;;; some frame has escaped.  We only have to look up the stack one frame since
+;;; the appropriate environment propagates down through the frame objects.
+;;;
+(defun pc-offset (pc env up-frame)
+  (flet ((check-pc (pc env errorp)
+	  (let* ((code-vector (system:%primitive header-ref env
+						 system:%function-code-slot))
+		 (offset (- (pointer- pc code-vector)
+			    clc::i-vector-header-size)))
+	    (cond ((<= 0 offset (length code-vector))
+		   (values env offset))
+		  (errorp
+		   (error "Unexpected inappropriate environment for pc."))
+		  (t nil)))))
+    (if (not (and (functionp env)
+		  (eql (system:%primitive get-vector-subtype env)
+		       #.system:%function-constants-subtype)))
+	(check-pc pc
+		  (compiled-debug-function-component
+		   (frame-debug-function up-frame))
+		  t)
+	(multiple-value-bind (env offset) (check-pc pc env nil)
+	  (if env
+	      (values env offset)
+	      (check-pc pc
+			(compiled-debug-function-component
+			 (frame-debug-function up-frame))
+			t))))))
+
+;;; FP-ENV -- Internal.
+;;;
+;;; This takes a frame pointer and returns its saved environment, taking care
+;;; if fp points to an escape frame.  As multiple values, this returns the
+;;; environment, the appropriate frame pointer for the environment, and whether
+;;; fp referenced an escape.  If fp is an escape frame, then we return fp as
+;;; the last value for convenience in accessing data saved in the escape frame.
+;;;
+(defun fp-env (fp current-fp)
+  (let ((env (stack-ref fp c::env-save-offset)))
+    (if (and (eql env 0)
+	     ;; If env is zero indicating an escape frame, then its return-pc
+	     ;; must point into an assembler routine for interrupts.
+	     (= (system:%primitive get-type
+				   (stack-ref current-fp
+					      c::return-pc-save-offset))
+		 system:%assembler-code-type))
+	;; Get the env of the interrupted frame.
+	(let ((env (escape-register fp c::env-offset)))
+	  (cond ((eql (system:%primitive get-type env) system:%trap-type)
+		 ;; Just ignore these for frame handling.
+		 )
+		((env-valid-p env)
+		 (values env
+			 ;; This is valid since the escape frame must be
+			 ;; preceded by some frame.
+			 (stack-ref fp c::old-cont-save-offset)
+			 fp))
+		(t
+		 (error "Escaping frame ENV invalid?"))))
+	(values env fp nil))))
+
+#|
+;;; FP-ENV -- Internal.
+;;;
+;;; This takes a frame pointer and returns its saved environment, taking care
+;;; if fp points to an escape frame.  As multiple values, this returns the
+;;; environment, the appropriate frame pointer for the environment, and whether
+;;; fp referenced an escape.  If fp is an escape frame, then we return fp as
+;;; the last value for convenience in accessing data saved in the escape frame.
+;;;
+(defun fp-env (fp)
+  (let ((env (stack-ref fp c::env-save-offset)))
+    (if (eql env 0)
+	;; Get the env of the interrupted frame.
+	(let ((env (escape-register fp c::env-offset)))
+	  (cond ((eql (system:%primitive get-type env) system:%trap-type)
+		 ;; Just ignore these for frame handling.
+		 )
+		((env-valid-p env)
+		 (values env
+			 ;; This is valid since the escape frame must be
+			 ;; preceded by some frame.
+			 (stack-ref fp c::old-cont-save-offset)
+			 fp))
+		(t
+		 (error "Escaping frame ENV invalid?"))))
+	(values env fp nil))))
+
+|#
+
+;;;
+;;; Frame utilities.
+;;;
+
+;;; ESCAPE-REGISTER -- Internal.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  This function returns the n'th saved register.  F is the
+;;; frame pointer to the escape frame which notes that someone interrupted the
+;;; previous frame.
+;;;
+(defun escape-register (f n)
+  (stack-ref f (+ n system:%escape-frame-general-register-start-slot)))
+
+;;; DEBUG-FUNCTION-FROM-PC -- Internal.
+;;;
+;;; This returns a compiled-debug-function for env and pc.  We fetch the
+;;; c::debug-info and run down its function-map to get a
+;;; c::compiled-debug-function from the pc.  The result only needs to reference
+;;; the component, for function constants, and the c::compiled-debug-function.
+;;;
+(defun debug-function-from-pc (env pc)
+  (let* ((component (function-code-header env))
+	 (info (system:%primitive header-ref component
+				  system:%function-constants-debug-info-slot)))
+    (unless info
+      (debug-signal 'no-debug-info))
+    (let* ((function-map (c::compiled-debug-info-function-map info))
+	   (len (length function-map)))
+      (declare (simple-vector function-map))
+      (if (= len 1)
+	  (make-compiled-debug-function (svref function-map 0) component)
+	  (let ((i 1))
+	    (declare (type c::index i))
+	    (loop
+	      (when (or (= i len) (< pc (svref function-map i)))
+		(return (make-compiled-debug-function (svref function-map (1- i))
+						      component)))
+	      (incf i 2)))))))
+
+;;; FUNCTION-CODE-HEADER -- Internal.
+;;;
+;;; This returns a pointer to the code data-block containing the function.  The
+;;; code header contains constants and debug-info.  First we fetch the
+;;; function's header word and shift out the type tag, leaving the offset back
+;;; to the code header.  Negate that and add it to the pointer to fun.
+;;;
+;;; IGNORE THE ABOVE COMMENT UNTIL RUNNING WITH THE NEW DATA FORMAT FOR THE
+;;; NEW SYSTEM.
+;;;
+(defun function-code-header (fun)
+  (ecase (system:%primitive get-vector-subtype fun)
+    ((#.system:%function-entry-subtype #.system:%function-closure-entry-subtype)
+     (system:%primitive header-ref fun system:%function-entry-constants-slot))
+    (#.system:%function-closure-subtype
+     (system:%primitive header-ref
+			(system:%primitive header-ref fun
+					   system:%function-name-slot)
+			system:%function-entry-constants-slot))
+    (#.system:%function-constants-subtype
+     fun)))
+
+;;; CODE-LOCATION-FROM-PC -- Internal.
+;;;
+;;; This returns a code-location for the compiled-debug-function, debug-fun,
+;;; and the pc into its code vector.  If there is debug-block info, we assume
+;;; the code-location is known by making a default one.  It may later prove
+;;; to be unknown as :unparsed slots are accessed.
+;;;
+(defun code-location-from-pc (debug-fun pc)
+  ;; For now, and this might be right:
+  (if (c::compiled-debug-function-blocks
+       (compiled-debug-function-compiler-debug-fun
+	debug-fun))
+      (make-code-location pc debug-fun)
+      (make-unknown-code-location pc debug-fun)))
+
+(defun frame-catches (frame)
+  "Returns an a-list mapping catch tags to code-locations.  These are
+   code-locations at which execution would continue with frame as the top
+   frame if someone threw to the corresponding tag."
+  (let ((catch (system:%primitive active-catch-frame))
+	(res nil)
+	(fp (frame-pointer frame)))
+    (loop
+      (when (eql catch 0) (return (nreverse res)))
+      (when (eq fp (stack-ref catch system:%unwind-block-current-cont))
+	(push (cons (stack-ref catch system:%catch-block-tag)
+		    (make-code-location
+		     (- (stack-ref catch system:%unwind-block-entry-pc)
+			clc::i-vector-header-size)
+		     (frame-debug-function frame)))
+	      res))
+      (setf catch (stack-ref catch system:%catch-block-previous-catch)))))
+
+
+
+;;;; Debug-functions.
+
+;;; DO-BLOCKS -- Public.
+;;;
+(defmacro do-blocks ((block-var debug-function &optional result) &body body)
+  "Executes the forms in a context with block-var bound to each debug-block
+   in debug-function successively.  Result is an optional form to execute for
+   return values, and DO-BLOCKS returns nil if there is no result form.  This
+   signals a no-debug-blocks condition when the debug-function lacks
+   debug-block information."
+  (let ((blocks (gensym))
+	(i (gensym)))
+    `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
+       (declare (simple-vector ,blocks))
+       (dotimes (,i (length ,blocks) ,result)
+	 (let ((,block-var (svref ,blocks ,i)))
+	   ,@body)))))
+
+;;; DO-DEBUG-FUNCTION-VARIABLES -- Public.
+;;;
+(defmacro do-debug-function-variables ((var debug-function &optional result)
+				       &body body)
+  "Executes body in a context with var bound to each debug-variable in
+   debug-function.  This returns the value of executing result (defaults to
+   nil).  This may iterate over only some of debug-function's variables or none
+   depending on debug policy; for example, possibly the compilation only
+   preserved argument information."
+  (let ((vars (gensym))
+	(i (gensym)))
+    `(let ((,vars (debug-function-debug-variables ,debug-function)))
+       (declare (simple-vector ,vars))
+       (dotimes (,i (length ,vars) ,result)
+	 (let ((,var (svref ,vars ,i)))
+	   ,@body)))))
+
+;;; DEBUG-FUNCTION-FUNCTION -- Public.
+;;;
+;;; ??? Can't work on the RT before back porting the new system from the MIPS.
+;;;
+(defun debug-function-function (debug-function)
+  "Returns the Common Lisp function associated with the debug-function.  This
+   returns nil if the function is unavailable or is non-existent as a user
+   callable function object."
+  (etypecase debug-function
+    (compiled-debug-function
+     (setf (debug-function-%function debug-function) nil))
+    (interpreted-debug-function
+     (error "Can't currently debug interpreted functions."))))
+
+;;; DEBUG-FUNCTION-NAME -- Public.
+;;;
+(defun debug-function-name (debug-function)
+  "Returns the name of the function represented by debug-function.  This may
+   be a string or a cons; do not assume it is a symbol."
+  (etypecase debug-function
+    (compiled-debug-function
+     (c::compiled-debug-function-name
+      (compiled-debug-function-compiler-debug-fun debug-function)))
+    (interpreted-debug-function
+     (error "Can't get interpreted-debug-function names now."))))
+
+;;; FUNCTION-DEBUG-FUNCTION -- Public.
+;;;
+(defun function-debug-function (fun)
+  "Returns a debug-function that represents debug information for function."
+  (debug-function-from-pc
+   fun
+   (- (system:%primitive header-ref fun system:%function-offset-slot)
+      clc::i-vector-header-size)))
+
+;;; DEBUG-FUNCTION-KIND -- Public.
+;;;
+(defun debug-function-kind (debug-function)
+  "Returns the kind of the function which is one of :optional, :external,
+   :top-level, :cleanup, nil."
+  (etypecase debug-function
+    (compiled-debug-function
+     (c::compiled-debug-function-kind
+      (compiled-debug-function-compiler-debug-fun debug-function)))
+    (interpreted-debug-function
+     (error "We don't debug interpreted functions now."))))
+
+;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public.
+;;;
+(defun debug-function-symbol-variables (debug-function symbol)
+  "Returns a list of debug-variables in debug-function having the same name
+   and package as symbol.  If symbol is uninterned, then this returns a list of
+   debug-variables without package names and with the same name as symbol.  The
+   result of this function is limited to the availability of variable
+   information in debug-function; for example, possibly debug-function only
+   knows about its arguments."
+  (let ((vars (ambiguous-debug-variables debug-function (symbol-name symbol)))
+	(package (if (symbol-package symbol)
+		     (package-name (symbol-package symbol)))))
+    (delete-if (if (stringp package)
+		   #'(lambda (var)
+		       (let ((p (debug-variable-package var)))
+			 (or (not (stringp p))
+			     (string/= p package))))
+		   #'(lambda (var)
+		       (stringp (debug-variable-package var))))
+	       vars)))
+
+;;; AMBIGUOUS-DEBUG-VARIABLES -- Public.
+;;;
+(defun ambiguous-debug-variables (debug-function name-prefix-string)
+   "Returns a list of debug-variables in debug-function whose names contain
+    name-prefix-string as an intial substring.  The result of this function is
+    limited to the availability of variable information in debug-function; for
+    example, possibly debug-function only knows about its arguments."
+  (declare (simple-string name-prefix-string))
+  (let* ((variables (debug-function-debug-variables debug-function))
+	 (len (length variables))
+	 (prefix-len (length name-prefix-string))
+	 (pos (find-variable name-prefix-string variables len))
+	 (res nil))
+    (declare (simple-vector variables))
+    (when pos
+      ;; Find names from pos to variable's len that contain prefix.
+      (do ((i pos (1+ i)))
+	  ((= i len))
+	(let* ((var (svref variables i))
+	       (name (debug-variable-name var))
+	       (name-len (length name)))
+	  (declare (simple-string name))
+	  (when (/= (or (string/= name-prefix-string name
+				  :end1 prefix-len :end2 name-len)
+			prefix-len)
+		    prefix-len)
+	    (return))
+	  (push var res)))
+      (setq res (nreverse res)))
+    res))
+
+;;; FIND-VARIABLE -- Internal.
+;;;
+;;; This returns a position in variables for one containing name as an initial
+;;; substring.  End is the length of variables if supplied.
+;;;
+(defun find-variable (name variables &optional end)
+  (declare (simple-vector variables)
+	   (simple-string name))
+  (let ((name-len (length name)))
+    (position name variables
+	      :test #'(lambda (x y)
+			(let* ((y (debug-variable-name y))
+			       (y-len (length y)))
+			  (declare (simple-string y))
+			  (and (>= y-len name-len)
+			       (string= x y :end1 name-len :end2 name-len))))
+	      :end (or end (length variables)))))
+
+#|
+    (multiple-value-bind (pos found)
+			 (find-variable name-prefix-string variables len)
+      (declare (ignore found))
+      ;;
+      ;; Find names from pos to variable's len that contain prefix.
+      (do ((i pos (1+ i)))
+	  ((= i len))
+	(let* ((var (svref variables i))
+	       (name (debug-variable-name var))
+	       (name-len (length name)))
+	  (declare (simple-string name))
+	  (when (/= (or (string/= name-prefix-string name
+				  :end1 prefix-len :end2 name-len)
+			prefix-len)
+		    prefix-len)
+	    (return))
+	  (push var res)))
+      (setq res (nreverse res))
+      ;;
+      ;; Find names from pos to initial variable containing prefix.
+      (do ((i (1- pos) (1- i)))
+	  ((minusp i))
+	(let* ((var (svref variables i))
+	       (name (debug-variable-name var))
+	       (name-len (length name)))
+	  (declare (simple-string name))
+	  (when (/= (or (string/= name-prefix-string name
+				  :end1 prefix-len :end2 name-len)
+			prefix-len)
+		    prefix-len)
+	    (return))
+	  (push var res))))
+
+;;; FIND-VARIABLE -- Internal.
+;;;
+;;; This does a binary search on variables for the one containing name as an
+;;; initial substring.  End is the length of variables if supplied.  This
+;;; returns two values: the position of the entry, and whether it was found.
+;;; When it wasn't found, the position is where to insert a new entry.
+;;;
+(defun find-variable (name variables &optional end)
+  (declare (simple-vector variables)
+	   (simple-string name))
+  (let ((low 0)
+	(high (or end (length variables)))
+	(mid 0)
+	(name-len (length name)))
+    (declare (fixnum low high mid name-len))
+    (loop
+      (when (< high low) (return (values low nil)))
+      (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
+      (let* ((test-name (debug-variable-name (svref variables mid)))
+	     (test-name-len (length test-name)))
+	(declare (simple-string test-name) (fixnum test-name-len))
+	(let ((res (string/= name test-name
+			     :end1 name-len :end2 test-name-len)))
+	  (declare (type (or null fixnum) res))
+	  (cond ((null res)
+		 (return (values mid t)))
+		((= res name-len)
+		 (setf high (1- mid)))
+		((= res test-name-len)
+		 (setf low (1+ mid)))
+		((char< (schar name res) (schar test-name res))
+		 (setf high (1- mid)))
+		(t (setf low (1+ mid)))))))))
+|#
+
+;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public.
+;;;
+(defun debug-function-lambda-list (debug-function)
+  "Returns a list representing the lambda-list for debug-function.  The list
+   has the following structure:
+      (required-var1 required-var2
+       ...
+       (:optional var3 suppliedp-var4)
+       (:optional var5)
+       ...
+       (:rest var6) (:rest var7)
+       ...
+       (:keyword keyword-symbol var8 suppliedp-var9)
+       (:keyword keyword-symbol var10)
+       ...
+      )
+   Each VARi is a debug-variable."
+  (let ((lambda-list (debug-function-%lambda-list debug-function)))
+    (cond ((eq lambda-list :unparsed)
+	   (etypecase debug-function
+	     (compiled-debug-function
+	      (multiple-value-bind
+		  (args argsp)
+		  (compiled-debug-function-lambda-list debug-function)
+		(setf (debug-function-%lambda-list debug-function) args)
+		(if argsp
+		    args
+		    (debug-signal 'lambda-list-unavailable
+				  :debug-function debug-function))))
+	     (interpreted-debug-function
+	      (error "Can't get lambda-lists for interpreted-debug-functions ~
+		      currently."))))
+	  (lambda-list)
+	  ((c::compiled-debug-function-arguments
+	    (compiled-debug-function-compiler-debug-fun
+	     debug-function))
+	   ;; If the packed information is there (whether empty or not) as
+	   ;; opposed to being nil, then returned our cached value (nil).
+	   nil)
+	  (t
+	   ;; Our cached value is nil, and the packed lambda-list information
+	   ;; is nil, so we don't have anything available.
+	   (debug-signal 'lambda-list-unavailable
+			 :debug-function debug-function)))))
+
+;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
+;;;
+;;; DEBUG-FUNCTION-LAMBDA-LIST calls this when a compiled-debug-function has no
+;;; lambda-list information cached.  It returns the lambda-list as the first
+;;; value and whether there was any argument information as the second value.
+;;;
+(defun compiled-debug-function-lambda-list (debug-function)
+  (let ((args (c::compiled-debug-function-arguments
+	       (compiled-debug-function-compiler-debug-fun
+		debug-function))))
+    (declare (type (or (simple-array * (*)) null) args))
+    (if (not args)
+	(values nil nil)
+	(let ((vars (debug-function-debug-variables debug-function))
+	      (i 0)
+	      (len (length args))
+	      (res nil))
+	  (declare (simple-vector vars))
+	  (loop
+	    (when (>= i len) (return))
+	    (let ((ele (aref args i)))
+	      (if (symbolp ele)
+		  (case ele
+		    (c::deleted
+		     ;; Deleted required arg at beginning of args array.
+		     (push :deleted res))
+		    (c::supplied-p
+		     ;; supplied-p var immediately following keyword or optional.
+		     ;; Stick the extra var in the result element representing
+		     ;; the keyword or optional.
+		     ;; ACTUALLY, WE DON'T HANDLE OPTIONALS CORRECTLY YET. ???
+		     (let ((last (car res))
+			   (v (compiled-debug-function-lambda-list-var
+			       args (incf i) vars)))
+		       (if (typep last 'cons)
+			   (nconc last (list v))
+			   (setf (car res) (list :optional last v)))))
+		    (c::rest-arg
+		     (push (list :rest
+				 (compiled-debug-function-lambda-list-var
+				  args (incf i) vars))
+			   res))
+		    (c::more-arg
+		     (error "I thought I'd never see a more-arg?"))
+		    (t
+		     ;; Keyword arg.
+		     (push (list :keyword
+				 ele
+				 (compiled-debug-function-lambda-list-var
+				  args (incf i) vars))
+			   res)))
+		  ;; Required arg at beginning of args array.
+		  (push (svref vars ele) res)))
+	    (incf i))
+	  (values (nreverse res) t)))))
+
+;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal
+;;;
+;;; Used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
+;;;
+(defun compiled-debug-function-lambda-list-var (args i vars)
+  (declare (type (simple-array * (*)) args)
+	   (simple-vector vars))
+  (let ((ele (aref args i)))
+    (cond ((not (symbolp ele)) (svref vars ele))
+	  ((eq ele 'c::deleted) :deleted)
+	  (t (error "Malformed arguments description.")))))
+
+;;; DEBUG-FUNCTION-DEBUG-INFO -- Internal Interface.
+;;;
+(defun debug-function-debug-info (debug-fun)
+  (etypecase debug-fun
+    (compiled-debug-function
+     (system:%primitive header-ref
+			(compiled-debug-function-component debug-fun)
+			system:%function-constants-debug-info-slot))
+    (interpreted-debug-function
+     (error "Can't currently get the debug-info for an ~
+	     interpreted-debug-function."))))
+
+
+
+;;;; Unpacking variable and basic block data.
+
+(defvar *parsing-buffer*
+  (make-array 20 :adjustable t :fill-pointer t))
+(defvar *other-parsing-buffer*
+  (make-array 20 :adjustable t :fill-pointer t))
+;;;
+;;; WITH-PARSING-BUFFER -- Internal.
+;;;
+;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARIABLES use this to unpack binary
+;;; encoded information.  It returns the values returned by the last form
+;;; in body.
+;;;
+;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element
+;;; zero, and makes sure if we unwind, we nil out any set elements for GC
+;;; purposes.
+;;;
+;;; This also binds other-var to *other-parsing-buffer* when it is supplied,
+;;; making sure it starts at element zero and that we nil out any elements if
+;;; we unwind.
+;;;
+;;; This defines the local macro RESULT that takes a buffer, copies its
+;;; elements to a resulting simple-vector, nil's out elements, and restarts
+;;; the buffer at element zero.  RESULT returns the simple-vector.
+;;;
+(eval-when (compile eval)
+(defmacro with-parsing-buffer ((buffer-var &optional other-var) &body body)
+  (let ((len (gensym))
+	(res (gensym)))
+    `(unwind-protect
+	 (let ((,buffer-var *parsing-buffer*)
+	       ,@(if other-var `((,other-var *other-parsing-buffer*))))
+	   (setf (fill-pointer ,buffer-var) 0)
+	   ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
+	   (macrolet ((result (buf)
+			`(let* ((,',len (length ,buf))
+				(,',res (make-array ,',len)))
+			   (replace ,',res ,buf :end1 ,',len :end2 ,',len)
+			   (fill ,buf nil :end ,',len)
+			   (setf (fill-pointer ,buf) 0)
+			   ,',res)))
+	     ,@body))
+     (fill *parsing-buffer* nil)
+     ,@(if other-var `((fill *other-parsing-buffer* nil))))))
+) ;eval-when
+
+
+;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal Interface.
+;;;
+;;; The argument is a debug internals structure.  This returns the debug-blocks
+;;; for debug-function, regardless of whether we have unpacked them yet.  It
+;;; signals a no-debug-blocks condition if it can't return the blocks.
+;;;
+(defun debug-function-debug-blocks (debug-function)
+  (etypecase debug-function
+    (compiled-debug-function
+     (let ((blocks (debug-function-blocks debug-function)))
+       (cond ((eq blocks :unparsed)
+	      (setf (debug-function-blocks debug-function)
+		    (parse-debug-blocks debug-function))
+	      (unless (debug-function-blocks debug-function)
+		(debug-signal 'no-debug-blocks
+			      :debug-function debug-function))
+	      (debug-function-blocks debug-function))
+	     (blocks)
+	     (t
+	      (debug-signal 'no-debug-blocks
+			    :debug-function debug-function)))))
+    (interpreted-debug-function
+     (error "We don't currently support interpreted-debug-functions."))))
+
+;;; PARSE-DEBUG-BLOCKS -- Internal.
+;;;
+;;; Debug-fun is a c::compiled-debug-function.  Var-count is how many variables
+;;; the live-set data in packed binary form represents.
+;;;
+(defun parse-debug-blocks (debug-function)
+  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
+	 (var-count (length (the simple-vector (debug-function-debug-variables
+						debug-function))))
+	 (blocks (c::compiled-debug-function-blocks debug-fun))
+	 ;; 8 is a hard-wired constant in the compiler for the element size of
+	 ;; of the packed binary form of the blocks data.
+	 (live-set-len (ceiling var-count 8))
+	 (tlf-number (c::compiled-debug-function-tlf-number debug-fun)))
+    (unless blocks (return-from parse-debug-blocks nil))
+    (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
+      (with-parsing-buffer (blocks-buffer locations-buffer)
+	(let ((i 0)
+	      (len (length blocks))
+	      (last-pc 0))
+	  (loop
+	    (when (>= i len) (return))
+	    (let ((succ-and-flags (aref+ blocks i))
+		  (successors nil))
+	      (declare (type (unsigned-byte 8) succ-and-flags)
+		       (list successors))
+	      (dotimes (k (ldb c::compiled-debug-block-nsucc-byte
+			       succ-and-flags))
+		(push (c::read-var-integer blocks i) successors))
+	      (let* ((locations
+		      (dotimes (k (c::read-var-integer blocks i)
+				  (result locations-buffer))
+			(let ((kind (svref c::compiled-code-location-kinds
+					   (aref+ blocks i)))
+			      (pc (+ last-pc (c::read-var-integer blocks i)))
+			      (tlf-offset (or tlf-number
+					      (c::read-var-integer blocks i)))
+			      (form-number (c::read-var-integer blocks i))
+			      (live-set (c::read-packed-bit-vector
+					 live-set-len blocks i)))
+			  (vector-push-extend (make-code-location
+					       pc debug-function tlf-offset
+					       form-number live-set kind)
+					      locations-buffer)
+			  (setf last-pc pc))))
+		     (block (make-debug-block
+			     locations successors
+			     (not (zerop (logand
+					  c::compiled-debug-block-elsewhere-p
+					  succ-and-flags))))))
+		(vector-push-extend block blocks-buffer)
+		(dotimes (k (length locations))
+		  (setf (code-location-%debug-block (svref locations k))
+			block))))))
+	(let ((res (result blocks-buffer)))
+	  (declare (simple-vector res))
+	  (dotimes (i (length res))
+	    (let* ((block (svref res i))
+		   (succs nil))
+	      (dolist (ele (debug-block-successors block))
+		(push (svref res ele) succs))
+	      (setf (debug-block-successors block) succs)))
+	  res)))))
+
+;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal Interface.
+;;;
+;;; The argument is a debug internals structure.  The resulting vector may be
+;;; empty.
+;;;
+(defun debug-function-debug-variables (debug-function)
+  (etypecase debug-function
+    (compiled-debug-function
+     (let ((vars (debug-function-debug-vars debug-function)))
+       (if (eq vars :unparsed)
+	   (setf (debug-function-debug-vars debug-function)
+		 (parse-debug-variables debug-function))
+	   vars)))
+    (interpreted-debug-function
+     (error "We don't currently support interpreted-debug-functions."))))
+
+;;; PARSE-DEBUG-VARIABLES -- Internal.
+;;;
+;;; This parses the packed binary representation of debug-variables from
+;;; debug-function's c::compiled-debug-function.
+;;;
+(defun parse-debug-variables (debug-function)
+  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
+	 (packed-vars (c::compiled-debug-function-variables debug-fun))
+	 (default-package (c::compiled-debug-info-package
+			   (debug-function-debug-info debug-function))))
+    (when (or (not packed-vars) (zerop (length packed-vars)))
+      (return-from parse-debug-variables '#()))
+    (let ((i 0)
+	  (len (length packed-vars)))
+      (with-parsing-buffer (buffer)
+	(loop
+	  (let ((flags (aref packed-vars i)))
+	    (declare (type (unsigned-byte 8) flags))
+	    (incf i)
+	    ;; The routines in the "C" package are macros that advance the index.
+	    (let ((name (c::read-var-string packed-vars i))
+		  (package (cond ((not
+				   (zerop
+				    (logand c::compiled-debug-variable-packaged
+					    flags)))
+				  (c::read-var-string packed-vars i))
+				 ((zerop
+				   (logand c::compiled-debug-variable-uninterned
+					   flags))
+				  default-package)
+				 (t nil)))
+		  (id (if (zerop (logand c::compiled-debug-variable-id-p
+					 flags))
+			  0
+			  (c::read-var-integer packed-vars i)))
+		  (sc-offset (c::read-var-integer packed-vars i))
+		  (save-sc-offset (if (zerop
+				       (logand
+					c::compiled-debug-variable-save-loc-p
+					flags))
+				      nil
+				      (c::read-var-integer packed-vars i))))
+	      (vector-push-extend
+	       (make-debug-variable
+		name package id
+		(not (zerop (logand c::compiled-debug-variable-environment-live
+				    flags)))
+		sc-offset save-sc-offset)
+	       buffer)))
+	  (when (>= i len) (return)))
+	(result buffer)))))
+
+
+
+;;;; Code-locations.
+
+;;; CODE-LOCATION-UNKNOWN-P -- Public.
+;;;
+;;; If we're sure of whether code-location is known, return t or nil.  If we're
+;;; :unsure, then try to fill in the code-location's slots.  This determines
+;;; whether there is any debug-block information, and if code-location is
+;;; known.
+;;;
+;;; ??? IF this conses closures every time it's called, then break off the
+;;; :unsure part to get the HANDLER-CASE into another function.
+;;;
+(defun code-location-unknown-p (basic-code-location)
+  "Returns whether basic-code-location is unknown.  It returns nil when the
+   code-location is known."
+  (ecase (code-location-%unknown-p basic-code-location)
+    ((t) t)
+    ((nil) nil)
+    (:unsure
+     (setf (code-location-%unknown-p basic-code-location)
+	   (handler-case (not (fill-in-code-location basic-code-location))
+	     (no-debug-blocks () t))))))
+
+;;; CODE-LOCATION-DEBUG-BLOCK -- Public.
+;;;
+;;; We don't use CODE-LOCATION= since the code-location may be unknown, but
+;;; even when it is, we can determine the block.  To do this we have to check
+;;; pc ranges for the blocks.  We use DEBUG-FUNCTION-DEBUG-BLOCKS to make sure
+;;; any block info is unparsed and to signal a no-debug-blocks condition when
+;;; appropriate.
+;;;
+;;; If there's only one block, it must be it.  If there's more than one, we
+;;; skip the first one and find the first block whose first code-location is
+;;; greater than we want.  Then we know we want the previous block.  The last
+;;; block is special since it may represent elsewhere code which has no start
+;;; code-location.  If it is elsewhere code, it starts where the
+;;; c::compiled-debug-function tells us the elsewhere code starts.
+;;;
+;;; ??? How to write this for interpreted code-locations.
+;;;
+(defun code-location-debug-block (basic-code-location)
+  "Returns the debug-block containing code-location if it is available.  Some
+   debug policies inhibit debug-block information, and if none is available,
+   then this signals a no-debug-blocks condition."
+  (let ((block (code-location-%debug-block basic-code-location)))
+    (if (eq block :unparsed)
+	(let* ((pc (code-location-pc basic-code-location))
+	       (debug-function (code-location-debug-function
+				basic-code-location))
+	       (blocks (debug-function-debug-blocks debug-function))
+	       (len (length blocks)))
+	  (declare (simple-vector blocks))
+	  (setf
+	   (code-location-%debug-block basic-code-location)
+	   (if (= len 1)
+	       (svref blocks 0)
+	       (do ((i 1 (1+ i))
+		    (end (1- len)))
+		   ((= i end)
+		    (let ((last (svref blocks end)))
+		      (cond
+		       ((debug-block-elsewhere-p last)
+			(if (< pc
+			       (c::compiled-debug-function-elsewhere-pc
+				(compiled-debug-function-compiler-debug-fun
+				 debug-function)))
+			    (svref blocks (1- end))
+			    last))
+		       ((< pc
+			   (code-location-pc
+			    (svref (debug-block-code-locations last)
+				   0)))
+			(svref blocks (1- end)))
+		       (t last))))
+		 (declare (type c::index i end))
+		 (when (< pc
+			  (code-location-pc
+			   (svref (debug-block-code-locations (svref blocks i))
+				  0)))
+		   (return (svref blocks (1- i))))))))
+	block)))
+
+;;; CODE-LOCATION-DEBUG-SOURCE -- Public.
+;;;
+(defun code-location-debug-source (code-location)
+  "Returns the code-location's debug-source."
+  (let ((info (debug-function-debug-info
+	       (code-location-debug-function code-location))))
+    (etypecase info
+      (c::compiled-debug-info
+       (let* ((sources (c::compiled-debug-info-source info))
+	      (len (length sources)))
+	 (declare (list sources))
+	 (if (= len 1)
+	     (car sources)
+	     (do ((prev (car sources) src)
+		  (src (cdr sources) (cdr src))
+		  (offset (code-location-top-level-form-offset code-location)))
+		 ((null src) (car prev))
+	       (when (< offset (c::debug-source-source-root (car src)))
+		 (car prev))))))
+      (interpreted-debug-info
+       (error "Can't handle interpreted-debug-infos.")))))
+
+;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public.
+;;;
+(defun code-location-top-level-form-offset (code-location)
+  "Returns the number of top-level forms before the one containing
+   code-location as seen by the compiler in some compilation unit.  A
+   compilation unit is not necessarily a single file, see the section on
+   debug-sources."
+  (when (code-location-unknown-p code-location)
+    (error 'unknown-code-location :code-location code-location))
+  (let ((tlf-offset (code-location-%tlf-offset code-location)))
+    (cond ((eq tlf-offset :unparsed)
+	   (unless (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."))
+	   (code-location-%tlf-offset code-location))
+	  (t tlf-offset))))
+
+;;; CODE-LOCATION-FORM-NUMBER -- Public.
+;;;
+(defun code-location-form-number (code-location)
+  "Returns the number of the form corresponding to code-location.  The form
+   number is derived by a walking the subforms of a top-level form in
+   depth-first order."
+  (when (code-location-unknown-p code-location)
+    (error 'unknown-code-location :code-location code-location))
+  (let ((form-num (code-location-%form-number code-location)))
+    (cond ((eq form-num :unparsed)
+	   (unless (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."))
+	   (code-location-%form-number code-location))
+	  (t form-num))))
+
+;;; CODE-LOCATION-LIVE-SET -- Internal Interface.
+;;;
+;;; This returns the code-location's live-set if it is available.  If there
+;;; is no debug-block information, this returns nil.
+;;;
+(defun code-location-live-set (code-location)
+  (if (code-location-unknown-p code-location)
+      nil
+      (let ((live-set (code-location-%live-set code-location)))
+	(cond ((eq live-set :unparsed)
+	       (unless (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."))
+	       (code-location-%live-set code-location))
+	      (t live-set)))))
+
+;;; CODE-LOCATION= -- Public.
+;;;
+(defun code-location= (obj1 obj2)
+  "Returns whether obj1 and obj2 are the same place in the code."
+  (let ((d-fun1 (code-location-debug-function obj1))
+	(d-fun2 (code-location-debug-function obj2)))
+    (and (eq d-fun1 d-fun2)
+	 (sub-code-location= d-fun1 obj1 obj2))))
+
+(defun sub-code-location= (d-fun1 obj1 obj2)
+  (etypecase d-fun1
+    (compiled-debug-function
+     (= (code-location-pc obj1) (code-location-pc obj2)))
+    (interpreted-debug-function
+     ;; ??? compare IR1 nodes?
+     (error "Cannot compare interpreted-debug-functions currently."))))
+
+;;; FILL-IN-CODE-LOCATION -- Internal.
+;;;
+;;; This fills in location's :unparsed slots.  It returns t or nil depending on
+;;; whether the code-location was known in its debug-function's debug-block
+;;; information.  This may signal a no-debug-blocks condition due to
+;;; DEBUG-FUNCTION-DEBUG-BLOCKS, and it assumes the %unknown-p slot is already
+;;; set or going to be set.
+;;;
+(defun fill-in-code-location (code-location)
+  (let* ((debug-function (code-location-debug-function code-location))
+	 (blocks (debug-function-debug-blocks debug-function)))
+    (declare (simple-vector blocks))
+    (dotimes (i (length blocks) nil)
+      (let* ((block (svref blocks i))
+	     (locations (debug-block-code-locations block)))
+	(declare (simple-vector locations))
+	(dotimes (j (length locations))
+	  (let ((loc (svref locations j)))
+	    (when (sub-code-location= debug-function code-location loc)
+	      (setf (code-location-%debug-block code-location) block)
+	      (setf (code-location-%tlf-offset code-location)
+		    (code-location-%tlf-offset loc))
+	      (setf (code-location-%form-number code-location)
+		    (code-location-%form-number loc))
+	      (setf (code-location-%live-set code-location)
+		    (code-location-%live-set loc))
+	      (setf (code-location-kind code-location)
+		    (code-location-kind loc))
+	      (return-from fill-in-code-location t))))))))
+
+
+
+;;;; Debug-blocks.
+
+;;; DO-DEBUG-BLOCK-LOCATIONS -- Public.
+;;;
+(defmacro do-debug-block-locations ((code-var debug-block &optional return)
+				    &body body)
+  "Executes forms in a context with code-var bound to each code-location in
+   debug-block.  This returns the value of executing result (defaults to nil)."
+  (let ((code-locations (gensym))
+	(i (gensym)))
+    `(let ((,code-locations (debug-block-code-locations ,debug-block)))
+       (declare (simple-vector ,code-locations))
+       (dotimes (,i (length ,code-locations) ,return)
+	 (let ((,code-var (svref ,code-locations ,i)))
+	   ,@body)))))
+
+;;; DEBUG-BLOCK-FUNCTION-NAME -- Internal.
+;;;
+(defun debug-block-function-name (debug-block)
+  "Returns the name of the function represented by debug-function.  This may
+   be a string or a cons; do not assume it is a symbol."
+  (let ((code-locs (debug-block-code-locations debug-block)))
+    (declare (simple-vector code-locs))
+    (when (zerop (length code-locs))
+      (error "No code-locations in debug-block? -- ~S." debug-block))
+    (debug-function-name (code-location-debug-function (svref code-locs 0)))))
+
+
+
+;;;; Variables.
+
+;;; DEBUG-VARIABLE-SYMBOL -- Public.
+;;;
+(defun debug-variable-symbol (debug-var)
+  "Returns the symbol from interning DEBUG-VARIABLE-NAME in the package named
+   by DEBUG-VARIABLE-PACKAGE."
+  (let ((package (debug-variable-package debug-var)))
+    (if package
+	(intern (debug-variable-name debug-var) package)
+	(make-symbol (debug-variable-name debug-var)))))
+
+;;; DEBUG-VARIABLE-VALID-VALUE -- Public.
+;;;
+(defun debug-variable-valid-value (debug-var frame)
+  "Returns the value stored for debug-variable in frame.  If the value is not
+   :valid, then this signals an invalid-value error."
+  (unless (eq (debug-variable-validity debug-var (frame-code-location frame))
+	      :valid)
+    (error 'invalid-value :debug-variable debug-var :frame frame))
+  (debug-variable-value debug-var frame))
+
+;;; DEBUG-VARIABLE-VALUE -- Public.
+;;;
+(defun debug-variable-value (debug-var frame)
+  "Returns the value stored for debug-variable in frame.  The value may be
+   invalid."
+  (let ((escaped (frame-escaped frame)))
+    (if escaped
+	(sub-debug-var-value (frame-pointer frame)
+			     (debug-variable-sc-offset debug-var)
+			     escaped)
+	(sub-debug-var-value (frame-pointer frame)
+			     (or (debug-variable-save-sc-offset debug-var)
+				 (debug-variable-sc-offset debug-var))))))
+
+(defun sub-debug-var-value (fp sc-offset &optional escaped)
+  (ecase (c::sc-offset-scn sc-offset)
+    ((0 1) ;; Any register or descriptor register.
+     (if escaped
+	 (stack-ref escaped (+ system:%escape-frame-general-register-start-slot
+			       (c::sc-offset-offset sc-offset)))
+	 :invalid-value-for-unescaped-register-storage))
+    (2 (error "Local non-descriptor register access?"))
+    (3 ;; String-char register (w/o tag bits)
+     (if escaped
+	 (code-char
+	  (stack-ref escaped (+ system:%escape-frame-general-register-start-slot
+				(c::sc-offset-offset sc-offset))))
+	 :invalid-value-for-unescaped-register-storage))
+    (4 ;; Descriptors on the stack.
+     (stack-ref fp (c::sc-offset-offset sc-offset)))
+    (5 ;; String-chars on the stack (w/o tag bits).
+     (code-char (stack-ref fp (c::sc-offset-offset sc-offset))))))
+
+(defun %set-debug-variable-value (debug-var frame value)
+  (let ((escaped (frame-escaped frame)))
+    (if escaped
+	(sub-%set-debug-var-value (frame-pointer frame)
+				  (debug-variable-sc-offset debug-var)
+				  value
+				  escaped)
+	(sub-%set-debug-var-value (frame-pointer frame)
+				  (or (debug-variable-save-sc-offset debug-var)
+				      (debug-variable-sc-offset debug-var))
+				  value))))
+;;;
+(defun sub-%set-debug-var-value (fp sc-offset value &optional escaped)
+  (ecase (c::sc-offset-scn sc-offset)
+    ((0 1) ;; Any register or descriptor register.
+     (if escaped
+	 (setf (stack-ref escaped
+			  (+ system:%escape-frame-general-register-start-slot
+			     (c::sc-offset-offset sc-offset)))
+	       value)
+	 value))
+    (2 (error "Local non-descriptor register access?"))
+    (3 ;; String-char register (w/o tag bits)
+     (if escaped
+	 (setf (stack-ref escaped
+			  (+ system:%escape-frame-general-register-start-slot
+			     (c::sc-offset-offset sc-offset)))
+	       (char-code value))
+	 value))
+    (4 ;; Descriptors on the stack.
+     (setf (stack-ref fp (c::sc-offset-offset sc-offset)) value))
+    (5 ;; String-chars on the stack (w/o tag bits).
+     (setf (stack-ref fp (c::sc-offset-offset sc-offset))
+	   (char-code value)))))
+;;;
+(defsetf debug-variable-value %set-debug-variable-value)
+
+
+;;; DEBUG-VARIABLE-VALIDITY -- Public.
+;;;
+;;; If the variable is always alive, then it is valid.  If the code-location is
+;;; unknown, then the variable's validity is :unknown.  Once we've called
+;;; CODE-LOCATION-UNKNOWN-P, we know the live-set information has been cached
+;;; in the code-location.
+;;;
+(defun debug-variable-validity (debug-var basic-code-loc)
+  "Returns three values reflecting the validity of debug-variable's value
+   at basic-code-location:
+      :valid    The value is known to be available.
+      :invalid  The value is known to be unavailable.
+      :unknown  The value's availability is unknown."
+  (cond ((debug-variable-alive-p debug-var)
+	 (let ((debug-fun (code-location-debug-function basic-code-loc)))
+	   (etypecase debug-fun
+	     (compiled-debug-function
+	      (if (>= (code-location-pc basic-code-loc)
+		      (c::compiled-debug-function-start-pc
+		       (compiled-debug-function-compiler-debug-fun debug-fun)))
+		  :valid
+		  :invalid))
+	     (interpreted-debug-function
+	      (error "Don't do interpreted debug-variable validity now.")))))
+	((code-location-unknown-p basic-code-loc) :unknown)
+	(t
+	 (let ((pos (position debug-var
+			      (debug-function-debug-variables
+			       (code-location-debug-function basic-code-loc)))))
+	   (unless pos
+	     (error 'unknown-debug-variable
+		    :debug-variable debug-var
+		    :debug-function
+		    (code-location-debug-function basic-code-loc)))
+	   ;; There must be live-set info since basic-code-loc is known.
+	   (if (zerop (sbit (code-location-live-set basic-code-loc) pos))
+	       :invalid
+	       :valid)))))
+
+
+
+;;;; Sources.
+
+;;; Written by Rob Maclachlan.
+;;; Documented by Bill Chiles.
+;;;
+;;; This code produces and uses what we call source-paths.  A source-path is a
+;;; list whose first element is a form number as returned by
+;;; CODE-LOCATION-FORM-NUMBER and whose last element is a top-level-form number
+;;; as returned by CODE-LOCATION-TOP-LEVEL-FORM-NUMBER.  The elements from the
+;;; last to the first, exclusively, are the numbered subforms into which to
+;;; descend.  For example:
+;;;    (defun foo (x)
+;;;      (let ((a (aref x 3)))
+;;;        (cons a 3)))
+;;; The call to AREF in this example is form number 5.  Assuming this DEFUN is
+;;; the 11'th top-level-form, the source-path for the AREF call is as follows:
+;;;    (5 1 0 1 3 11)
+;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 gets the
+;;; first binding, and 1 gets the AREF form.
+;;;
+
+
+;;; Temporary buffer used to build form-number => source-path translation in
+;;; FORM-NUMBER-TRANSLATIONS.
+;;;
+(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
+
+;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
+;;;
+(defvar *form-number-circularity-table* (make-hash-table :test #'eq))
+
+;;; FORM-NUMBER-TRANSLATIONS  --  Public.
+;;;
+;;; The vector elements are in the same format as the compiler's
+;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
+;;; is the top-level-form number.
+;;;
+(defun form-number-translations (form tlf-number)
+  "This returns a table mapping form numbers to source-paths.  A source-path
+   indicates a descent into the top-level-form form, going directly to the
+   subform corressponding to the form number."
+  (clrhash *form-number-circularity-table*)
+  (setf (fill-pointer *form-number-temp*) 0)
+  (sub-translate-form-numbers form (list tlf-number))
+  (coerce *form-number-temp* 'simple-vector))
+;;;
+(defun sub-translate-form-numbers (form path)
+  (unless (gethash form *form-number-circularity-table*)
+    (setf (gethash form *form-number-circularity-table*) t)
+    (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
+			*form-number-temp*)
+    (let ((pos 0)
+	  (subform form)
+	  (trail form))
+      (declare (fixnum pos))
+      (macrolet ((frob ()
+		   '(progn
+		      (when (atom subform) (return))
+		      (let ((fm (car subform)))
+			(when (consp fm)
+			  (sub-translate-form-numbers fm (cons pos path)))
+			(incf pos))
+		      (setq subform (cdr subform))
+		      (when (eq subform trail) (return)))))
+	(loop
+	  (frob)
+	  (frob)
+	  (setq trail (cdr trail)))))))
+
+
+;;; SOURCE-PATH-CONTEXT  --  Public.
+;;;
+(defun source-path-context (form path context)
+  "Form is a top-level form, and path is a source-path into it.  This returns
+   the form indicated by the source-path.  Context is the number of enclosing
+   forms to return instead of directly returning the source-path form.  When
+   context is non-zero, the form returned contains a marker, #:****HERE****,
+   immediately before the form indicated by path."
+  (declare (type unsigned-byte context))
+  ;;
+  ;; Get to the form indicated by path or the enclosing form indicated by
+  ;; context and path.
+  (let ((path (nreverse (butlast (cdr path)))))
+    (dotimes (i (- (length path) context))
+      (setq form (elt form (first path)))
+      (setq path (rest path)))
+    ;;
+    ;; Recursively rebuild the source form resulting from the above descent,
+    ;; copying the beginning of each subform up to the next subform we descend
+    ;; into according to path.  At the bottom of the recursion, we return the
+    ;; form indicated by path preceded by our marker, and this gets spliced
+    ;; into the resulting list structure on the way back up.
+    (labels ((frob (form path level)
+	       (if (or (zerop level) (null path))
+		   (if (zerop context)
+		       form
+		       `(#:***here*** ,form))
+		   (let* ((n (first path))
+			  (res (frob (elt form n) (rest path) (1- level))))
+		     (nconc (subseq form 0 n)
+			    (cons res (nthcdr (1+ n) form)))))))
+      (frob form path context))))
-- 
GitLab