Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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