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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Wed Mar 10 08:24:45 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.22: +0 -1 lines
(find-definitions): Some tweaking.
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. This code was written for "Allegro CL Trial
9 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10 ;;;
11
12 (in-package :swank-backend)
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :sock)
16 (require :process))
17
18 (import
19 '(excl:fundamental-character-output-stream
20 excl:stream-write-char
21 excl:stream-force-output
22 excl:fundamental-character-input-stream
23 excl:stream-read-char
24 excl:stream-listen
25 excl:stream-unread-char
26 excl:stream-clear-input
27 excl:stream-line-column
28 excl:stream-read-char-no-hang
29 ))
30
31 ;;;; TCP Server
32
33
34 (defimplementation preferred-communication-style ()
35 :spawn)
36
37 (defimplementation create-socket (host port)
38 (socket:make-socket :connect :passive :local-port port
39 :local-host host :reuse-address t))
40
41 (defimplementation local-port (socket)
42 (socket:local-port socket))
43
44 (defimplementation close-socket (socket)
45 (close socket))
46
47 (defimplementation accept-connection (socket)
48 (socket:accept-connection socket :wait t))
49
50 (defimplementation emacs-connected ())
51
52 ;;;; Unix signals
53
54 (defimplementation call-without-interrupts (fn)
55 (excl:without-interrupts (funcall fn)))
56
57 (defimplementation getpid ()
58 (excl::getpid))
59
60 (defimplementation lisp-implementation-type-name ()
61 "allegro")
62
63 ;;;; Misc
64
65 (defimplementation arglist (symbol)
66 (excl:arglist symbol))
67
68 (defimplementation macroexpand-all (form)
69 (excl::walk form))
70
71 (defimplementation describe-symbol-for-emacs (symbol)
72 (let ((result '()))
73 (flet ((doc (kind &optional (sym symbol))
74 (or (documentation sym kind) :not-documented))
75 (maybe-push (property value)
76 (when value
77 (setf result (list* property value result)))))
78 (maybe-push
79 :variable (when (boundp symbol)
80 (doc 'variable)))
81 (maybe-push
82 :function (if (fboundp symbol)
83 (doc 'function)))
84 (maybe-push
85 :class (if (find-class symbol nil)
86 (doc 'class)))
87 result)))
88
89
90 (defimplementation describe-definition (symbol namespace)
91 (ecase namespace
92 (:variable
93 (describe symbol))
94 ((:function :generic-function)
95 (describe (symbol-function symbol)))
96 (:class
97 (describe (find-class symbol)))))
98
99 (defimplementation describe-definition (symbol namespace)
100 (ecase namespace
101 (:variable
102 (describe symbol))
103 ((:function :generic-function)
104 (describe (symbol-function symbol)))
105 (:class
106 (describe (find-class symbol)))))
107
108 ;;;; Debugger
109
110 (defvar *sldb-topframe*)
111
112 (defimplementation call-with-debugging-environment (debugger-loop-fn)
113 (let ((*sldb-topframe* (excl::int-newest-frame))
114 (excl::*break-hook* nil))
115 (funcall debugger-loop-fn)))
116
117 (defun nth-frame (index)
118 (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
119 (i index (1- i)))
120 ((zerop i) frame)))
121
122 (defimplementation compute-backtrace (start end)
123 (let ((end (or end most-positive-fixnum)))
124 (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
125 for i from start below end
126 while f
127 collect f)))
128
129 (defimplementation print-frame (frame stream)
130 (debugger:output-frame stream frame :moderate))
131
132 (defimplementation frame-locals (index)
133 (let ((frame (nth-frame index)))
134 (loop for i from 0 below (debugger:frame-number-vars frame)
135 collect (list :name (debugger:frame-var-name frame i)
136 :id 0
137 :value (debugger:frame-var-value frame i)))))
138
139 (defimplementation frame-catch-tags (index)
140 (declare (ignore index))
141 nil)
142
143 (defimplementation disassemble-frame (index)
144 (disassemble (debugger:frame-function (nth-frame index))))
145
146 (defimplementation frame-source-location-for-emacs (index)
147 (list :error (format nil "Cannot find source for frame: ~A"
148 (nth-frame index))))
149
150 (defimplementation eval-in-frame (form frame-number)
151 (debugger:eval-form-in-context
152 form
153 (debugger:environment-of-frame (nth-frame frame-number))))
154
155 (defimplementation return-from-frame (frame-number form)
156 (let ((frame (nth-frame frame-number)))
157 (multiple-value-call #'debugger:frame-return
158 frame (debugger:eval-form-in-context
159 form
160 (debugger:environment-of-frame frame)))))
161
162 ;;; XXX doesn't work for frames with arguments
163 (defimplementation restart-frame (frame-number)
164 (let ((frame (nth-frame frame-number)))
165 (debugger:frame-retry frame (debugger:frame-function frame))))
166
167 ;;;; Compiler hooks
168
169 (defvar *buffer-name* nil)
170 (defvar *buffer-start-position*)
171 (defvar *buffer-string*)
172 (defvar *compile-filename*)
173
174 (defun handle-compiler-warning (condition)
175 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
176 (signal (make-condition
177 'compiler-condition
178 :original-condition condition
179 :severity :warning
180 :message (format nil "~A" condition)
181 :location (cond (*buffer-name*
182 (make-location
183 (list :buffer *buffer-name*)
184 (list :position *buffer-start-position*)))
185 (loc
186 (destructuring-bind (file . pos) loc
187 (make-location
188 (list :file (namestring (truename file)))
189 (list :position (1+ pos)))))
190 (t
191 (make-location
192 (list :file *compile-filename*)
193 (list :position 1))))))))
194
195 (defimplementation swank-compile-file (*compile-filename* load-p)
196 (handler-bind ((warning #'handle-compiler-warning))
197 (let ((*buffer-name* nil))
198 (compile-file *compile-filename* :load-after-compile load-p))))
199
200 (defimplementation swank-compile-string (string &key buffer position)
201 (handler-bind ((warning #'handle-compiler-warning))
202 (let ((*buffer-name* buffer)
203 (*buffer-start-position* position)
204 (*buffer-string* string))
205 (funcall (compile nil (read-from-string
206 (format nil "(CL:LAMBDA () ~A)" string)))))))
207
208 ;;;; Definition Finding
209
210 (defun find-fspec-location (fspec type)
211 (let ((file (excl::fspec-pathname fspec type)))
212 (etypecase file
213 (pathname
214 (let ((start (scm:find-definition-in-file fspec type file)))
215 (make-location (list :file (namestring (truename file)))
216 (if start
217 (list :position (1+ start))
218 (list :function-name (string fspec))))))
219 ((member :top-level)
220 (list :error (format nil "Defined at toplevel: ~A" fspec)))
221 (null
222 (list :error (format nil "Unkown source location for ~A" fspec))))))
223
224 (defun fspec-definition-locations (fspec)
225 (let ((defs (excl::find-multiple-definitions fspec)))
226 (loop for (fspec type) in defs
227 collect (list fspec (find-fspec-location fspec type)))))
228
229 (defimplementation find-definitions (symbol)
230 (fspec-definition-locations symbol))
231
232 ;;;; XREF
233
234 (defmacro defxref (name relation name1 name2)
235 `(defimplementation ,name (x)
236 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
237
238 (defxref who-calls :calls :wild x)
239 (defxref who-references :uses :wild x)
240 (defxref who-binds :binds :wild x)
241 (defxref who-macroexpands :macro-calls :wild x)
242 (defxref who-sets :sets :wild x)
243 (defxref list-callees :calls x :wild)
244
245 (defun xref-result (fspecs)
246 (loop for fspec in fspecs
247 append (fspec-definition-locations fspec)))
248
249 ;;;; Inspecting
250
251 (defmethod inspected-parts (o)
252 (let* ((class (class-of o))
253 (slots (clos:class-slots class)))
254 (values (format nil "~A~% is a ~A" o class)
255 (mapcar (lambda (slot)
256 (let ((name (clos:slot-definition-name slot)))
257 (cons (princ-to-string name)
258 (slot-value o name))))
259 slots))))
260
261 ;;;; Multithreading
262
263 (defimplementation startup-multiprocessing ()
264 (mp:start-scheduler))
265
266 (defimplementation spawn (fn &key name)
267 (mp:process-run-function name fn))
268
269 (defimplementation thread-name (thread)
270 (mp:process-name thread))
271
272 (defimplementation thread-status (thread)
273 (format nil "~A ~D" (mp:process-whostate thread)
274 (mp:process-priority thread)))
275
276 (defimplementation make-lock (&key name)
277 (mp:make-process-lock :name name))
278
279 (defimplementation call-with-lock-held (lock function)
280 (mp:with-process-lock (lock) (funcall function)))
281
282 (defimplementation current-thread ()
283 mp:*current-process*)
284
285 (defimplementation all-threads ()
286 (copy-list mp:*all-processes*))
287
288 (defimplementation interrupt-thread (thread fn)
289 (mp:process-interrupt thread fn))
290
291 (defimplementation kill-thread (thread)
292 (mp:process-kill thread))
293
294 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
295
296 (defstruct (mailbox (:conc-name mailbox.))
297 (mutex (mp:make-process-lock :name "process mailbox"))
298 (queue '() :type list))
299
300 (defun mailbox (thread)
301 "Return THREAD's mailbox."
302 (mp:with-process-lock (*mailbox-lock*)
303 (or (getf (mp:process-property-list thread) 'mailbox)
304 (setf (getf (mp:process-property-list thread) 'mailbox)
305 (make-mailbox)))))
306
307 (defimplementation send (thread message)
308 (let* ((mbox (mailbox thread))
309 (mutex (mailbox.mutex mbox)))
310 (mp:with-process-lock (mutex)
311 (setf (mailbox.queue mbox)
312 (nconc (mailbox.queue mbox) (list message))))))
313
314 (defimplementation receive ()
315 (let* ((mbox (mailbox mp:*current-process*))
316 (mutex (mailbox.mutex mbox)))
317 (mp:process-wait "receive" #'mailbox.queue mbox)
318 (mp:with-process-lock (mutex)
319 (pop (mailbox.queue mbox)))))

  ViewVC Help
Powered by ViewVC 1.1.5