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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Thu Jan 22 00:37:35 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
CVS Tags: STATELESS-EMACS
Branch point for: stateless-emacs
Changes since 1.10: +12 -1 lines
(return-from-frame, restart-name): Implement interface (partly).
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
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.11 2004/01/22 00:37:35 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 excl:stream-read-char-no-hang
33 ))
34
35 ;;;; TCP Server
36
37 (defimplementation create-socket (port)
38 (socket:make-socket :connect :passive :local-port port :reuse-address t))
39
40 (defimplementation local-port (socket)
41 (socket:local-port socket))
42
43 (defimplementation close-socket (socket)
44 (close socket))
45
46 (defimplementation accept-connection (socket)
47 (socket:accept-connection socket :wait t))
48
49 (defimplementation emacs-connected ())
50
51 ;;;; Unix signals
52
53 (defimplementation call-without-interrupts (fn)
54 (excl:without-interrupts (funcall fn)))
55
56 (defimplementation getpid ()
57 (excl::getpid))
58
59 ;;;; Misc
60
61 (defimplementation arglist-string (fname)
62 (format-arglist fname #'excl:arglist))
63
64 (defun apropos-symbols (string &optional external-only package)
65 (remove-if (lambda (sym)
66 (or (keywordp sym)
67 (and external-only
68 (not (equal (symbol-package sym) *buffer-package*))
69 (not (symbol-external-p sym)))))
70 (apropos-list string package external-only t)))
71
72 (defimplementation describe-symbol-for-emacs (symbol)
73 (let ((result '()))
74 (flet ((doc (kind &optional (sym symbol))
75 (or (documentation sym kind) :not-documented))
76 (maybe-push (property value)
77 (when value
78 (setf result (list* property value result)))))
79 (maybe-push
80 :variable (when (boundp symbol)
81 (doc 'variable)))
82 (maybe-push
83 :function (if (fboundp symbol)
84 (doc 'function)))
85 (maybe-push
86 :class (if (find-class symbol nil)
87 (doc 'class)))
88 result)))
89
90 (defimplementation macroexpand-all (form)
91 (excl::walk form))
92
93 (defimplementation describe-definition (symbol-name type)
94 (let ((symbol (from-string symbol-name)))
95 (ecase type
96 (:variable (print-description-to-string symbol))
97 ((:function :generic-function)
98 (print-description-to-string (symbol-function symbol)))
99 (:class
100 (print-description-to-string (find-class symbol))))))
101
102 ;;;; Debugger
103
104 (defvar *sldb-topframe*)
105 (defvar *sldb-source*)
106 (defvar *sldb-restarts*)
107
108 (defimplementation call-with-debugging-environment (debugger-loop-fn)
109 (let ((*sldb-topframe* (excl::int-newest-frame))
110 (*debugger-hook* nil)
111 (excl::*break-hook* nil)
112 (*package* *buffer-package*)
113 (*sldb-restarts*
114 (compute-restarts *swank-debugger-condition*))
115 (*print-pretty* nil)
116 (*print-readably* nil)
117 (*print-level* 3)
118 (*print-length* 10))
119 (funcall debugger-loop-fn)))
120
121 (defun format-restarts-for-emacs ()
122 (loop for restart in *sldb-restarts*
123 collect (list (princ-to-string (restart-name restart))
124 (princ-to-string restart))))
125
126 (defun nth-frame (index)
127 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
128 (i index (1- i)))
129 ((zerop i) frame)))
130
131 (defun compute-backtrace (start end)
132 (let ((end (or end most-positive-fixnum)))
133 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
134 for i from start below end
135 while f
136 collect f)))
137
138 (defimplementation backtrace (start-frame-number end-frame-number)
139 (flet ((format-frame (f i)
140 (print-with-frame-label
141 i (lambda (s) (debugger:output-frame s f :moderate)))))
142 (loop for i from start-frame-number
143 for f in (compute-backtrace start-frame-number end-frame-number)
144 collect (list i (format-frame f i)))))
145
146 (defimplementation debugger-info-for-emacs (start end)
147 (list (debugger-condition-for-emacs)
148 (format-restarts-for-emacs)
149 (backtrace start end)))
150
151 (defun nth-restart (index)
152 (nth index *sldb-restarts*))
153
154 (defslimefun invoke-nth-restart (index)
155 (invoke-restart-interactively (nth-restart index)))
156
157 (defslimefun sldb-abort ()
158 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
159
160 (defimplementation frame-locals (index)
161 (let ((frame (nth-frame index)))
162 (loop for i from 0 below (debugger:frame-number-vars frame)
163 collect (list :name (to-string (debugger:frame-var-name frame i))
164 :id 0
165 :value-string
166 (to-string (debugger:frame-var-value frame i))))))
167
168 (defimplementation frame-catch-tags (index)
169 (declare (ignore index))
170 nil)
171
172 (defimplementation frame-source-location-for-emacs (index)
173 (list :error (format nil "Cannot find source for frame: ~A"
174 (nth-frame index))))
175
176 (defimplementation eval-in-frame (form frame-number)
177 (debugger:eval-form-in-context
178 form
179 (debugger:environment-of-frame (nth-frame frame-number))))
180
181 (defimplementation return-from-frame (frame-number form)
182 (let ((frame (nth-frame frame-number)))
183 (multiple-value-call #'debugger:frame-return
184 frame (debugger:eval-form-in-context
185 (from-string form) (debugger:environment-of-frame frame)))))
186
187 ;;; XXX doens't work for frames with arguments
188 (defimplementation restart-frame (frame-number)
189 (let ((frame (nth-frame frame-number)))
190 (debugger:frame-retry frame (debugger:frame-function frame))))
191
192 ;;;; Compiler hooks
193
194 (defvar *buffer-name* nil)
195 (defvar *buffer-start-position*)
196 (defvar *buffer-string*)
197 (defvar *compile-filename*)
198
199 (defun handle-compiler-warning (condition)
200 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
201 (signal (make-condition
202 'compiler-condition
203 :original-condition condition
204 :severity :warning
205 :message (format nil "~A" condition)
206 :location (cond (*buffer-name*
207 (make-location
208 (list :buffer *buffer-name*)
209 (list :position *buffer-start-position*)))
210 (loc
211 (destructuring-bind (file . pos) loc
212 (make-location
213 (list :file (namestring (truename file)))
214 (list :position (1+ pos)))))
215 (t
216 (make-location
217 (list :file *compile-filename*)
218 (list :position 1))))))))
219
220 (defimplementation compile-file-for-emacs (*compile-filename* load-p)
221 (handler-bind ((warning #'handle-compiler-warning))
222 (let ((*buffer-name* nil))
223 (compile-file *compile-filename* :load-after-compile load-p))))
224
225 (defimplementation compile-string-for-emacs (string &key buffer position)
226 (handler-bind ((warning #'handle-compiler-warning))
227 (let ((*package* *buffer-package*)
228 (*buffer-name* buffer)
229 (*buffer-start-position* position)
230 (*buffer-string* string))
231 (eval (from-string
232 (format nil "(funcall (compile nil '(lambda () ~A)))" string))))))
233
234 ;;;; Definition Finding
235
236 (defun fspec-source-locations (fspec)
237 (let ((defs (excl::find-multiple-definitions fspec)))
238 (let ((locations '()))
239 (loop for (fspec type) in defs do
240 (let ((file (excl::fspec-pathname fspec type)))
241 (etypecase file
242 (pathname
243 (let ((start (scm:find-definition-in-file fspec type file)))
244 (push (make-location
245 (list :file (namestring (truename file)))
246 (if start
247 (list :position (1+ start))
248 (list :function-name (string fspec))))
249 locations)))
250 ((member :top-level)
251 (push (list :error (format nil "Defined at toplevel: ~A"
252 fspec))
253 locations))
254 (null
255 (push (list :error (format nil
256 "Unkown source location for ~A"
257 fspec))
258 locations))
259 )))
260 locations)))
261
262 (defimplementation find-function-locations (symbol-name)
263 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
264 (cond ((not foundp)
265 (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
266 ((macro-function symbol)
267 (fspec-source-locations symbol))
268 ((special-operator-p symbol)
269 (list (list :error (format nil "~A is a special-operator" symbol))))
270 ((fboundp symbol)
271 (fspec-source-locations symbol))
272 (t (list (list :error
273 (format nil "Symbol not fbound: ~A" symbol-name))))
274 )))
275
276 ;;;; XREF
277
278 (defun lookup-xrefs (finder name)
279 (xref-results-for-emacs (funcall finder (from-string name))))
280
281 (defimplementation who-calls (function-name)
282 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
283 function-name))
284
285 (defimplementation who-references (variable)
286 (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
287 variable))
288
289 (defimplementation who-binds (variable)
290 (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
291 variable))
292
293 (defimplementation who-macroexpands (variable)
294 (lookup-xrefs (lambda (x) (xref:get-relation :macro-calls :wild x))
295 variable))
296
297 (defimplementation who-sets (variable)
298 (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
299 variable))
300
301 (defimplementation list-callers (name)
302 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
303 name))
304
305 (defimplementation list-callees (name)
306 (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
307 name))
308
309 (defun xref-results-for-emacs (fspecs)
310 (let ((xrefs '()))
311 (dolist (fspec fspecs)
312 (dolist (location (fspec-source-locations fspec))
313 (push (cons (to-string fspec) location) xrefs)))
314 (group-xrefs xrefs)))
315
316 ;;;; Multiprocessing
317
318 (defimplementation startup-multiprocessing ()
319 (mp:start-scheduler))
320
321 (defimplementation spawn (fn &key name)
322 (mp:process-run-function name fn))
323
324 ;; XXX: shurtcut
325 (defimplementation thread-id ()
326 (mp:process-name mp:*current-process*))
327
328 (defimplementation thread-name (thread-id)
329 thread-id)
330
331 (defimplementation make-lock (&key name)
332 (mp:make-process-lock :name name))
333
334 (defimplementation call-with-lock-held (lock function)
335 (mp:with-process-lock (lock) (funcall function)))

  ViewVC Help
Powered by ViewVC 1.1.5