Skip to content

HTTPS clone URL

Subversion checkout URL

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