Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 731 lines (613 sloc) 26.695 kb
fab0b31 Add multiprocessing support.
Helmut Eller authored
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
f912c9c New file.
Helmut Eller authored
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
5 ;;; Created 2003
f912c9c New file.
Helmut Eller authored
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
8 ;;; are disclaimed. This code was written for "Allegro CL Trial
9 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
f912c9c New file.
Helmut Eller authored
10 ;;;
11
8052a9e Minor modifications.
Helmut Eller authored
12 (in-package :swank-backend)
13
f912c9c New file.
Helmut Eller authored
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :sock)
aa65d6e Implemented.
Luke Gorrie authored
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)))
f912c9c New file.
Helmut Eller authored
29
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
30 ;;; swank-mop
31
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
32 ;; maybe better change MOP to ACLMOP ?
33 ;; CLOS also works in ACL5. --he
34 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
ff1fa86 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
35
36 (defun swank-mop:slot-definition-documentation (slot)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
37 (documentation slot t))
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
38
fab0b31 Add multiprocessing support.
Helmut Eller authored
39 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
40
8052a9e Minor modifications.
Helmut Eller authored
41 (defimplementation preferred-communication-style ()
42 :spawn)
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
43
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
44 (defimplementation create-socket (host port)
45 (socket:make-socket :connect :passive :local-port port
46 :local-host host :reuse-address t))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-em…
Helmut Eller authored
47
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
48 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
49 (socket:local-port socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
50
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
51 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
52 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
53
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
54 (defimplementation accept-connection (socket &key external-format)
55 (let ((ef (or external-format :iso-latin-1-unix))
56 (s (socket:accept-connection socket :wait t)))
57 (set-external-format s ef)
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
58 s))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
59
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
60 (defun set-external-format (stream external-format)
61 #-allegro-v5.0
62 (let* ((name (ecase external-format
63 (:iso-latin-1-unix :latin1)
64 (:utf-8-unix :utf-8-unix)
65 (:emacs-mule-unix :emacs-mule)))
66 (ef (excl:crlf-base-ef
67 (excl:find-external-format name :try-variant t))))
68 (setf (stream-external-format stream) ef)))
69
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
70 (defimplementation format-sldb-condition (c)
71 (princ-to-string c))
72
73 (defimplementation condition-references (c)
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
74 (declare (ignore c))
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
75 '())
76
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
77 (defimplementation call-with-syntax-hooks (fn)
78 (funcall fn))
79
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
80 ;;;; Unix signals
81
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
82 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
83 (excl:without-interrupts (funcall fn)))
84
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
85 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
86 (excl::getpid))
87
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
88 (defimplementation lisp-implementation-type-name ()
89 "allegro")
90
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
91 (defimplementation set-default-directory (directory)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
92 (let ((dir (namestring (setf *default-pathname-defaults*
93 (truename (merge-pathnames directory))))))
94 (excl:chdir dir)
95 dir))
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
96
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
97 (defimplementation default-directory ()
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
98 (namestring (excl:current-directory)))
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
99
fab0b31 Add multiprocessing support.
Helmut Eller authored
100 ;;;; Misc
f912c9c New file.
Helmut Eller authored
101
8052a9e Minor modifications.
Helmut Eller authored
102 (defimplementation arglist (symbol)
d589600 (arglist): Return :not-available if arglist lookup fails with an
Luke Gorrie authored
103 (handler-case (excl:arglist symbol)
104 (simple-error () :not-available)))
8052a9e Minor modifications.
Helmut Eller authored
105
106 (defimplementation macroexpand-all (form)
107 (excl::walk form))
f912c9c New file.
Helmut Eller authored
108
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
109 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
110 (let ((result '()))
111 (flet ((doc (kind &optional (sym symbol))
112 (or (documentation sym kind) :not-documented))
113 (maybe-push (property value)
114 (when value
115 (setf result (list* property value result)))))
116 (maybe-push
117 :variable (when (boundp symbol)
118 (doc 'variable)))
119 (maybe-push
120 :function (if (fboundp symbol)
121 (doc 'function)))
122 (maybe-push
123 :class (if (find-class symbol nil)
124 (doc 'class)))
125 result)))
126
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
127 (defimplementation describe-definition (symbol namespace)
128 (ecase namespace
129 (:variable
130 (describe symbol))
131 ((:function :generic-function)
132 (describe (symbol-function symbol)))
133 (:class
134 (describe (find-class symbol)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
135
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
136 (defimplementation make-stream-interactive (stream)
137 (setf (interactive-stream-p stream) t))
138
fab0b31 Add multiprocessing support.
Helmut Eller authored
139 ;;;; Debugger
140
f912c9c New file.
Helmut Eller authored
141 (defvar *sldb-topframe*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
142
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
143 (defimplementation call-with-debugging-environment (debugger-loop-fn)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
144 (let ((*sldb-topframe* (excl::int-newest-frame))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
145 (excl::*break-hook* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
146 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
147
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
148 (defun next-frame (frame)
149 (let ((next (excl::int-next-older-frame frame)))
150 (cond ((not next) nil)
151 ((debugger:frame-visible-p next) next)
152 (t (next-frame next)))))
153
f912c9c New file.
Helmut Eller authored
154 (defun nth-frame (index)
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
155 (do ((frame *sldb-topframe* (next-frame frame))
f912c9c New file.
Helmut Eller authored
156 (i index (1- i)))
157 ((zerop i) frame)))
158
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
159 (defimplementation compute-backtrace (start end)
f912c9c New file.
Helmut Eller authored
160 (let ((end (or end most-positive-fixnum)))
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
161 (loop for f = (nth-frame start) then (next-frame f)
f912c9c New file.
Helmut Eller authored
162 for i from start below end
163 while f
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
164 collect f)))
f912c9c New file.
Helmut Eller authored
165
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
166 (defimplementation print-frame (frame stream)
167 (debugger:output-frame stream frame :moderate))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
168
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
169 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
170 (let ((frame (nth-frame index)))
171 (loop for i from 0 below (debugger:frame-number-vars frame)
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
172 collect (list :name (debugger:frame-var-name frame i)
f912c9c New file.
Helmut Eller authored
173 :id 0
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
174 :value (debugger:frame-var-value frame i)))))
f912c9c New file.
Helmut Eller authored
175
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
176 (defimplementation frame-var-value (frame var)
177 (let ((frame (nth-frame frame)))
178 (debugger:frame-var-value frame var)))
179
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
180 (defimplementation frame-catch-tags (index)
f912c9c New file.
Helmut Eller authored
181 (declare (ignore index))
182 nil)
183
8052a9e Minor modifications.
Helmut Eller authored
184 (defimplementation disassemble-frame (index)
185 (disassemble (debugger:frame-function (nth-frame index))))
186
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
187 (defimplementation frame-source-location-for-emacs (index)
33236b4 From Matthew Danish:
Luke Gorrie authored
188 (let* ((frame (nth-frame index))
189 (expr (debugger:frame-expression frame))
190 (fspec (first expr)))
191 (second (first (fspec-definition-locations fspec)))))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
192
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
193 (defimplementation eval-in-frame (form frame-number)
194 (debugger:eval-form-in-context
195 form
196 (debugger:environment-of-frame (nth-frame frame-number))))
197
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
198 (defimplementation return-from-frame (frame-number form)
199 (let ((frame (nth-frame frame-number)))
200 (multiple-value-call #'debugger:frame-return
201 frame (debugger:eval-form-in-context
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
202 form
203 (debugger:environment-of-frame frame)))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
204
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
205 (defimplementation restart-frame (frame-number)
206 (let ((frame (nth-frame frame-number)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
207 (cond ((debugger:frame-retryable-p frame)
208 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
209 (cdr (debugger:frame-expression frame))))
210 (t "Frame is not retryable"))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
211
fab0b31 Add multiprocessing support.
Helmut Eller authored
212 ;;;; Compiler hooks
213
f912c9c New file.
Helmut Eller authored
214 (defvar *buffer-name* nil)
215 (defvar *buffer-start-position*)
216 (defvar *buffer-string*)
aa65d6e Implemented.
Luke Gorrie authored
217 (defvar *compile-filename* nil)
f912c9c New file.
Helmut Eller authored
218
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
219 (defun compiler-note-p (object)
220 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
221
222 (defun compiler-undefined-functions-called-warning-p (object)
223 #-allegro-v5.0
224 (typep object 'excl:compiler-undefined-functions-called-warning))
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
225
226 (deftype compiler-note ()
227 `(satisfies compiler-note-p))
228
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
229 (defun signal-compiler-condition (&rest args)
230 (signal (apply #'make-condition 'compiler-condition args)))
231
f912c9c New file.
Helmut Eller authored
232 (defun handle-compiler-warning (condition)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
233 (declare (optimize (debug 3) (speed 0) (space 0)))
234 (cond ((and (not *buffer-name*)
235 (compiler-undefined-functions-called-warning-p condition))
236 (handle-undefined-functions-warning condition))
237 (t
238 (signal-compiler-condition
239 :original-condition condition
240 :severity (etypecase condition
241 (warning :warning)
242 (compiler-note :note))
243 :message (format nil "~A" condition)
244 :location (location-for-warning condition)))))
245
246 (defun location-for-warning (condition)
f912c9c New file.
Helmut Eller authored
247 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
248 (cond (*buffer-name*
249 (make-location
250 (list :buffer *buffer-name*)
251 (list :position *buffer-start-position*)))
252 (loc
253 (destructuring-bind (file . pos) loc
254 (make-location
255 (list :file (namestring (truename file)))
256 (list :position (1+ pos)))))
257 (t
258 (list :error "No error location available.")))))
259
260 (defun handle-undefined-functions-warning (condition)
261 (let ((fargs (slot-value condition 'excl::format-arguments)))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
262 (loop for (fname . pos-file) in (car fargs) do
263 (loop for (pos file) in pos-file do
264 (signal-compiler-condition
265 :original-condition condition
266 :severity :warning
267 :message (format nil "Undefined function referenced: ~S"
268 fname)
269 :location (make-location (list :file file)
270 (list :position (1+ pos))))))))
f912c9c New file.
Helmut Eller authored
271
aa65d6e Implemented.
Luke Gorrie authored
272 (defimplementation call-with-compilation-hooks (function)
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
273 (handler-bind ((warning #'handle-compiler-warning)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
274 ;;(compiler-note #'handle-compiler-warning)
275 )
aa65d6e Implemented.
Luke Gorrie authored
276 (funcall function)))
277
278 (defimplementation swank-compile-file (*compile-filename* load-p)
279 (with-compilation-hooks ()
f912c9c New file.
Helmut Eller authored
280 (let ((*buffer-name* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
281 (compile-file *compile-filename* :load-after-compile load-p))))
f912c9c New file.
Helmut Eller authored
282
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
283 (defun call-with-temp-file (fn)
284 (let ((tmpname (system:make-temp-file-name)))
285 (unwind-protect
286 (with-open-file (file tmpname :direction :output :if-exists :error)
287 (funcall fn file tmpname))
288 (delete-file tmpname))))
289
290 (defun compile-from-temp-file (string)
291 (call-with-temp-file
292 (lambda (stream filename)
293 (write-string string stream)
294 (finish-output stream)
295 (let ((binary-filename (compile-file filename :load-after-compile t)))
296 (when binary-filename
297 (delete-file binary-filename))))))
298
79c38c6 Adding directory argument to swank-compile-string.
Peter Seibel authored
299 (defimplementation swank-compile-string (string &key buffer position directory)
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
300 ;; We store the source buffer in excl::*source-pathname* as a string
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
301 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
302 ;; the fasl file is corrupted if we use some other datatype.
aa65d6e Implemented.
Luke Gorrie authored
303 (with-compilation-hooks ()
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
304 (let ((*buffer-name* buffer)
f912c9c New file.
Helmut Eller authored
305 (*buffer-start-position* position)
79c38c6 Adding directory argument to swank-compile-string.
Peter Seibel authored
306 (*buffer-string* string)
307 (*default-pathname-defaults*
308 (if directory (merge-pathnames (pathname directory))
309 *default-pathname-defaults*)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
310 (compile-from-temp-file
311 (format nil "~S ~S~%~A"
312 `(in-package ,(package-name *package*))
313 `(eval-when (:compile-toplevel :load-toplevel)
314 (setq excl::*source-pathname*
6d27ed7 (find-fspec-location): Catch errors in excl:source-file.
Helmut Eller authored
315 ',(format nil "~A;~D" buffer position)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
316 string)))))
f912c9c New file.
Helmut Eller authored
317
fab0b31 Add multiprocessing support.
Helmut Eller authored
318 ;;;; Definition Finding
319
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
320 (defun fspec-primary-name (fspec)
321 (etypecase fspec
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
322 (symbol fspec)
323 (list (fspec-primary-name (second fspec)))))
324
325 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
326 ;; single character, but file-position counts them as two. Here we do
327 ;; our own conversion.
328 (defun count-cr (file pos)
329 (let* ((bufsize 256)
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
330 (type '(unsigned-byte 8))
331 (buf (make-array bufsize :element-type type))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
332 (cr-count 0))
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
333 (with-open-file (stream file :direction :input :element-type type)
334 (loop for bytes-read = (read-sequence buf stream) do
335 (incf cr-count (count (char-code #\return) buf
336 :end (min pos bytes-read)))
337 (decf pos bytes-read)
338 (when (<= pos 0)
339 (return cr-count))))))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
340
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
341 (defun find-definition-in-file (fspec type file)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
342 (let* ((start (or (scm:find-definition-in-file fspec type file)
343 (scm:find-definition-in-file (fspec-primary-name fspec)
344 type file)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
345 (pos (if start
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
346 (list :position (1+ (- start (count-cr file start))))
347 (list :function-name (string (fspec-primary-name fspec))))))
348 (make-location (list :file (namestring (truename file)))
349 pos)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
350
351 (defun find-definition-in-buffer (filename)
352 (let ((pos (position #\; filename :from-end t)))
353 (make-location
354 (list :buffer (subseq filename 0 pos))
355 (list :position (parse-integer (subseq filename (1+ pos)))))))
356
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
357 (defun find-fspec-location (fspec type)
6d27ed7 (find-fspec-location): Catch errors in excl:source-file.
Helmut Eller authored
358 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
359 (etypecase file
360 (pathname
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
361 (find-definition-in-file fspec type file))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
362 ((member :top-level)
6d27ed7 (find-fspec-location): Catch errors in excl:source-file.
Helmut Eller authored
363 (list :error (format nil "Defined at toplevel: ~A"
364 (fspec->string fspec))))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
365 (string
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
366 (find-definition-in-buffer file))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
367 (null
6d27ed7 (find-fspec-location): Catch errors in excl:source-file.
Helmut Eller authored
368 (list :error (if err
369 (princ-to-string err)
370 (format nil "Unknown source location for ~A"
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
371 (fspec->string fspec)))))
372 (cons
373 (destructuring-bind ((type . filename)) file
374 (assert (member type '(:operator)))
375 (etypecase filename
376 (pathname
377 (find-definition-in-file fspec type filename))
378 (string
379 (find-definition-in-buffer filename))))))))
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
380
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
381 (defun fspec->string (fspec)
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
382 (etypecase fspec
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
383 (symbol (let ((*package* (find-package :keyword)))
384 (prin1-to-string fspec)))
385 (list (format nil "(~A ~A)"
386 (prin1-to-string (first fspec))
387 (let ((*package* (find-package :keyword)))
388 (prin1-to-string (second fspec)))))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
389
437f909 Remove stupid conflicts.
Helmut Eller authored
390 (defun fspec-definition-locations (fspec)
f912c9c New file.
Helmut Eller authored
391 (let ((defs (excl::find-multiple-definitions fspec)))
8052a9e Minor modifications.
Helmut Eller authored
392 (loop for (fspec type) in defs
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
393 collect (list (list type fspec)
394 (find-fspec-location fspec type)))))
8052a9e Minor modifications.
Helmut Eller authored
395
396 (defimplementation find-definitions (symbol)
397 (fspec-definition-locations symbol))
fab0b31 Add multiprocessing support.
Helmut Eller authored
398
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
399 ;;;; XREF
f912c9c New file.
Helmut Eller authored
400
8052a9e Minor modifications.
Helmut Eller authored
401 (defmacro defxref (name relation name1 name2)
402 `(defimplementation ,name (x)
403 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
404
405 (defxref who-calls :calls :wild x)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
406 (defxref calls-who :calls x :wild)
8052a9e Minor modifications.
Helmut Eller authored
407 (defxref who-references :uses :wild x)
408 (defxref who-binds :binds :wild x)
409 (defxref who-macroexpands :macro-calls :wild x)
410 (defxref who-sets :sets :wild x)
411
412 (defun xref-result (fspecs)
413 (loop for fspec in fspecs
414 append (fspec-definition-locations fspec)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
415
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
416 ;; list-callers implemented by groveling through all fbound symbols.
417 ;; Only symbols are considered. Functions in the constant pool are
418 ;; searched recursevly. Closure environments are ignored at the
419 ;; moment (constants in methods are therefore not found).
420
421 (defun map-function-constants (function fn depth)
422 "Call FN with the elements of FUNCTION's constant pool."
423 (do ((i 0 (1+ i))
424 (max (excl::function-constant-count function)))
425 ((= i max))
426 (let ((c (excl::function-constant function i)))
427 (cond ((and (functionp c)
428 (not (eq c function))
429 (plusp depth))
430 (map-function-constants c fn (1- depth)))
431 (t
432 (funcall fn c))))))
433
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
434 (defun in-constants-p (fun symbol)
435 (map-function-constants fun
436 (lambda (c)
437 (when (eq c symbol)
438 (return-from in-constants-p t)))
439 3))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
440
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
441 (defun function-callers (name)
442 (let ((callers '()))
443 (do-all-symbols (sym)
444 (when (fboundp sym)
445 (let ((fn (fdefinition sym)))
446 (when (in-constants-p fn name)
447 (push sym callers)))))
448 callers))
449
450 (defimplementation list-callers (name)
451 (xref-result (function-callers name)))
452
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
453 (defimplementation list-callees (name)
454 (let ((result '()))
455 (map-function-constants (fdefinition name)
456 (lambda (c)
457 (when (fboundp c)
458 (push c result)))
459 2)
460 (xref-result result)))
461
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
462 ;;;; Inspecting
463
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
464 (defclass acl-inspector (inspector)
465 ())
466
467 (defimplementation make-default-inspector ()
468 (make-instance 'acl-inspector))
469
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
470 ;; duplicated from swank.lisp in order to avoid package dependencies
471 (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
472 (butlast
473 (loop
474 for i in list
475 collect (funcall callback i)
476 collect ", ")))
477
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
478 #-allegro-v5.0
479 (defmethod inspect-for-emacs ((f function) inspector)
480 inspector
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
481 (values "A function."
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
482 (append
483 (label-value-line "Name" (function-name f))
484 `("Formals" ,(princ-to-string (arglist f)) (:newline))
485 (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
486 (when doc
487 `("Documentation:" (:newline) ,doc))))))
488
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
489
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
490 (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
491 (values "A structure class."
492 `("Name: " (:value ,(class-name class))
493 (:newline)
494 "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
495 (:newline)
496 "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)
497 (lambda (slot)
498 `(:value ,slot ,(princ-to-string
499 (swank-mop:slot-definition-name slot)))))
500 (:newline)
501 "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)
502 (common-seperated-spec (swank-mop:class-slots class)
503 (lambda (slot)
504 `(:value ,slot ,(princ-to-string
505 (swank-mop:slot-definition-name slot)))))
506 '("N/A (class not finalized)"))
507 (:newline)
508 "Documentation:" (:newline)
509 ,@(when (documentation class t)
510 `(,(documentation class t) (:newline)))
511 "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
512 (lambda (sub)
513 `(:value ,sub ,(princ-to-string (class-name sub)))))
514 (:newline)
515 "Precedence List: " ,@(if (swank-mop:class-finalized-p class)
516 (common-seperated-spec (swank-mop:class-precedence-list class)
517 (lambda (class)
518 `(:value ,class ,(princ-to-string (class-name class)))))
519 '("N/A (class not finalized)"))
520 (:newline)
521 "Prototype: " ,(if (swank-mop:class-finalized-p class)
522 `(:value ,(swank-mop:class-prototype class))
523 '"N/A (class not finalized)"))))
524
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
525 #-allegro-v5.0
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
526 (defmethod inspect-for-emacs ((slot excl::structure-slot-definition)
527 (inspector acl-inspector))
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
528 (values "A structure slot."
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
529 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
530 (:newline)
531 "Documentation:" (:newline)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
532 ,@(when (documentation slot t)
533 `((:value ,(documentation slot t)) (:newline)))
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
534 "Initform: " ,(if (swank-mop:slot-definition-initform slot)
535 `(:value ,(swank-mop:slot-definition-initform slot))
536 "#<unspecified>") (:newline)
537 "Type: " ,(if (swank-mop:slot-definition-type slot)
538 `(:value ,(swank-mop:slot-definition-type slot))
539 "#<unspecified>") (:newline)
540 "Allocation: " (:value ,(excl::slotd-allocation slot)) (:newline)
541 "Read-only: " (:value ,(excl::slotd-read-only slot)) (:newline))))
542
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
543 (defmethod inspect-for-emacs ((o structure-object) (inspector acl-inspector))
8eb357e 2004-09-14 Thomas Schilling <tjs_ng@yahoo.de>
Marco Baringer authored
544 (values "An structure object."
545 `("Structure class: " (:value ,(class-of o))
546 (:newline)
547 "Slots:" (:newline)
548 ,@(loop
549 with direct-slots = (swank-mop:class-direct-slots (class-of o))
550 for slot in (swank-mop:class-slots (class-of o))
551 for slot-def = (or (find-if (lambda (a)
552 ;; find the direct slot with the same as
553 ;; SLOT (an effective slot).
554 (eql (swank-mop:slot-definition-name a)
555 (swank-mop:slot-definition-name slot)))
556 direct-slots)
557 slot)
558 collect `(:value ,slot-def ,(princ-to-string (swank-mop:slot-definition-name slot-def)))
559 collect " = "
560 if (slot-boundp o (swank-mop:slot-definition-name slot-def))
561 collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
562 else
563 collect "#<unbound>"
564 collect '(:newline)))))
565
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
566 (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
567 inspector
568 (values "A value." (allegro-inspect o)))
569
570 (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
571 inspector
572 (values "A function." (allegro-inspect o)))
573
574 (defun allegro-inspect (o)
575 (loop for (d dd) on (inspect::inspect-ctl o)
576 until (eq d dd)
577 for i from 0
578 append (frob-allegro-field-def o d i)))
579
580 (defun frob-allegro-field-def (object def idx)
581 (with-struct (inspect::field-def- name type access) def
582 (label-value-line name
583 (ecase type
584 ((:unsigned-word :unsigned-byte :unsigned-natural
585 :unsigned-half-long)
586 (inspect::component-ref-v object access type))
587 (:lisp
588 (inspect::component-ref object access))
589 (:indirect
590 (apply #'inspect::indirect-ref object idx access))))))
591
592 #|
593 (defun test (foo)
594 (inspect::show-object-structure foo (inspect::inspect-ctl foo) 1))
595 |#
596
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
597 ;;;; Multithreading
fab0b31 Add multiprocessing support.
Helmut Eller authored
598
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
599 (defimplementation startup-multiprocessing ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
600 (mp:start-scheduler))
601
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
602 (defimplementation spawn (fn &key name)
68dd370 Removed fwrapper-based code for inheriting "swankiness" to newly
Luke Gorrie authored
603 (mp:process-run-function name fn))
fab0b31 Add multiprocessing support.
Helmut Eller authored
604
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
605 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
606 (defvar *thread-id-counter* 0)
607
608 (defimplementation thread-id (thread)
609 (mp:with-process-lock (*id-lock*)
610 (or (getf (mp:process-property-list thread) 'id)
611 (setf (getf (mp:process-property-list thread) 'id)
612 (incf *thread-id-counter*)))))
613
614 (defimplementation find-thread (id)
615 (find id mp:*all-processes*
616 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
617
64ff730 Update for modified thread interface.
Helmut Eller authored
618 (defimplementation thread-name (thread)
619 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
620
64ff730 Update for modified thread interface.
Helmut Eller authored
621 (defimplementation thread-status (thread)
622 (format nil "~A ~D" (mp:process-whostate thread)
623 (mp:process-priority thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
624
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
625 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
626 (mp:make-process-lock :name name))
627
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
628 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
629 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
630
631 (defimplementation current-thread ()
632 mp:*current-process*)
633
634 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
635 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
636
637 (defimplementation interrupt-thread (thread fn)
638 (mp:process-interrupt thread fn))
639
52dc1fc (kill-thread): Implemented.
Helmut Eller authored
640 (defimplementation kill-thread (thread)
641 (mp:process-kill thread))
642
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
643 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
644
645 (defstruct (mailbox (:conc-name mailbox.))
646 (mutex (mp:make-process-lock :name "process mailbox"))
647 (queue '() :type list))
648
649 (defun mailbox (thread)
650 "Return THREAD's mailbox."
651 (mp:with-process-lock (*mailbox-lock*)
652 (or (getf (mp:process-property-list thread) 'mailbox)
653 (setf (getf (mp:process-property-list thread) 'mailbox)
654 (make-mailbox)))))
655
656 (defimplementation send (thread message)
657 (let* ((mbox (mailbox thread))
658 (mutex (mailbox.mutex mbox)))
cbaae0c (send): Wait a bit if there are already many message in the mailbox.
Helmut Eller authored
659 (mp:process-wait-with-timeout
660 "yielding before sending" 0.1
661 (lambda ()
662 (mp:with-process-lock (mutex)
95e3c25 (send): Fix misplaced parens. (From Bill Clementson)
Helmut Eller authored
663 (< (length (mailbox.queue mbox)) 10))))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
664 (mp:with-process-lock (mutex)
665 (setf (mailbox.queue mbox)
666 (nconc (mailbox.queue mbox) (list message))))))
667
668 (defimplementation receive ()
669 (let* ((mbox (mailbox mp:*current-process*))
670 (mutex (mailbox.mutex mbox)))
671 (mp:process-wait "receive" #'mailbox.queue mbox)
672 (mp:with-process-lock (mutex)
673 (pop (mailbox.queue mbox)))))
9decabc See ChangeLog entry 2004-04-06 Marco Baringer
Marco Baringer authored
674
675 (defimplementation quit-lisp ()
676 (excl:exit 0 :quiet t))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
677
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
678
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
679 ;;Trace implementations
680 ;;In Allegro 7.0, we have:
681 ;; (trace <name>)
682 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
683 ;; (trace ((labels <name> <label-name>)))
684 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
685 ;; <name> can be a normal name or a (setf name)
686
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
687 (defimplementation toggle-trace (spec)
688 (ecase (car spec)
689 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
690 ((:defmethod :labels :flet)
691 (toggle-trace-aux (process-fspec-for-allegro spec)))
692 (:call
693 (destructuring-bind (caller callee) (cdr spec)
694 (toggle-trace-aux callee
695 :inside (list (process-fspec-for-allegro caller)))))))
696
697 (defun tracedp (fspec)
698 (member name (eval '(trace)) :test #'equal))
699
700 (defun toggle-trace-aux (fspec &rest args)
701 (cond ((tracedp fspec)
702 (eval `(untrace ,fspec))
703 (format nil "~S is now untraced." fspec))
704 (t
705 (eval `(trace (,fspec ,@args)))
706 (format nil "~S is now traced." fspec))))
707
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
708 #-allegro-v5.0
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
709 (defun toggle-trace-generic-function-methods (name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
710 (let ((methods (mop:generic-function-methods (fdefinition name))))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
711 (cond ((tracedp name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
712 (eval `(untrace ,name))
713 (dolist (method methods (format nil "~S is now untraced." name))
714 (excl:funtrace (mop:method-function method))))
715 (t
716 (eval `(trace ,name))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
717 (dolist (method methods (format nil "~S is now traced." name))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
718 (excl:ftrace (mop:method-function method)))))))
719
720 (defun process-fspec-for-allegro (fspec)
721 (cond ((consp fspec)
722 (ecase (first fspec)
723 ((:defun :defgeneric) (second fspec))
724 ((:defmethod) `(method ,@(rest fspec)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
725 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
726 ,(third fspec)))
727 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
728 ,(third fspec)))))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
729 (t
730 fspec)))
Something went wrong with that request. Please try again.