forked from Shinmera/dissect
-
Notifications
You must be signed in to change notification settings - Fork 0
/
interface.lisp
154 lines (127 loc) · 4.87 KB
/
interface.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
#|
This file is a part of Dissect
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.tymoonnext.dissect)
(declaim (ftype (function () list) stack restarts)
(notinline stack restarts))
(defun stack ())
(defun restarts ())
(declaim (notinline stack-truncator))
(defun stack-truncator (function)
(funcall function))
(defmacro with-truncated-stack (() &body body)
`(stack-truncator (lambda () ,@body)))
(declaim (notinline stack-capper))
(defun stack-capper (function)
(funcall function))
(defmacro with-capped-stack (() &body body)
`(stack-capper (lambda () ,@body)))
(defun present (thing &optional (destination T))
(with-capped-stack ()
(etypecase destination
((eql T) (present thing *standard-output*))
((eql NIL) (with-output-to-string (stream)
(present thing stream)))
(stream (present-object thing destination)))))
(defgeneric present-object (thing stream))
(defmethod present-object ((condition condition) stream)
(format stream "~a" condition)
(format stream "~& [Condition of type ~s]" (type-of condition))
(format stream "~&~%")
(present-object T stream))
(defmethod present-object ((thing (eql T)) stream)
(present-object (capture-environment) stream))
(defmethod present-object ((list list) stream)
(when list
(etypecase (first list)
(restart (format stream "~&Available restarts:")
(loop for i from 0
for item in list
do (format stream "~& ~d: " i)
(present-object item stream)))
(call (format stream "~&Backtrace:")
(loop for item in list
do (format stream "~& ")
(present-object item stream))))))
(defclass restart ()
((name :initarg :name :reader name)
(report :initarg :report :reader report)
(restart :initarg :restart :reader restart)
(object :initarg :object :reader object)
(interactive :initarg :interactive :reader interactive)
(test :initarg :test :reader test)))
(defmethod print-object ((restart restart) stream)
(print-unreadable-object (restart stream :type T)
(format stream "[~s] ~s"
(name restart) (report restart))))
(defmethod present-object ((restart restart) stream)
(format stream "[~a] ~a" (name restart) (report restart)))
(defgeneric invoke (restart &rest args))
(defmethod invoke ((restart restart) &rest args)
(if (restart restart)
(apply (restart restart) args)
(apply #'invoke-restart (name restart) args)))
(defclass unknown-arguments ()
())
(defmethod print-object ((args unknown-arguments) stream)
(format stream "#<Unknown Arguments>"))
(defclass unavailable-argument ()
())
(defmethod print-object ((arg unavailable-argument) stream)
(format stream "#<Unavailable>"))
(defclass call ()
((pos :initarg :pos :reader pos)
(call :initarg :call :reader call)
(args :initarg :args :reader args)
(file :initarg :file :reader file)
(line :initarg :line :reader line)
(form :initarg :form :reader form)))
(defmethod print-object ((call call) stream)
(print-unreadable-object (call stream :type T)
(format stream "[~a] ~a~@[ | ~a~@[:~a~]~]"
(pos call) (call call) (file call) (line call))))
(defmethod present-object ((call call) stream)
(let ((*print-pretty* NIL)
(*print-readably* NIL)
(args (args call)))
(format stream "~d: ~:[(~s ~s)~;(~s~{ ~a~})~]"
(pos call)
;; If args is a list then they will be listed
;; separated by spaces.
(listp args)
(call call)
(if (listp args)
(loop for arg in args
collect (or (ignore-errors (princ-to-string arg))
"<error printing arg>"))
args))))
(defclass environment ()
((condition :initarg :condition :reader environment-condition)
(stack :initarg :stack :reader environment-stack)
(restarts :initarg :restarts :reader environment-restarts)
(thread :initarg :thread :reader environment-thread))
(:default-initargs
:condition NIL
:stack (stack)
:restarts (restarts)
:thread (current-thread)))
(declaim (inline capture-environment))
(defun capture-environment (&optional condition)
(with-capped-stack ()
(make-instance 'environment :condition condition)))
(defmethod present-object ((env environment) stream)
(with-slots ((condition condition) (stack stack) (restarts restarts) (thread thread)) env
(format stream "~a" env)
(format stream "~& [Environment~@[ of thread ~a~]]" thread)
(when condition
(format stream "~&~%")
(format stream "~a" condition)
(format stream "~& [Condition of type ~s]" (type-of condition)))
(when restarts
(format stream "~&~%")
(present-object restarts stream))
(when stack
(format stream "~&~%")
(present-object stack stream))))