Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 947 lines (795 sloc) 34.041 kB
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
1 ;;;; -*- 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
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
8 ;;; are disclaimed.
f912c9c New file.
Helmut Eller authored
9 ;;;
10
8052a9e Minor modifications.
Helmut Eller authored
11 (in-package :swank-backend)
12
f912c9c New file.
Helmut Eller authored
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :sock)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
15 (require :process)
16 #+(version>= 8 2)
17 (require 'lldb)
18 )
19
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
20 (import-from :excl *gray-stream-symbols* :swank-backend)
f912c9c New file.
Helmut Eller authored
21
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
22 ;;; swank-mop
23
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
24 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
ff1fa86 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
25
26 (defun swank-mop:slot-definition-documentation (slot)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
27 (documentation slot t))
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
28
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
29
f050f4b * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented.
Helmut Eller authored
30 ;;;; UTF8
31
e29b538 Use Unix-EOL convention even on Windows.
Helmut Eller authored
32 (define-symbol-macro utf8-ef
33 (load-time-value
34 (excl:crlf-base-ef (excl:find-external-format :utf-8))
35 t))
36
f050f4b * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented.
Helmut Eller authored
37 (defimplementation string-to-utf8 (s)
e7bdad5 * swank-allegro.lisp (string-to-utf8): Set the :null-terminate
Helmut Eller authored
38 (excl:string-to-octets s :external-format utf8-ef
39 :null-terminate nil))
f050f4b * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented.
Helmut Eller authored
40
41 (defimplementation utf8-to-string (u)
e29b538 Use Unix-EOL convention even on Windows.
Helmut Eller authored
42 (excl:octets-to-string u :external-format utf8-ef))
f050f4b * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented.
Helmut Eller authored
43
44
fab0b31 Add multiprocessing support.
Helmut Eller authored
45 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
46
8052a9e Minor modifications.
Helmut Eller authored
47 (defimplementation preferred-communication-style ()
48 :spawn)
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
49
1a8faa2 * swank.lisp (create-server): Add a :backlog argument.
Helmut Eller authored
50 (defimplementation create-socket (host port &key backlog)
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
51 (socket:make-socket :connect :passive :local-port port
1a8faa2 * swank.lisp (create-server): Add a :backlog argument.
Helmut Eller authored
52 :local-host host :reuse-address t
53 :backlog (or backlog 5)))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-em…
Helmut Eller authored
54
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
55 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
56 (socket:local-port socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
57
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
58 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
59 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
60
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
61 (defimplementation accept-connection (socket &key external-format buffering
62 timeout)
63 (declare (ignore buffering timeout))
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
64 (let ((s (socket:accept-connection socket :wait t)))
65 (when external-format
66 (setf (stream-external-format s) external-format))
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
67 s))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
68
0be420c * swank-allegro.lisp (socket-fd): Add support for allegro.
Helmut Eller authored
69 (defimplementation socket-fd (stream)
70 (excl::stream-input-handle stream))
71
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
72 (defvar *external-format-to-coding-system*
73 '((:iso-8859-1
74 "latin-1" "latin-1-unix" "iso-latin-1-unix"
75 "iso-8859-1" "iso-8859-1-unix")
76 (:utf-8 "utf-8" "utf-8-unix")
77 (:euc-jp "euc-jp" "euc-jp-unix")
78 (:us-ascii "us-ascii" "us-ascii-unix")
79 (:emacs-mule "emacs-mule" "emacs-mule-unix")))
80
81 (defimplementation find-external-format (coding-system)
82 (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83 *external-format-to-coding-system*)))
84 (and e (excl:crlf-base-ef
85 (excl:find-external-format (car e)
86 :try-variant t)))))
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
87
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
88 (defimplementation format-sldb-condition (c)
89 (princ-to-string c))
90
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
91 (defimplementation call-with-syntax-hooks (fn)
92 (funcall fn))
93
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
94 ;;;; Unix signals
95
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
96 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
97 (excl::getpid))
98
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
99 (defimplementation lisp-implementation-type-name ()
100 "allegro")
101
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
102 (defimplementation set-default-directory (directory)
b408600 (set-default-directory): Fix for pathnames without a trailing slash.
Matthias Koeppe authored
103 (let* ((dir (namestring (truename (merge-pathnames directory)))))
104 (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
105 dir))
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
106
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
107 (defimplementation default-directory ()
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
108 (namestring (excl:current-directory)))
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
109
fab0b31 Add multiprocessing support.
Helmut Eller authored
110 ;;;; Misc
f912c9c New file.
Helmut Eller authored
111
8052a9e Minor modifications.
Helmut Eller authored
112 (defimplementation arglist (symbol)
d589600 (arglist): Return :not-available if arglist lookup fails with an
Luke Gorrie authored
113 (handler-case (excl:arglist symbol)
114 (simple-error () :not-available)))
8052a9e Minor modifications.
Helmut Eller authored
115
116 (defimplementation macroexpand-all (form)
117 (excl::walk form))
f912c9c New file.
Helmut Eller authored
118
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
119 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
120 (let ((result '()))
121 (flet ((doc (kind &optional (sym symbol))
122 (or (documentation sym kind) :not-documented))
123 (maybe-push (property value)
124 (when value
125 (setf result (list* property value result)))))
126 (maybe-push
127 :variable (when (boundp symbol)
128 (doc 'variable)))
129 (maybe-push
130 :function (if (fboundp symbol)
131 (doc 'function)))
132 (maybe-push
133 :class (if (find-class symbol nil)
134 (doc 'class)))
135 result)))
136
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
137 (defimplementation describe-definition (symbol namespace)
138 (ecase namespace
139 (:variable
140 (describe symbol))
141 ((:function :generic-function)
142 (describe (symbol-function symbol)))
143 (:class
144 (describe (find-class symbol)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
145
fab0b31 Add multiprocessing support.
Helmut Eller authored
146 ;;;; Debugger
147
f912c9c New file.
Helmut Eller authored
148 (defvar *sldb-topframe*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
149
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
150 (defimplementation call-with-debugging-environment (debugger-loop-fn)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
151 (let ((*sldb-topframe* (find-topframe))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
152 (excl::*break-hook* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
153 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
154
424cc92 (sldb-break-at-start): Implement.
Matthias Koeppe authored
155 (defimplementation sldb-break-at-start (fname)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
156 ;; :print-before is kind of mis-used but we just want to stuff our
157 ;; break form somewhere. This does not work for setf, :before and
158 ;; :after methods, which need special syntax in the trace call, see
159 ;; ACL's doc/debugging.htm chapter 10.
424cc92 (sldb-break-at-start): Implement.
Matthias Koeppe authored
160 (eval `(trace (,fname
161 :print-before
162 ((break "Function start breakpoint of ~A" ',fname)))))
163 `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
164
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
165 (defun find-topframe ()
83a4ffd @trittweiler * swank-allegro.lisp (find-topframe): Hide SWANK related cruft
trittweiler authored
166 (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
167 (find-package :swank)))
2e8aa53 @stassats * swank-allegro.lisp (find-topframe): Fix excl::int-newest-frame
stassats authored
168 (top-frame (excl::int-newest-frame (excl::current-thread))))
83a4ffd @trittweiler * swank-allegro.lisp (find-topframe): Hide SWANK related cruft
trittweiler authored
169 (loop for frame = top-frame then (next-frame frame)
170 for name = (debugger:frame-name frame)
171 for i from 0
172 when (eq name magic-symbol)
173 return (next-frame frame)
174 until (= i 10) finally (return top-frame))))
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
175
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
176 (defun next-frame (frame)
177 (let ((next (excl::int-next-older-frame frame)))
178 (cond ((not next) nil)
179 ((debugger:frame-visible-p next) next)
180 (t (next-frame next)))))
181
f912c9c New file.
Helmut Eller authored
182 (defun nth-frame (index)
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
183 (do ((frame *sldb-topframe* (next-frame frame))
f912c9c New file.
Helmut Eller authored
184 (i index (1- i)))
185 ((zerop i) frame)))
186
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
187 (defimplementation compute-backtrace (start end)
f912c9c New file.
Helmut Eller authored
188 (let ((end (or end most-positive-fixnum)))
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
189 (loop for f = (nth-frame start) then (next-frame f)
f912c9c New file.
Helmut Eller authored
190 for i from start below end
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
191 while f collect f)))
f912c9c New file.
Helmut Eller authored
192
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
193 (defimplementation print-frame (frame stream)
194 (debugger:output-frame stream frame :moderate))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
195
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
196 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
197 (let ((frame (nth-frame index)))
198 (loop for i from 0 below (debugger:frame-number-vars frame)
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
199 collect (list :name (debugger:frame-var-name frame i)
f912c9c New file.
Helmut Eller authored
200 :id 0
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
201 :value (debugger:frame-var-value frame i)))))
f912c9c New file.
Helmut Eller authored
202
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
203 (defimplementation frame-var-value (frame var)
204 (let ((frame (nth-frame frame)))
205 (debugger:frame-var-value frame var)))
f912c9c New file.
Helmut Eller authored
206
8052a9e Minor modifications.
Helmut Eller authored
207 (defimplementation disassemble-frame (index)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
208 (let ((frame (nth-frame index)))
209 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
210 (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
211 (disassemble (debugger:frame-function frame)))))
8052a9e Minor modifications.
Helmut Eller authored
212
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored
213 (defimplementation frame-source-location (index)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
214 (let* ((frame (nth-frame index)))
215 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
216 (declare (ignore x xx xxx))
a7c970b Fix some of the brokeness in the last change.
Helmut Eller authored
217 (cond (pc
218 #+(version>= 8 2)
219 (pc-source-location fun pc)
220 #-(version>= 8 2)
221 (function-source-location fun))
222 (t ; frames for unbound functions etc end up here
223 (cadr (car (fspec-definition-locations
224 (car (debugger:frame-expression frame))))))))))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
225
226 (defun function-source-location (fun)
5d60829 Even more long line breaking.
Helmut Eller authored
227 (cadr (car (fspec-definition-locations
228 (xref::object-to-function-name fun)))))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
229
230 #+(version>= 8 2)
231 (defun pc-source-location (fun pc)
232 (let* ((debug-info (excl::function-source-debug-info fun)))
233 (cond ((not debug-info)
234 (function-source-location fun))
235 (t
86cc95a (pc-source-location): Be a bit more fuzzy when searching the
Helmut Eller authored
236 (let* ((code-loc (find-if (lambda (c)
237 (<= (- pc (sys::natural-width))
238 (excl::ldb-code-pc c)
239 pc))
240 debug-info)))
241 (cond ((not code-loc)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
242 (ldb-code-to-src-loc (aref debug-info 0)))
243 (t
86cc95a (pc-source-location): Be a bit more fuzzy when searching the
Helmut Eller authored
244 (ldb-code-to-src-loc code-loc))))))))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
245
246 #+(version>= 8 2)
247 (defun ldb-code-to-src-loc (code)
248 (let* ((start (excl::ldb-code-start-char code))
249 (func (excl::ldb-code-func code))
a7c970b Fix some of the brokeness in the last change.
Helmut Eller authored
250 (src-file (excl:source-file func)))
251 (cond (start
252 (buffer-or-file-location src-file start))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
253 (t
254 (let* ((debug-info (excl::function-source-debug-info func))
255 (whole (aref debug-info 0))
256 (paths (source-paths-of (excl::ldb-code-source whole)
257 (excl::ldb-code-source code)))
258 (path (longest-common-prefix paths))
be5c6cf (ldb-code-to-src-loc): Don't use *temp-file-map* before it is declared.
Helmut Eller authored
259 (start (excl::ldb-code-start-char whole)))
260 (buffer-or-file
261 src-file
262 (lambda (file)
263 (make-location `(:file ,file)
264 `(:source-path (0 . ,path) ,start)))
265 (lambda (buffer bstart)
266 (make-location `(:buffer ,buffer)
267 `(:source-path (0 . ,path)
268 ,(+ bstart start))))))))))
269
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
270 (defun longest-common-prefix (sequences)
271 (assert sequences)
272 (flet ((common-prefix (s1 s2)
273 (let ((diff-pos (mismatch s1 s2)))
274 (if diff-pos (subseq s1 0 diff-pos) s1))))
275 (reduce #'common-prefix sequences)))
276
277 (defun source-paths-of (whole part)
278 (let ((result '()))
279 (labels ((walk (form path)
280 (cond ((eq form part)
281 (push (reverse path) result))
282 ((consp form)
283 (loop for i from 0 while (consp form) do
284 (walk (pop form) (cons i path)))))))
285 (walk whole '())
286 (reverse result))))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
287
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
288 (defimplementation eval-in-frame (form frame-number)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
289 (let ((frame (nth-frame frame-number)))
290 ;; let-bind lexical variables
291 (let ((vars (loop for i below (debugger:frame-number-vars frame)
292 for name = (debugger:frame-var-name frame i)
293 if (symbolp name)
294 collect `(,name ',(debugger:frame-var-value frame i)))))
295 (debugger:eval-form-in-context
296 `(let* ,vars ,form)
297 (debugger:environment-of-frame frame)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
298
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
299 (defimplementation return-from-frame (frame-number form)
300 (let ((frame (nth-frame frame-number)))
301 (multiple-value-call #'debugger:frame-return
302 frame (debugger:eval-form-in-context
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
303 form
304 (debugger:environment-of-frame frame)))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
305
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
306 (defimplementation frame-restartable-p (frame)
bf67446 * swank-allegro.lisp (frame-restartable-p): Handle errors signaled
Helmut Eller authored
307 (handler-case (debugger:frame-retryable-p frame)
308 (serious-condition (c)
309 (funcall (read-from-string "swank::background-message")
310 "~a ~a" frame (princ-to-string c))
311 nil)))
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
312
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
313 (defimplementation restart-frame (frame-number)
314 (let ((frame (nth-frame frame-number)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
315 (cond ((debugger:frame-retryable-p frame)
316 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
317 (cdr (debugger:frame-expression frame))))
318 (t "Frame is not retryable"))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
319
fab0b31 Add multiprocessing support.
Helmut Eller authored
320 ;;;; Compiler hooks
321
f912c9c New file.
Helmut Eller authored
322 (defvar *buffer-name* nil)
323 (defvar *buffer-start-position*)
324 (defvar *buffer-string*)
aa65d6e Implemented.
Luke Gorrie authored
325 (defvar *compile-filename* nil)
f912c9c New file.
Helmut Eller authored
326
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
327 (defun compiler-note-p (object)
328 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
329
bf4d33d @trittweiler * swank-allegro.lisp (redefinition-p, redefinition): New.
trittweiler authored
330 (defun redefinition-p (condition)
331 (and (typep condition 'style-warning)
332 (every #'char-equal "redefin" (princ-to-string condition))))
333
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
334 (defun compiler-undefined-functions-called-warning-p (object)
335 (typep object 'excl:compiler-undefined-functions-called-warning))
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
336
337 (deftype compiler-note ()
338 `(satisfies compiler-note-p))
339
bf4d33d @trittweiler * swank-allegro.lisp (redefinition-p, redefinition): New.
trittweiler authored
340 (deftype redefinition ()
341 `(satisfies redefinition-p))
342
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
343 (defun signal-compiler-condition (&rest args)
c6b4fd5 @stassats * clean up: (signal (make-condition ...)) => (signal ...)
stassats authored
344 (apply #'signal 'compiler-condition args))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
345
f912c9c New file.
Helmut Eller authored
346 (defun handle-compiler-warning (condition)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
347 (declare (optimize (debug 3) (speed 0) (space 0)))
ab49718 Handle src-locs of compiler warnings in Allegro 8.2.
Helmut Eller authored
348 (cond ((and (not *buffer-name*)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
349 (compiler-undefined-functions-called-warning-p condition))
350 (handle-undefined-functions-warning condition))
351 (t
352 (signal-compiler-condition
353 :original-condition condition
354 :severity (etypecase condition
bf4d33d @trittweiler * swank-allegro.lisp (redefinition-p, redefinition): New.
trittweiler authored
355 (redefinition :redefinition)
356 (style-warning :style-warning)
357 (warning :warning)
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
358 (compiler-note :note)
bf4d33d @trittweiler * swank-allegro.lisp (redefinition-p, redefinition): New.
trittweiler authored
359 (reader-error :read-error)
360 (error :error))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
361 :message (format nil "~A" condition)
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
362 :location (if (typep condition 'reader-error)
363 (location-for-reader-error condition)
364 (location-for-warning condition))))))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
365
366 (defun location-for-warning (condition)
f912c9c New file.
Helmut Eller authored
367 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
368 (cond (*buffer-name*
369 (make-location
370 (list :buffer *buffer-name*)
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
371 (list :offset *buffer-start-position* 0)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
372 (loc
373 (destructuring-bind (file . pos) loc
ab49718 Handle src-locs of compiler warnings in Allegro 8.2.
Helmut Eller authored
374 (let ((start (cond ((consp pos) ; 8.2 and newer
375 (car pos))
376 (t pos))))
377 (make-location
378 (list :file (namestring (truename file)))
379 (list :position (1+ start))))))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
380 (t
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
381 (make-error-location "No error location available.")))))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
382
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
383 (defun location-for-reader-error (condition)
384 (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
385 (file (pathname (stream-error-stream condition))))
386 (if (integerp pos)
387 (if *buffer-name*
388 (make-location `(:buffer ,*buffer-name*)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
389 `(:offset ,*buffer-start-position* ,pos))
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
390 (make-location `(:file ,(namestring (truename file)))
391 `(:position ,pos)))
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
392 (make-error-location "No error location available."))))
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
393
ab49718 Handle src-locs of compiler warnings in Allegro 8.2.
Helmut Eller authored
394 ;; TODO: report it as a bug to Franz that the condition's plist
395 ;; slot contains (:loc nil).
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
396 (defun handle-undefined-functions-warning (condition)
397 (let ((fargs (slot-value condition 'excl::format-arguments)))
ab49718 Handle src-locs of compiler warnings in Allegro 8.2.
Helmut Eller authored
398 (loop for (fname . locs) in (car fargs) do
399 (dolist (loc locs)
400 (multiple-value-bind (pos file) (ecase (length loc)
401 (2 (values-list loc))
402 (3 (destructuring-bind
403 (start end file) loc
404 (declare (ignore end))
405 (values start file))))
406 (signal-compiler-condition
407 :original-condition condition
408 :severity :warning
409 :message (format nil "Undefined function referenced: ~S"
410 fname)
411 :location (make-location (list :file file)
412 (list :position (1+ pos)))))))))
413
aa65d6e Implemented.
Luke Gorrie authored
414 (defimplementation call-with-compilation-hooks (function)
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
415 (handler-bind ((warning #'handle-compiler-warning)
416 (compiler-note #'handle-compiler-warning)
417 (reader-error #'handle-compiler-warning))
aa65d6e Implemented.
Luke Gorrie authored
418 (funcall function)))
419
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
420 (defimplementation swank-compile-file (input-file output-file
20bed40 @stassats * slime.el (slime-compile-and-load-file): Accept C-u arguments for
stassats authored
421 load-p external-format
422 &key policy)
423 (declare (ignore policy))
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
424 (handler-case
425 (with-compilation-hooks ()
426 (let ((*buffer-name* nil)
427 (*compile-filename* input-file))
428 (compile-file *compile-filename*
429 :output-file output-file
430 :load-after-compile load-p
431 :external-format external-format)))
432 (reader-error () (values nil nil t))))
f912c9c New file.
Helmut Eller authored
433
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
434 (defun call-with-temp-file (fn)
435 (let ((tmpname (system:make-temp-file-name)))
436 (unwind-protect
437 (with-open-file (file tmpname :direction :output :if-exists :error)
438 (funcall fn file tmpname))
439 (delete-file tmpname))))
440
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
441 (defvar *temp-file-map* (make-hash-table :test #'equal)
442 "A mapping from tempfile names to Emacs buffer names.")
443
444 (defun compile-from-temp-file (string buffer offset file)
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
445 (call-with-temp-file
446 (lambda (stream filename)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
447 (let ((excl:*load-source-file-info* t)
448 (sys:*source-file-types* '(nil)) ; suppress .lisp extension
449 #+(version>= 8 2)
450 (compiler:save-source-level-debug-info-switch t)
451 #+(version>= 8 2)
452 (excl:*load-source-debug-info* t) ; NOTE: requires lldb
453 )
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
454 (write-string string stream)
455 (finish-output stream)
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
456 (multiple-value-bind (binary-filename warnings? failure?)
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
457 (excl:without-redefinition-warnings
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
458 ;; Suppress Allegro's redefinition warnings; they are
459 ;; pointless when we are compiling via a temporary
460 ;; file.
461 (compile-file filename :load-after-compile t))
462 (declare (ignore warnings?))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
463 (when binary-filename
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
464 (setf (gethash (pathname stream) *temp-file-map*)
465 (list buffer offset file))
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
466 (delete-file binary-filename))
a8fa895 @trittweiler Highlight reader-errors in the source buffers on Allegro.
trittweiler authored
467 (not failure?))))))
468
469 (defimplementation swank-compile-string (string &key buffer position filename
470 policy)
471 (declare (ignore policy))
472 (handler-case
473 (with-compilation-hooks ()
474 (let ((*buffer-name* buffer)
475 (*buffer-start-position* position)
476 (*buffer-string* string)
477 (*default-pathname-defaults*
478 (if filename
479 (merge-pathnames (pathname filename))
480 *default-pathname-defaults*)))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
481 (compile-from-temp-file string buffer position filename)))
05687e1 * swank-allegro.lisp (swank-compile-string): For reader errors
Helmut Eller authored
482 (reader-error () nil)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
483
fab0b31 Add multiprocessing support.
Helmut Eller authored
484 ;;;; Definition Finding
485
cd4e839 Some more fixes for Allegro
Helmut Eller authored
486 (defun buffer-or-file (file file-fun buffer-fun)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
487 (let* ((probe (gethash file *temp-file-map*)))
cd4e839 Some more fixes for Allegro
Helmut Eller authored
488 (cond (probe
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
489 (destructuring-bind (buffer start file) probe
490 (declare (ignore file))
cd4e839 Some more fixes for Allegro
Helmut Eller authored
491 (funcall buffer-fun buffer start)))
492 (t (funcall file-fun (namestring (truename file)))))))
493
494 (defun buffer-or-file-location (file offset)
495 (buffer-or-file file
496 (lambda (filename)
497 (make-location `(:file ,filename)
498 `(:position ,(1+ offset))))
499 (lambda (buffer start)
500 (make-location `(:buffer ,buffer)
501 `(:offset ,start ,offset)))))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
502
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
503 (defun fspec-primary-name (fspec)
504 (etypecase fspec
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
505 (symbol fspec)
506 (list (fspec-primary-name (second fspec)))))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
507
7544734 (find-definition-in-file)
Matthias Koeppe authored
508 (defun find-definition-in-file (fspec type file top-level)
509 (let* ((part
510 (or (scm::find-definition-in-definition-group
511 fspec type (scm:section-file :file file)
512 :top-level top-level)
513 (scm::find-definition-in-definition-group
514 (fspec-primary-name fspec)
515 type (scm:section-file :file file)
516 :top-level top-level)))
517 (start (and part
518 (scm::source-part-start part)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
519 (pos (if start
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
520 (list :position (1+ start))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
521 (list :function-name (string (fspec-primary-name fspec))))))
522 (make-location (list :file (namestring (truename file)))
523 pos)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
524
7544734 (find-definition-in-file)
Matthias Koeppe authored
525 (defun find-fspec-location (fspec type file top-level)
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
526 (handler-case
527 (etypecase file
528 (pathname
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
529 (let ((probe (gethash file *temp-file-map*)))
530 (cond (probe
531 (destructuring-bind (buffer offset file) probe
532 (declare (ignore file))
533 (make-location `(:buffer ,buffer)
534 `(:offset ,offset 0))))
535 (t
536 (find-definition-in-file fspec type file top-level)))))
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
537 ((member :top-level)
5d60829 Even more long line breaking.
Helmut Eller authored
538 (make-error-location "Defined at toplevel: ~A"
539 (fspec->string fspec))))
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
540 (error (e)
541 (make-error-location "Error: ~A" e))))
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
542
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
543 (defun fspec->string (fspec)
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
544 (typecase fspec
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
545 (symbol (let ((*package* (find-package :keyword)))
546 (prin1-to-string fspec)))
547 (list (format nil "(~A ~A)"
548 (prin1-to-string (first fspec))
549 (let ((*package* (find-package :keyword)))
3109766 Try to use source-level debugging features in Allegro 8.2
Helmut Eller authored
550 (prin1-to-string (second fspec)))))
551 (t (princ-to-string fspec))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
552
437f909 Remove stupid conflicts.
Helmut Eller authored
553 (defun fspec-definition-locations (fspec)
b909530 (fspec-definition-locations): Handle
Matthias Koeppe authored
554 (cond
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
555 ((and (listp fspec)
556 (eql (car fspec) :top-level-form))
dd44b5f @stassats * swank-allegro.lisp (fspec-definition-locations): Default
stassats authored
557 (destructuring-bind (top-level-form file &optional (position 0)) fspec
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
558 (declare (ignore top-level-form))
cd4e839 Some more fixes for Allegro
Helmut Eller authored
559 `((,fspec
560 ,(buffer-or-file-location file position)))))
af85d10 @stassats swank-allegro.lisp: Use new function `make-error-location'.
stassats authored
561 ((and (listp fspec) (eq (car fspec) :internal))
562 (destructuring-bind (_internal next _n) fspec
563 (declare (ignore _internal _n))
564 (fspec-definition-locations next)))
565 (t
566 (let ((defs (excl::find-source-file fspec)))
567 (when (and (null defs)
568 (listp fspec)
569 (string= (car fspec) '#:method))
570 ;; If methods are defined in a defgeneric form, the source location is
571 ;; recorded for the gf but not for the methods. Therefore fall back to
572 ;; the gf as the likely place of definition.
573 (setq defs (excl::find-source-file (second fspec))))
574 (if (null defs)
575 (list
576 (list fspec
577 (make-error-location "Unknown source location for ~A"
578 (fspec->string fspec))))
ab49718 Handle src-locs of compiler warnings in Allegro 8.2.
Helmut Eller authored
579 (loop for (fspec type file top-level) in defs collect
580 (list (list type fspec)
581 (find-fspec-location fspec type file top-level))))))))
8052a9e Minor modifications.
Helmut Eller authored
582
583 (defimplementation find-definitions (symbol)
584 (fspec-definition-locations symbol))
fab0b31 Add multiprocessing support.
Helmut Eller authored
585
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
586 ;;;; XREF
f912c9c New file.
Helmut Eller authored
587
8052a9e Minor modifications.
Helmut Eller authored
588 (defmacro defxref (name relation name1 name2)
589 `(defimplementation ,name (x)
590 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
591
592 (defxref who-calls :calls :wild x)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
593 (defxref calls-who :calls x :wild)
8052a9e Minor modifications.
Helmut Eller authored
594 (defxref who-references :uses :wild x)
595 (defxref who-binds :binds :wild x)
596 (defxref who-macroexpands :macro-calls :wild x)
597 (defxref who-sets :sets :wild x)
598
599 (defun xref-result (fspecs)
600 (loop for fspec in fspecs
601 append (fspec-definition-locations fspec)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
602
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
603 ;; list-callers implemented by groveling through all fbound symbols.
604 ;; Only symbols are considered. Functions in the constant pool are
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
605 ;; searched recursively. Closure environments are ignored at the
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
606 ;; moment (constants in methods are therefore not found).
607
608 (defun map-function-constants (function fn depth)
609 "Call FN with the elements of FUNCTION's constant pool."
610 (do ((i 0 (1+ i))
611 (max (excl::function-constant-count function)))
612 ((= i max))
613 (let ((c (excl::function-constant function i)))
614 (cond ((and (functionp c)
615 (not (eq c function))
616 (plusp depth))
617 (map-function-constants c fn (1- depth)))
618 (t
619 (funcall fn c))))))
620
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
621 (defun in-constants-p (fun symbol)
622 (map-function-constants fun
623 (lambda (c)
624 (when (eq c symbol)
625 (return-from in-constants-p t)))
626 3))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
627
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
628 (defun function-callers (name)
629 (let ((callers '()))
630 (do-all-symbols (sym)
631 (when (fboundp sym)
632 (let ((fn (fdefinition sym)))
633 (when (in-constants-p fn name)
634 (push sym callers)))))
635 callers))
636
637 (defimplementation list-callers (name)
638 (xref-result (function-callers name)))
639
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
640 (defimplementation list-callees (name)
641 (let ((result '()))
642 (map-function-constants (fdefinition name)
643 (lambda (c)
644 (when (fboundp c)
645 (push c result)))
646 2)
647 (xref-result result)))
648
d5c9af3 they are pointless when we are compiling via a temporary file.
Matthias Koeppe authored
649 ;;;; Profiling
650
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
651 ;; Per-function profiling based on description in
5d60829 Even more long line breaking.
Helmut Eller authored
652 ;; http://www.franz.com/support/documentation/8.0/\
653 ;; doc/runtime-analyzer.htm#data-collection-control-2
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
654
655 (defvar *profiled-functions* ())
656 (defvar *profile-depth* 0)
657
658 (defmacro with-redirected-y-or-n-p (&body body)
659 ;; If the profiler is restarted when the data from the previous
660 ;; session is not reported yet, the user is warned via Y-OR-N-P.
661 ;; As the CL:Y-OR-N-P question is (for some reason) not directly
662 ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
663 ;; overruled.
ca8b7d7 @stassats * swank-allegro.lisp (with-redirected-y-or-n-p): Fix modern-mode
stassats authored
664 `(let* ((pkg (find-package :common-lisp))
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
665 (saved-pdl (excl::package-definition-lock pkg))
666 (saved-ynp (symbol-function 'cl:y-or-n-p)))
667 (setf (excl::package-definition-lock pkg) nil
ca8b7d7 @stassats * swank-allegro.lisp (with-redirected-y-or-n-p): Fix modern-mode
stassats authored
668 (symbol-function 'cl:y-or-n-p)
669 (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
670 (unwind-protect
ca8b7d7 @stassats * swank-allegro.lisp (with-redirected-y-or-n-p): Fix modern-mode
stassats authored
671 (progn ,@body)
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
672 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
673 (excl::package-definition-lock pkg) saved-pdl))))
674
675 (defun start-acl-profiler ()
676 (with-redirected-y-or-n-p
677 (prof:start-profiler :type :time :count t
678 :start-sampling-p nil :verbose nil)))
679 (defun acl-profiler-active-p ()
680 (not (eq (prof:profiler-status :verbose nil) :inactive)))
681
682 (defun stop-acl-profiler ()
683 (prof:stop-profiler :verbose nil))
684
685 (excl:def-fwrapper profile-fwrapper (&rest args)
686 ;; Ensures sampling is done during the execution of the function,
687 ;; taking into account recursion.
688 (declare (ignore args))
689 (cond ((zerop *profile-depth*)
690 (let ((*profile-depth* (1+ *profile-depth*)))
691 (prof:start-sampling)
692 (unwind-protect (excl:call-next-fwrapper)
693 (prof:stop-sampling))))
694 (t
695 (excl:call-next-fwrapper))))
696
697 (defimplementation profile (fname)
698 (unless (acl-profiler-active-p)
699 (start-acl-profiler))
700 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
701 (push fname *profiled-functions*))
702
703 (defimplementation profiled-functions ()
704 *profiled-functions*)
705
706 (defimplementation unprofile (fname)
707 (excl:funwrap fname 'profile-fwrapper)
708 (setq *profiled-functions* (remove fname *profiled-functions*)))
709
d5c9af3 they are pointless when we are compiling via a temporary file.
Matthias Koeppe authored
710 (defimplementation profile-report ()
be83e05 Profiling functions on Allegro (except for profile-package). From
Helmut Eller authored
711 (prof:show-flat-profile :verbose nil)
712 (when *profiled-functions*
713 (start-acl-profiler)))
714
715 (defimplementation profile-reset ()
716 (when (acl-profiler-active-p)
717 (stop-acl-profiler)
718 (start-acl-profiler))
719 "Reset profiling counters.")
d5c9af3 they are pointless when we are compiling via a temporary file.
Matthias Koeppe authored
720
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
721 ;;;; Inspecting
722
0758964 * swank-allegro.lisp (fspec-definition-locations): add declare
Helmut Eller authored
723 (excl:without-redefinition-warnings
0c75cea Inspector cleanups.
Helmut Eller authored
724 (defmethod emacs-inspect ((o t))
0758964 * swank-allegro.lisp (fspec-definition-locations): add declare
Helmut Eller authored
725 (allegro-inspect o)))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
726
0c75cea Inspector cleanups.
Helmut Eller authored
727 (defmethod emacs-inspect ((o function))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
728 (allegro-inspect o))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
729
0c75cea Inspector cleanups.
Helmut Eller authored
730 (defmethod emacs-inspect ((o standard-object))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
731 (allegro-inspect o))
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored
732
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
733 (defun allegro-inspect (o)
734 (loop for (d dd) on (inspect::inspect-ctl o)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
735 append (frob-allegro-field-def o d)
736 until (eq d dd)))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
737
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
738 (defun frob-allegro-field-def (object def)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
739 (with-struct (inspect::field-def- name type access) def
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
740 (ecase type
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
741 ((:unsigned-word :unsigned-byte :unsigned-natural
04e47df * swank-allegro.lisp (frob-allegro-field-def): Add missing type to
Helmut Eller authored
742 :unsigned-long :unsigned-half-long
743 :unsigned-3byte :unsigned-long32)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
744 (label-value-line name (inspect::component-ref-v object access type)))
0be4e49 * swank-allegro.lisp (frob-allegro-field-def): There seems to be a
Helmut Eller authored
745 ((:lisp :value :func)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
746 (label-value-line name (inspect::component-ref object access)))
747 (:indirect
748 (destructuring-bind (prefix count ref set) access
749 (declare (ignore set prefix))
750 (loop for i below (funcall count object)
751 append (label-value-line (format nil "~A-~D" name i)
752 (funcall ref object i))))))))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
753
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
754 ;;;; Multithreading
fab0b31 Add multiprocessing support.
Helmut Eller authored
755
344b94e (initialize-multiprocessing): Update for new api.
Marco Baringer authored
756 (defimplementation initialize-multiprocessing (continuation)
757 (mp:start-scheduler)
758 (funcall continuation))
fab0b31 Add multiprocessing support.
Helmut Eller authored
759
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
760 (defimplementation spawn (fn &key name)
68dd370 Removed fwrapper-based code for inheriting "swankiness" to newly
Luke Gorrie authored
761 (mp:process-run-function name fn))
fab0b31 Add multiprocessing support.
Helmut Eller authored
762
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
763 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
764 (defvar *thread-id-counter* 0)
765
766 (defimplementation thread-id (thread)
767 (mp:with-process-lock (*id-lock*)
768 (or (getf (mp:process-property-list thread) 'id)
769 (setf (getf (mp:process-property-list thread) 'id)
770 (incf *thread-id-counter*)))))
771
772 (defimplementation find-thread (id)
773 (find id mp:*all-processes*
774 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
775
64ff730 Update for modified thread interface.
Helmut Eller authored
776 (defimplementation thread-name (thread)
777 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
778
64ff730 Update for modified thread interface.
Helmut Eller authored
779 (defimplementation thread-status (thread)
31b41bd @stassats * slime.el (slime-update-threads-buffer): New formatting, with labels
stassats authored
780 (princ-to-string (mp:process-whostate thread)))
781
782 (defimplementation thread-attributes (thread)
783 (list :priority (mp:process-priority thread)
784 :times-resumed (mp:process-times-resumed thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
785
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
786 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
787 (mp:make-process-lock :name name))
788
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
789 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
790 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
791
792 (defimplementation current-thread ()
793 mp:*current-process*)
794
795 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
796 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
797
798 (defimplementation interrupt-thread (thread fn)
799 (mp:process-interrupt thread fn))
800
52dc1fc (kill-thread): Implemented.
Helmut Eller authored
801 (defimplementation kill-thread (thread)
802 (mp:process-kill thread))
803
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
804 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
805
806 (defstruct (mailbox (:conc-name mailbox.))
564f63c * swank-allegro.lisp:(receive-if): Periodically check for interrupts.
Helmut Eller authored
807 (lock (mp:make-process-lock :name "process mailbox"))
808 (queue '() :type list)
5b361b3 Fix typo.
Helmut Eller authored
809 (gate (mp:make-gate nil)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
810
811 (defun mailbox (thread)
812 "Return THREAD's mailbox."
813 (mp:with-process-lock (*mailbox-lock*)
814 (or (getf (mp:process-property-list thread) 'mailbox)
815 (setf (getf (mp:process-property-list thread) 'mailbox)
816 (make-mailbox)))))
817
818 (defimplementation send (thread message)
564f63c * swank-allegro.lisp:(receive-if): Periodically check for interrupts.
Helmut Eller authored
819 (let* ((mbox (mailbox thread)))
820 (mp:with-process-lock ((mailbox.lock mbox))
821 (setf (mailbox.queue mbox)
822 (nconc (mailbox.queue mbox) (list message)))
823 (mp:open-gate (mailbox.gate mbox)))))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
824
66297c5 * swank-openmcl.lisp (receive-if): Support timeout argument.
Helmut Eller authored
825 (defimplementation receive-if (test &optional timeout)
1812184 Add some flow-control.
Helmut Eller authored
826 (let ((mbox (mailbox mp:*current-process*)))
66297c5 * swank-openmcl.lisp (receive-if): Support timeout argument.
Helmut Eller authored
827 (assert (or (not timeout) (eq timeout t)))
564f63c * swank-allegro.lisp:(receive-if): Periodically check for interrupts.
Helmut Eller authored
828 (loop
829 (check-slime-interrupts)
830 (mp:with-process-lock ((mailbox.lock mbox))
831 (let* ((q (mailbox.queue mbox))
832 (tail (member-if test q)))
833 (when tail
834 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
835 (return (car tail)))
836 (mp:close-gate (mailbox.gate mbox))))
66297c5 * swank-openmcl.lisp (receive-if): Support timeout argument.
Helmut Eller authored
837 (when (eq timeout t) (return (values nil t)))
838 (mp:process-wait-with-timeout "receive-if" 0.5
839 #'mp:gate-open-p (mailbox.gate mbox)))))
1812184 Add some flow-control.
Helmut Eller authored
840
8f7df46 Add a "sentinel thread" to protect access to global lists.
Helmut Eller authored
841 (let ((alist '())
842 (lock (mp:make-process-lock :name "register-thread")))
843
844 (defimplementation register-thread (name thread)
845 (declare (type symbol name))
846 (mp:with-process-lock (lock)
847 (etypecase thread
848 (null
849 (setf alist (delete name alist :key #'car)))
850 (mp:process
851 (let ((probe (assoc name alist)))
852 (cond (probe (setf (cdr probe) thread))
853 (t (setf alist (acons name thread alist))))))))
854 nil)
855
856 (defimplementation find-registered (name)
857 (mp:with-process-lock (lock)
858 (cdr (assoc name alist)))))
859
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored
860 (defimplementation set-default-initial-binding (var form)
cd89cf1 * swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
Helmut Eller authored
861 (push (cons var form)
862 #+(version>= 9 0)
863 excl:*required-thread-bindings*
864 #-(version>= 9 0)
865 excl::required-thread-bindings))
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored
866
9decabc See ChangeLog entry 2004-04-06 Marco Baringer
Marco Baringer authored
867 (defimplementation quit-lisp ()
868 (excl:exit 0 :quiet t))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
869
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
870
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
871 ;;Trace implementations
872 ;;In Allegro 7.0, we have:
873 ;; (trace <name>)
874 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
875 ;; (trace ((labels <name> <label-name>)))
876 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
877 ;; <name> can be a normal name or a (setf name)
878
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
879 (defimplementation toggle-trace (spec)
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
880 (ecase (car spec)
881 ((setf)
882 (toggle-trace-aux spec))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
883 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
884 ((setf :defmethod :labels :flet)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
885 (toggle-trace-aux (process-fspec-for-allegro spec)))
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
886 (:call
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
887 (destructuring-bind (caller callee) (cdr spec)
888 (toggle-trace-aux callee
889 :inside (list (process-fspec-for-allegro caller)))))))
890
891 (defun tracedp (fspec)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
892 (member fspec (eval '(trace)) :test #'equal))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
893
894 (defun toggle-trace-aux (fspec &rest args)
895 (cond ((tracedp fspec)
896 (eval `(untrace ,fspec))
897 (format nil "~S is now untraced." fspec))
898 (t
899 (eval `(trace (,fspec ,@args)))
900 (format nil "~S is now traced." fspec))))
901
902 (defun toggle-trace-generic-function-methods (name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
903 (let ((methods (mop:generic-function-methods (fdefinition name))))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
904 (cond ((tracedp name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
905 (eval `(untrace ,name))
906 (dolist (method methods (format nil "~S is now untraced." name))
907 (excl:funtrace (mop:method-function method))))
908 (t
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
909 (eval `(trace (,name)))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
910 (dolist (method methods (format nil "~S is now traced." name))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
911 (excl:ftrace (mop:method-function method)))))))
912
913 (defun process-fspec-for-allegro (fspec)
914 (cond ((consp fspec)
915 (ecase (first fspec)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
916 ((setf) fspec)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
917 ((:defun :defgeneric) (second fspec))
918 ((:defmethod) `(method ,@(rest fspec)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
919 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
920 ,(third fspec)))
921 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
922 ,(third fspec)))))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
923 (t
924 fspec)))
b7ebf32 * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
Helmut Eller authored
925
926
927 ;;;; Weak hashtables
928
929 (defimplementation make-weak-key-hash-table (&rest args)
930 (apply #'make-hash-table :weak-keys t args))
931
932 (defimplementation make-weak-value-hash-table (&rest args)
933 (apply #'make-hash-table :values :weak args))
cfdb2c4 (character-completion-set): Implement it.
Matthias Koeppe authored
934
8428f90 Added hash-table-weakness and use it in hash-table-inspecting
Attila Lendvai authored
935 (defimplementation hash-table-weakness (hashtable)
936 (cond ((excl:hash-table-weak-keys hashtable) :key)
937 ((eq (excl:hash-table-values hashtable) :weak) :value)))
938
939
cfdb2c4 (character-completion-set): Implement it.
Matthias Koeppe authored
940
941 ;;;; Character names
942
943 (defimplementation character-completion-set (prefix matchp)
944 (loop for name being the hash-keys of excl::*name-to-char-table*
945 when (funcall matchp prefix name)
946 collect (string-capitalize name)))
Something went wrong with that request. Please try again.