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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sun Dec 14 07:58:12 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.3: +69 -44 lines
(create-swank-server): Add support for BACKGROUND and CLOSE argument.

(call-with-debugging-environment): Use excl::int-newest-frame to avoid
the kludge with *break-hook*.

(sldb-abort): Add Allegro support.
(frame-source-location-for-emacs): Add dummy definition.

(compile-file-for-emacs): The argument is called :load-after-compile
and not :load.

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

  ViewVC Help
Powered by ViewVC 1.1.5