Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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-emacs...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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 end s...
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.