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