Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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