Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
4b2ff8cd
Commit
4b2ff8cd
authored
33 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Added rudiments of *current-code-location* support. Added ``DESCRIBE''
debugger command.
parent
f4d1e1ff
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/debug.lisp
+58
-26
58 additions, 26 deletions
code/debug.lisp
with
58 additions
and
26 deletions
code/debug.lisp
+
58
−
26
View file @
4b2ff8cd
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.2
6
1992/0
2
/1
4 23:44:34
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.2
7
1992/0
3
/1
0 15:21:11
wlott Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -52,6 +52,7 @@
...
@@ -52,6 +52,7 @@
(
defvar
*in-the-debugger*
nil
(
defvar
*in-the-debugger*
nil
"If this is bound before the debugger is invoked, it is used as the stack
"If this is bound before the debugger is invoked, it is used as the stack
top by the debugger."
)
(
defvar
*stack-top*
nil
)
(
defvar
*stack-top*
nil
)
;;;; Breakpoint state:
;;;; Breakpoint state:
...
@@ -323,8 +324,9 @@
...
@@ -323,8 +324,9 @@
(
setf
max-name-len
len
))))))
(
setf
max-name-len
len
))))))
(
unless
(
zerop
max-name-len
)
(
unless
(
zerop
max-name-len
)
(
incf
max-name-len
3
))
(
incf
max-name-len
3
))
(let ((*debug-command-level* (1+ *debug-command-level*))
(
dolist
(
restart
restarts
)
(*current-frame* (di:top-frame)))
(
*current-frame*
(
di:top-frame
))
(
format
s
"~& ~2D: [~VA] ~A~%"
count
(
-
max-name-len
3
)
name
restart
)
count
(
-
max-name-len
3
)
name
restart
)
(
push
name
names-used
))))
(
push
name
names-used
))))
(
incf
count
)
))))
(
incf
count
)
))))
...
@@ -632,35 +634,47 @@
...
@@ -632,35 +634,47 @@
;; Return the right value.
;; Return the right value.
(
cond
((
not
res
)
nil
)
(
cond
((
not
res
)
nil
)
((
=
(
length
res
)
1
)
((
=
(
length
res
)
1
)
(if next
(
cdar
res
))
(print-frame-call (setf *current-frame* next))
(
t
;Just return the names.
(format t "
~&Top
of
stack.
"))))
(
do
((
cmds
res
(
cdr
cmds
)))
((
not
cmds
)
res
)
(
setf
(
car
cmds
)
(
caar
cmds
))))))))
;;;
;;;
;;; Returns a list of debug commands (in the same format as *debug-commands*)
;;; Returns a list of debug commands (in the same format as *debug-commands*)
(if next
;;; that invoke each active restart.
(print-frame-call (setf *current-frame* next))
;;;
(format t "
~&Bottom
of
stack.
"))))
;;; Two commands are made for each restart: one for the number, and one for
;;; the restart name (unless it's been shadowed by an earlier restart of the
;;; same name.
;;;
(
defun
make-restart-commands
(
&optional
(
restarts
*debug-restarts*
))
(
defun
make-restart-commands
(
&optional
(
restarts
*debug-restarts*
))
(
let
((
commands
)
(
num
0
))
; better be the same as show-restarts!
(
dolist
(
restart
restarts
)
(
dolist
(
restart
restarts
)
(print-frame-call
(
let
((
name
(
string
(
restart-name
restart
))))
(setf *current-frame*
(
unless
(
find
name
commands
:key
#'
car
:test
#'
string=
)
(do ((prev *current-frame* lead)
(
let
((
restart-fun
(lead (di:frame-up *current-frame*) (di:frame-up lead)))
#'
(
lambda
()
((null lead) prev)))))
(
invoke-restart-interactively
restart
))))
(
push
(
cons
name
restart-fun
)
commands
)
(
push
(
cons
(
format
nil
"~d"
num
)
restart-fun
)
commands
))))
(
push
(
cons
(
format
nil
"~d"
num
)
restart-fun
)
commands
))))
(
incf
num
))
(
incf
num
))
(print-frame-call
commands
))
(setf *current-frame*
(do ((prev *current-frame* lead)
(lead (di:frame-down *current-frame*) (di:frame-down lead)))
;;;
((null lead) prev)))))
;;; Frame changing commands.
;;;
(
def-debug-command
"UP"
()
(
let
((
next
(
di:frame-up
*current-frame*
)))
(
let
((
next
(
di:frame-up
*current-frame*
)))
(
cond
(
next
(
cond
(
next
(
setf
*current-frame*
next
)
(
setf
*current-frame*
next
)
(
print-frame-call
next
))
(
print-frame-call
next
))
(
t
(
t
(
format
t
"~&Top of stack."
)))))
(
def-debug-command
"DOWN"
()
(
def-debug-command
"DOWN"
()
(
let
((
next
(
di:frame-down
*current-frame*
)))
(
let
((
next
(
di:frame-down
*current-frame*
)))
...
@@ -809,16 +823,22 @@
...
@@ -809,16 +823,22 @@
(
def-debug-command-alias
"PP"
"VPRINT"
)
(
def-debug-command-alias
"PP"
"VPRINT"
)
(print-frame-source-form *current-frame* (read-if-available 0)))
(
def-debug-command
"LIST-LOCALS"
()
(
let
((
d-fun
(
di:frame-debug-function
*current-frame*
)))
(
if
(
di:debug-variable-info-available
d-fun
)
(
let
((
*print-level*
(
or
*debug-print-level*
*print-level*
))
(
*print-length*
(
or
*debug-print-length*
*print-level*
))
(
*print-length*
(
or
*debug-print-length*
*print-level*
))
(
*standard-output*
*debug-io*
)
(
*standard-output*
*debug-io*
)
(print-frame-source-form *current-frame* (read-if-available 0) t))
(
location
(
di:frame-code-location
*current-frame*
))
(
prefix
(
read-if-available
nil
))
(
any-p
nil
)
(
any-valid-p
nil
))
(
dolist
(
v
(
di:ambiguous-debug-variables
d-fun
d-fun
(
if
prefix
(
string
prefix
)
""
)))
;;; PRINT-FRAME-SOURCE-FORM -- Internal.
(
setf
any-p
t
)
(
setf
any-p
t
)
(defun print-frame-source-form (frame context &optional verbose
)
(
when
(
eq
(
di:debug-variable-validity
v
location
)
:valid
)
(
l
et
* ((location (maybe-block-start-location (di:frame-code-location frame))
)
(
s
et
f
any-valid-p
t
)
(
format
t
"~A~:[#~D~;~*~] = ~S~%"
(
format
t
"~A~:[#~D~;~*~] = ~S~%"
(
di:debug-variable-name
v
)
(
di:debug-variable-name
v
)
(
zerop
(
di:debug-variable-id
v
))
(
zerop
(
di:debug-variable-id
v
))
...
@@ -907,6 +927,17 @@
...
@@ -907,6 +927,17 @@
(
setf
break
(
di:preprocess-for-eval
break
code-loc
))
(
setf
break
(
di:preprocess-for-eval
break
code-loc
))
(
setf
condition
(
di:preprocess-for-eval
condition
code-loc
))
(
setf
condition
(
di:preprocess-for-eval
condition
code-loc
))
(
dolist
(
form
print
)
(
dolist
(
form
print
)
(
push
(
cons
(
di:preprocess-for-eval
form
code-loc
)
form
)
print-functions
))))
(
setup-function-end
()
(
setf
bp
(
di:make-breakpoint
#'
main-hook-function
place
:kind
:function-end
))
(
setf
break
(
coerce
`
(
lambda
(
dummy
)
(
declare
(
ignore
dummy
))
,
break
)
'function
))
(
setf
condition
(
coerce
`
(
lambda
(
dummy
)
(
declare
(
ignore
dummy
))
,
condition
)
(
declare
(
ignore
dummy
))
,
condition
)
'function
))
'function
))
(
dolist
(
form
print
)
(
dolist
(
form
print
)
...
@@ -917,7 +948,8 @@
...
@@ -917,7 +948,8 @@
print-functions
)))
print-functions
)))
(
setup-code-location
()
(
setup-code-location
()
(
setf
place
(
nth
index
*possible-breakpoints*
))
(
setf
place
(
nth
index
*possible-breakpoints*
))
(
di:frame-code-location
*current-frame*
))
)
(
setf
bp
(
di:make-breakpoint
#'
main-hook-function
place
:kind
:code-location
))
(
dolist
(
form
print
)
(
dolist
(
form
print
)
(
push
(
cons
(
push
(
cons
(
di:preprocess-for-eval
form
place
)
(
di:preprocess-for-eval
form
place
)
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment