/[slime]/slime/swank-allegro.lisp
ViewVC logotype

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Fri Jan 2 18:23:14 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-10
Changes since 1.4: +7 -11 lines
(format-condition-for-emacs): Replaced with debugger-condition-for-emacs.

(backtrace): Use print-with-frame-label.

(frame-locals): Rename the :symbol property to :name.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003, Helmut Eller
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10 ;;; $Id: swank-allegro.lisp,v 1.5 2004/01/02 18:23:14 heller Exp $
11 ;;;
12 ;;; This code was written for
13 ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
14 ;;;
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require :sock)
18 (require :process))
19
20 (in-package :swank)
21
22 (import
23 '(excl:fundamental-character-output-stream
24 excl:stream-write-char
25 excl:stream-force-output
26 excl:fundamental-character-input-stream
27 excl:stream-read-char
28 excl:stream-listen
29 excl:stream-unread-char
30 excl:stream-clear-input
31 excl:stream-line-column
32 ))
33
34 (defun without-interrupts* (body)
35 (excl:without-interrupts (funcall body)))
36
37 ;;; TCP Server
38
39 (setq *start-swank-in-background* nil)
40
41 (defun create-swank-server (port &key (reuse-address t)
42 (announce #'simple-announce-function)
43 (background *start-swank-in-background*)
44 (close *close-swank-socket-after-setup*))
45 "Create a Swank TCP server on `port'."
46 (let ((server-socket (socket:make-socket :connect :passive :local-port port
47 :reuse-address reuse-address)))
48 (funcall announce (socket:local-port server-socket))
49 (cond (background
50 (mp:process-run-function "Swank" #'accept-loop server-socket close))
51 (t
52 (accept-loop server-socket close)))))
53
54 (defun accept-loop (server-socket close)
55 (unwind-protect (cond (close (accept-one-client server-socket))
56 (t (loop (accept-one-client server-socket))))
57 (close server-socket)))
58
59 (defun accept-one-client (server-socket)
60 (request-loop (socket:accept-connection server-socket :wait t)))
61
62 (defun request-loop (stream)
63 (let* ((out (if *use-dedicated-output-stream*
64 (open-stream-to-emacs stream)
65 (make-instance 'slime-output-stream)))
66 (in (make-instance 'slime-input-stream))
67 (io (make-two-way-stream in out)))
68 (do () ((serve-one-request stream out in io)))))
69
70 (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
71 (catch 'slime-toplevel
72 (with-simple-restart (abort "Return to Slime toplevel.")
73 (handler-case (read-from-emacs)
74 (slime-read-error (e)
75 (when *swank-debug-p*
76 (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
77 (close *emacs-io*)
78 (return-from serve-one-request t)))))
79 nil)
80
81 (defun open-stream-to-emacs (*emacs-io*)
82 (let* ((listener (socket:make-socket :connect :passive :local-port 0
83 :reuse-address t))
84 (port (socket:local-port listener)))
85 (unwind-protect (progn
86 (eval-in-emacs `(slime-open-stream-to-lisp ,port))
87 (socket:accept-connection listener :wait t))
88 (close listener))))
89
90 (defmethod arglist-string (fname)
91 (declare (type string fname))
92 (multiple-value-bind (function condition)
93 (ignore-errors (values (from-string fname)))
94 (when condition
95 (return-from arglist-string (format nil "(-- ~A)" condition)))
96 (multiple-value-bind (arglist condition)
97 (ignore-errors (values (excl:arglist function)))
98 (cond (condition (format nil "(-- ~A)" condition))
99 (t (format nil "(~{~A~^ ~})" arglist))))))
100
101 (defslimefun getpid ()
102 (excl::getpid))
103
104 (defun apropos-symbols (string &optional external-only package)
105 (remove-if (lambda (sym)
106 (or (keywordp sym)
107 (and external-only
108 (not (equal (symbol-package sym) *buffer-package*))
109 (not (symbol-external-p sym)))))
110 (apropos-list string package external-only t)))
111
112 (defmethod describe-symbol-for-emacs (symbol)
113 (let ((result '()))
114 (flet ((doc (kind &optional (sym symbol))
115 (or (documentation sym kind) :not-documented))
116 (maybe-push (property value)
117 (when value
118 (setf result (list* property value result)))))
119 (maybe-push
120 :variable (when (boundp symbol)
121 (doc 'variable)))
122 (maybe-push
123 :function (if (fboundp symbol)
124 (doc 'function)))
125 (maybe-push
126 :class (if (find-class symbol nil)
127 (doc 'class)))
128 result)))
129
130 (defmethod macroexpand-all (form)
131 (excl::walk form))
132
133 (defvar *sldb-topframe*)
134 (defvar *sldb-source*)
135 (defvar *sldb-restarts*)
136
137 (defmethod call-with-debugging-environment (debugger-loop-fn)
138 (let ((*sldb-topframe* (excl::int-newest-frame))
139 (*debugger-hook* nil)
140 (excl::*break-hook* nil)
141 (*package* *buffer-package*)
142 (*sldb-restarts*
143 (compute-restarts *swank-debugger-condition*))
144 (*print-pretty* nil)
145 (*print-readably* nil)
146 (*print-level* 3)
147 (*print-length* 10))
148 (funcall debugger-loop-fn)))
149
150 (defun format-restarts-for-emacs ()
151 (loop for restart in *sldb-restarts*
152 collect (list (princ-to-string (restart-name restart))
153 (princ-to-string restart))))
154
155 (defun nth-frame (index)
156 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
157 (i index (1- i)))
158 ((zerop i) frame)))
159
160 (defun compute-backtrace (start end)
161 (let ((end (or end most-positive-fixnum)))
162 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
163 for i from start below end
164 while f
165 collect f)))
166
167 (defmethod backtrace (start-frame-number end-frame-number)
168 (flet ((format-frame (f i)
169 (print-with-frame-label
170 i (lambda (s) (debugger:output-frame s f :moderate)))))
171 (loop for i from start-frame-number
172 for f in (compute-backtrace start-frame-number end-frame-number)
173 collect (list i (format-frame f i)))))
174
175 (defmethod debugger-info-for-emacs (start end)
176 (list (debugger-condition-for-emacs)
177 (format-restarts-for-emacs)
178 (backtrace start end)))
179
180 (defun nth-restart (index)
181 (nth index *sldb-restarts*))
182
183 (defslimefun invoke-nth-restart (index)
184 (invoke-restart-interactively (nth-restart index)))
185
186 (defslimefun sldb-abort ()
187 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
188
189 (defmethod frame-locals (index)
190 (let ((frame (nth-frame index)))
191 (loop for i from 0 below (debugger:frame-number-vars frame)
192 collect (list :name (to-string (debugger:frame-var-name frame i))
193 :id 0
194 :value-string
195 (to-string (debugger:frame-var-value frame i))))))
196
197 (defmethod frame-catch-tags (index)
198 (declare (ignore index))
199 nil)
200
201 (defmethod frame-source-location-for-emacs (index)
202 (list :error (format nil "Cannot find source for frame: ~A"
203 (nth-frame index))))
204
205 (defvar *buffer-name* nil)
206 (defvar *buffer-start-position*)
207 (defvar *buffer-string*)
208 (defvar *compile-filename*)
209
210 (defun handle-compiler-warning (condition)
211 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
212 (signal (make-condition
213 'compiler-condition
214 :original-condition condition
215 :severity :warning
216 :message (format nil "~A" condition)
217 :location (cond (*buffer-name*
218 (make-location
219 (list :buffer *buffer-name*)
220 (list :position *buffer-start-position*)))
221 (loc
222 (destructuring-bind (file . pos) loc
223 (make-location
224 (list :file (namestring (truename file)))
225 (list :position (1+ pos)))))
226 (t
227 (make-location
228 (list :file *compile-filename*)
229 (list :position 1))))))))
230
231 (defmethod compile-file-for-emacs (*compile-filename* load-p)
232 (handler-bind ((warning #'handle-compiler-warning))
233 (let ((*buffer-name* nil))
234 (compile-file *compile-filename* :load-after-compile load-p))))
235
236 (defmethod compile-string-for-emacs (string &key buffer position)
237 (handler-bind ((warning #'handle-compiler-warning))
238 (let ((*package* *buffer-package*)
239 (*buffer-name* buffer)
240 (*buffer-start-position* position)
241 (*buffer-string* string))
242 (eval (from-string
243 (format nil "(funcall (compile nil '(lambda () ~A)))" string))))))
244
245 (defun fspec-source-locations (fspec)
246 (let ((defs (excl::find-multiple-definitions fspec)))
247 (let ((locations '()))
248 (loop for (fspec type) in defs do
249 (let ((file (excl::fspec-pathname fspec type)))
250 (etypecase file
251 (pathname
252 (let ((start (scm:find-definition-in-file fspec type file)))
253 (push (make-location
254 (list :file (namestring (truename file)))
255 (if start
256 (list :position (1+ start))
257 (list :function-name (string fspec))))
258 locations)))
259 ((member :top-level)
260 (push (list :error (format nil "Defined at toplevel: ~A"
261 fspec))
262 locations))
263 (null
264 (push (list :error (format nil
265 "Unkown source location for ~A"
266 fspec))
267 locations))
268 )))
269 locations)))
270
271 (defmethod find-function-locations (symbol-name)
272 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
273 (cond ((not foundp)
274 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
275 ((macro-function symbol)
276 (fspec-source-locations symbol))
277 ((special-operator-p symbol)
278 (list (list :error (format nil "~A is a special-operator" symbol))))
279 ((fboundp symbol)
280 (fspec-source-locations symbol))
281 (t (list (list :error
282 (format nil "Symbol not fbound: ~A" symbol-name))))
283 )))
284
285 (defun lookup-xrefs (finder name)
286 (xref-results-for-emacs (funcall finder (from-string name))))
287
288 (defslimefun who-calls (function-name)
289 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
290 function-name))
291
292 (defslimefun who-references (variable)
293 (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
294 variable))
295
296 (defslimefun who-binds (variable)
297 (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
298 variable))
299
300 (defslimefun who-sets (variable)
301 (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
302 variable))
303
304 (defslimefun list-callers (name)
305 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
306 name))
307
308 (defslimefun list-callees (name)
309 (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
310 name))
311
312 (defun xref-results-for-emacs (fspecs)
313 (let ((xrefs '()))
314 (dolist (fspec fspecs)
315 (dolist (location (fspec-source-locations fspec))
316 (push (cons (to-string fspec) location) xrefs)))
317 (group-xrefs xrefs)))
318

  ViewVC Help
Powered by ViewVC 1.1.5