Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 911 lines (765 sloc) 32.818 kb
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
1 ;;; -*- indent-tabs-mode: nil -*-
cc43d38 First version.
Helmut Eller authored
2 ;;;
3 ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4 ;;;
5 ;;; Created 2003, Helmut Eller
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
11 (in-package :swank-backend)
cc43d38 First version.
Helmut Eller authored
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
55bf49e Use *gray-stream-symbols* instead of enumerating them in each backend.
Helmut Eller authored
14 (require "comm")
15 (import-from :stream *gray-stream-symbols* :swank-backend))
cc43d38 First version.
Helmut Eller authored
16
fafbcd3 (emacs-connected): Set sigint handler only for single threaded
Helmut Eller authored
17 (import-swank-mop-symbols :clos '(:slot-definition-documentation
5fb2e15 swank-lispworks.lisp: wrapper functions for swank-mop
Martin Simmons authored
18 :slot-boundp-using-class
19 :slot-value-using-class
20 :slot-makunbound-using-class
fafbcd3 (emacs-connected): Set sigint handler only for single threaded
Helmut Eller authored
21 :eql-specializer
06e774c (swank-mop:compute-applicable-methods-using-classes): Implement it.
Helmut Eller authored
22 :eql-specializer-object
23 :compute-applicable-methods-using-classes))
05bc052 Set up the swank-mop package.
Martin Simmons authored
24
25 (defun swank-mop:slot-definition-documentation (slot)
26 (documentation slot t))
27
5fb2e15 swank-lispworks.lisp: wrapper functions for swank-mop
Martin Simmons authored
28 (defun swank-mop:slot-boundp-using-class (class object slotd)
29 (clos:slot-boundp-using-class class object
30 (clos:slot-definition-name slotd)))
31
32 (defun swank-mop:slot-value-using-class (class object slotd)
33 (clos:slot-value-using-class class object
34 (clos:slot-definition-name slotd)))
35
36 (defun (setf swank-mop:slot-value-using-class) (value class object slotd)
37 (setf (clos:slot-value-using-class class object
38 (clos:slot-definition-name slotd))
39 value))
40
41 (defun swank-mop:slot-makunbound-using-class (class object slotd)
42 (clos:slot-makunbound-using-class class object
43 (clos:slot-definition-name slotd)))
44
06e774c (swank-mop:compute-applicable-methods-using-classes): Implement it.
Helmut Eller authored
45 (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
46 (clos::compute-applicable-methods-from-classes gf classes))
47
48 ;; lispworks doesn't have the eql-specializer class, it represents
49 ;; them as a list of `(EQL ,OBJECT)
1a51744 (swank-mop): Export specializer-direct-methods.
Marco Baringer authored
50 (deftype swank-mop:eql-specializer () 'cons)
51
52 (defun swank-mop:eql-specializer-object (eql-spec)
53 (second eql-spec))
54
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored
55 (eval-when (:compile-toplevel :execute :load-toplevel)
56 (defvar *original-defimplementation* (macro-function 'defimplementation))
57 (defmacro defimplementation (&whole whole name args &body body
58 &environment env)
59 (declare (ignore args body))
60 `(progn
61 (dspec:record-definition '(defun ,name) (dspec:location)
62 :check-redefinition-p nil)
63 ,(funcall *original-defimplementation* whole env))))
f8c9312 (describe-symbol-for-emacs): Include information about setf-functions st...
Helmut Eller authored
64
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
65 ;;; TCP server
66
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
67 (defimplementation preferred-communication-style ()
68 :spawn)
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
69
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
70 (defun socket-fd (socket)
71 (etypecase socket
72 (fixnum socket)
73 (comm:socket-stream (comm:socket-stream-socket socket))))
74
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
75 (defimplementation create-socket (host port)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
76 (multiple-value-bind (socket where errno)
526a135 (create-socket): Work around bug in comm::create-tcp-socket-for-service ...
Martin Simmons authored
77 #-(or lispworks4.1 (and macosx lispworks4.3))
78 (comm::create-tcp-socket-for-service port :address host)
79 #+(or lispworks4.1 (and macosx lispworks4.3))
80 (comm::create-tcp-socket-for-service port)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
81 (cond (socket socket)
b6bf550 (create-socket): Fix condition message.
Helmut Eller authored
82 (t (error 'network-error
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
83 :format-control "~A failed: ~A (~D)"
84 :format-arguments (list where
85 (list #+unix (lw:get-unix-error errno))
b6bf550 (create-socket): Fix condition message.
Helmut Eller authored
86 errno))))))
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
87
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored
88 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
89 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
90
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored
91 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
92 (comm::close-socket (socket-fd socket)))
93
635b29f (list-callers-internal): Return the function if dspec:object-dspec
Helmut Eller authored
94 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
95 &key external-format buffering timeout)
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored
96 (declare (ignore buffering))
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
97 (let* ((fd (comm::get-fd-from-socket socket)))
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
98 (assert (/= fd -1))
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored
99 (assert (valid-external-format-p external-format))
100 (cond ((member (first external-format) '(:latin-1 :ascii))
101 (make-instance 'comm:socket-stream
102 :socket fd
103 :direction :io
104 :read-timeout timeout
105 :element-type 'base-char))
106 (t
107 (make-flexi-stream
108 (make-instance 'comm:socket-stream
109 :socket fd
110 :direction :io
111 :read-timeout timeout
112 :element-type '(unsigned-byte 8))
113 external-format)))))
114
115 (defun make-flexi-stream (stream external-format)
116 (unless (member :flexi-streams *features*)
117 (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
118 external-format))
119 (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
120 stream
121 :external-format
122 (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
123 external-format)))
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
124
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
125 ;;; Coding Systems
126
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored
127 (defun valid-external-format-p (external-format)
128 (member external-format *external-format-to-coding-system*
129 :test #'equal :key #'car))
130
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
131 (defvar *external-format-to-coding-system*
132 '(((:latin-1 :eol-style :lf)
133 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
134 ((:latin-1)
135 "latin-1" "iso-latin-1" "iso-8859-1")
136 ((:utf-8) "utf-8")
137 ((:utf-8 :eol-style :lf) "utf-8-unix")
138 ((:euc-jp) "euc-jp")
139 ((:euc-jp :eol-style :lf) "euc-jp-unix")
140 ((:ascii) "us-ascii")
141 ((:ascii :eol-style :lf) "us-ascii-unix")))
142
143 (defimplementation find-external-format (coding-system)
144 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
145 *external-format-to-coding-system*)))
146
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
147 ;;; Unix signals
148
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
149 (defun sigint-handler ()
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
150 (with-simple-restart (continue "Continue from SIGINT handler.")
151 (invoke-debugger "SIGINT")))
cc43d38 First version.
Helmut Eller authored
152
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
153 (defun make-sigint-handler (process)
154 (lambda (&rest args)
155 (declare (ignore args))
156 (mp:process-interrupt process #'sigint-handler)))
157
2903ff0 * slime.el ([test] find-definition.2): Also fails for Lispworks.
Helmut Eller authored
158 (defun set-sigint-handler ()
159 ;; Set SIGINT handler on Swank request handler thread.
160 #-win32
161 (sys::set-signal-handler +sigint+
162 (make-sigint-handler mp:*current-process*)))
163
164 #-win32
165 (defimplementation install-sigint-handler (handler)
166 (sys::set-signal-handler +sigint+
167 (let ((self mp:*current-process*))
168 (lambda (&rest args)
169 (declare (ignore args))
170 (mp:process-interrupt self handler)))))
171
f3a6882 (getpid, emacs-connected): Conditionalize for Windows. Patch from Bill
Helmut Eller authored
172 (defimplementation getpid ()
173 #+win32 (win32:get-current-process-id)
174 #-win32 (system::getpid))
cc43d38 First version.
Helmut Eller authored
175
3fb29a2 * slime.el: Various bits of support for maintaining multiple SLIME
Helmut Eller authored
176 (defimplementation lisp-implementation-type-name ()
177 "lispworks")
178
89b931a (emacs-connected): Add default method to
Helmut Eller authored
179 (defimplementation set-default-directory (directory)
180 (namestring (hcl:change-directory directory)))
181
ccec519 (emacs-connected): Add methods to stream-soft-force-output for
Helmut Eller authored
182 ;;;; Documentation
183
6372ed6 @stassats swank-lispworks.lisp (replace-strings-with-symbols): Didn't work on
stassats authored
184 (defun map-list (function list)
185 "Map over proper and not proper lists."
186 (loop for (car . cdr) on list
187 collect (funcall function car) into result
188 when (null cdr) return result
189 when (atom cdr) return (nconc result (funcall function cdr))))
190
9b43099 @stassats * swank-lispworks.lisp (replace-strings-with-symbols): New function for
stassats authored
191 (defun replace-strings-with-symbols (tree)
6372ed6 @stassats swank-lispworks.lisp (replace-strings-with-symbols): Didn't work on
stassats authored
192 (map-list
193 (lambda (x)
194 (typecase x
195 (list
196 (replace-strings-with-symbols x))
197 (symbol
198 x)
199 (string
200 (intern x))
201 (t
202 (intern (write-to-string x)))))
203 tree))
9b43099 @stassats * swank-lispworks.lisp (replace-strings-with-symbols): New function for
stassats authored
204
05bc052 Set up the swank-mop package.
Martin Simmons authored
205 (defimplementation arglist (symbol-or-function)
206 (let ((arglist (lw:function-lambda-list symbol-or-function)))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
207 (etypecase arglist
3f16659 (arglist): Return :not-available if the arglist cannot be determined.
Helmut Eller authored
208 ((member :dont-know)
209 :not-available)
210 (list
9b43099 @stassats * swank-lispworks.lisp (replace-strings-with-symbols): New function for
stassats authored
211 (replace-strings-with-symbols arglist)))))
cc43d38 First version.
Helmut Eller authored
212
05bc052 Set up the swank-mop package.
Martin Simmons authored
213 (defimplementation function-name (function)
214 (nth-value 2 (function-lambda-expression function)))
215
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored
216 (defimplementation macroexpand-all (form)
cc43d38 First version.
Helmut Eller authored
217 (walker:walk-form form))
218
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored
219 (defun generic-function-p (object)
89b931a (emacs-connected): Add default method to
Helmut Eller authored
220 (typep object 'generic-function))
221
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored
222 (defimplementation describe-symbol-for-emacs (symbol)
cc43d38 First version.
Helmut Eller authored
223 "Return a plist describing SYMBOL.
224 Return NIL if the symbol is unbound."
225 (let ((result '()))
226 (labels ((first-line (string)
227 (let ((pos (position #\newline string)))
228 (if (null pos) string (subseq string 0 pos))))
229 (doc (kind &optional (sym symbol))
3185fb3 * swank-lispworks.lisp (describe-symbol-for-emacs): Revert last
Helmut Eller authored
230 (let ((string (or (documentation sym kind))))
cc43d38 First version.
Helmut Eller authored
231 (if string
232 (first-line string)
233 :not-documented)))
234 (maybe-push (property value)
235 (when value
236 (setf result (list* property value result)))))
237 (maybe-push
238 :variable (when (boundp symbol)
239 (doc 'variable)))
240 (maybe-push
89b931a (emacs-connected): Add default method to
Helmut Eller authored
241 :generic-function (if (and (fboundp symbol)
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored
242 (generic-function-p (fdefinition symbol)))
89b931a (emacs-connected): Add default method to
Helmut Eller authored
243 (doc 'function)))
244 (maybe-push
245 :function (if (and (fboundp symbol)
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored
246 (not (generic-function-p (fdefinition symbol))))
cc43d38 First version.
Helmut Eller authored
247 (doc 'function)))
248 (maybe-push
f8c9312 (describe-symbol-for-emacs): Include information about setf-functions st...
Helmut Eller authored
249 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
250 (if (fboundp setf-name)
251 (doc 'setf))))
252 (maybe-push
cc43d38 First version.
Helmut Eller authored
253 :class (if (find-class symbol nil)
254 (doc 'class)))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
255 result)))
256
257 (defimplementation describe-definition (symbol type)
258 (ecase type
259 (:variable (describe-symbol symbol))
260 (:class (describe (find-class symbol)))
f8c9312 (describe-symbol-for-emacs): Include information about setf-functions st...
Helmut Eller authored
261 ((:function :generic-function) (describe-function symbol))
262 (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
263
264 (defun describe-function (symbol)
265 (cond ((fboundp symbol)
d97256c * swank-lispworks.lisp (describe-function): Don't use
Helmut Eller authored
266 (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
267 symbol
268 (lispworks:function-lambda-list symbol)
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
269 (documentation symbol 'function))
86f2dd5 (spawn): Remove CL symbols from mp:*process-initial-bindings*, to
Helmut Eller authored
270 (describe (fdefinition symbol)))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
271 (t (format t "~S is not fbound" symbol))))
272
273 (defun describe-symbol (sym)
cc43d38 First version.
Helmut Eller authored
274 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
275 (when (boundp sym)
276 (format t "~%~%Value: ~A" (symbol-value sym)))
277 (let ((doc (documentation sym 'variable)))
278 (when doc
279 (format t "~%~%Variable documentation:~%~A" doc)))
280 (when (fboundp sym)
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
281 (describe-function sym)))
cc43d38 First version.
Helmut Eller authored
282
283 ;;; Debugging
284
89e015f (slime-env): New class.
Helmut Eller authored
285 (defclass slime-env (env:environment)
286 ((debugger-hook :initarg :debugger-hoook)))
287
288 (defun slime-env (hook io-bindings)
289 (make-instance 'slime-env :name "SLIME Environment"
290 :io-bindings io-bindings
291 :debugger-hoook hook))
292
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored
293 (defmethod env-internals:environment-display-notifier
89e015f (slime-env): New class.
Helmut Eller authored
294 ((env slime-env) &key restarts condition)
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored
295 (declare (ignore restarts condition))
4c0c2f2 *** empty log message ***
Helmut Eller authored
296 (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
297 ;; nil
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored
298 )
89e015f (slime-env): New class.
Helmut Eller authored
299
300 (defmethod env-internals:environment-display-debugger ((env slime-env))
301 *debug-io*)
302
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored
303 (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
304 (apply (swank-sym :y-or-n-p-in-emacs) msg args))
305
f8acf96 Display the "Use default debugger" restart more prominently.
Helmut Eller authored
306 (defimplementation call-with-debugger-hook (hook fun)
307 (let ((*debugger-hook* hook))
308 (env:with-environment ((slime-env hook '()))
309 (funcall fun))))
89e015f (slime-env): New class.
Helmut Eller authored
310
2410a8e (install-debugger-globally): hook into the environment globally to catch...
Martin Simmons authored
311 (defimplementation install-debugger-globally (function)
312 (setq *debugger-hook* function)
313 (setf (env:environment) (slime-env function '())))
314
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
315 (defvar *sldb-top-frame*)
cc43d38 First version.
Helmut Eller authored
316
317 (defun interesting-frame-p (frame)
89b931a (emacs-connected): Add default method to
Helmut Eller authored
318 (cond ((or (dbg::call-frame-p frame)
319 (dbg::derived-call-frame-p frame)
320 (dbg::foreign-frame-p frame)
321 (dbg::interpreted-call-frame-p frame))
322 t)
323 ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
324 ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
325 ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
326 ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
327 (t nil)))
cc43d38 First version.
Helmut Eller authored
328
f18968b (find-top-frame): New function used to hide debugger internal frames.
Helmut Eller authored
329 (defun nth-next-frame (frame n)
330 "Unwind FRAME N times."
331 (do ((frame frame (dbg::frame-next frame))
332 (i n (if (interesting-frame-p frame) (1- i) i)))
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
333 ((or (not frame)
334 (and (interesting-frame-p frame) (zerop i)))
335 frame)))
cc43d38 First version.
Helmut Eller authored
336
f18968b (find-top-frame): New function used to hide debugger internal frames.
Helmut Eller authored
337 (defun nth-frame (index)
338 (nth-next-frame *sldb-top-frame* index))
339
340 (defun find-top-frame ()
341 "Return the most suitable top-frame for the debugger."
dce3cf1 (find-top-frame): If we can't find an invoke-debugger frame we take
Marco Baringer authored
342 (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
343 (nth-next-frame frame 1)))
344 ((or (null frame) ; no frame found!
345 (and (dbg::call-frame-p frame)
346 (eq (dbg::call-frame-function-name frame)
347 'invoke-debugger)))
348 (nth-next-frame frame 1)))
349 ;; if we can't find a invoke-debugger frame, take any old frame at the top
350 (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
f18968b (find-top-frame): New function used to hide debugger internal frames.
Helmut Eller authored
351
352 (defimplementation call-with-debugging-environment (fn)
353 (dbg::with-debugger-stack ()
354 (let ((*sldb-top-frame* (find-top-frame)))
355 (funcall fn))))
356
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
357 (defimplementation compute-backtrace (start end)
cc43d38 First version.
Helmut Eller authored
358 (let ((end (or end most-positive-fixnum))
359 (backtrace '()))
360 (do ((frame (nth-frame start) (dbg::frame-next frame))
361 (i start))
362 ((or (not frame) (= i end)) (nreverse backtrace))
363 (when (interesting-frame-p frame)
364 (incf i)
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
365 (push frame backtrace)))))
cc43d38 First version.
Helmut Eller authored
366
89b931a (emacs-connected): Add default method to
Helmut Eller authored
367 (defun frame-actual-args (frame)
4fd7ad6 (frame-actual-args): Bind *break-on-signals* to nil and special case
Helmut Eller authored
368 (let ((*break-on-signals* nil))
369 (mapcar (lambda (arg)
370 (case arg
371 ((&rest &optional &key) arg)
372 (t
373 (handler-case (dbg::dbg-eval arg frame)
3fceffe (frame-actual-args): Correct syntax for handler-case.
Martin Simmons authored
374 (error (e) (format nil "<~A>" arg))))))
4fd7ad6 (frame-actual-args): Bind *break-on-signals* to nil and special case
Helmut Eller authored
375 (dbg::call-frame-arglist frame))))
89b931a (emacs-connected): Add default method to
Helmut Eller authored
376
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
377 (defimplementation print-frame (frame stream)
378 (cond ((dbg::call-frame-p frame)
379 (format stream "~S ~S"
380 (dbg::call-frame-function-name frame)
381 (frame-actual-args frame)))
382 (t (princ frame stream))))
cc43d38 First version.
Helmut Eller authored
383
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
384 (defun frame-vars (frame)
385 (first (dbg::frame-locals-format-list frame #'list 75 0)))
386
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored
387 (defimplementation frame-locals (n)
f3a6882 (getpid, emacs-connected): Conditionalize for Windows. Patch from Bill
Helmut Eller authored
388 (let ((frame (nth-frame n)))
cc43d38 First version.
Helmut Eller authored
389 (if (dbg::call-frame-p frame)
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
390 (mapcar (lambda (var)
391 (destructuring-bind (name value symbol location) var
392 (declare (ignore name location))
393 (list :name symbol :id 0
394 :value value)))
395 (frame-vars frame)))))
396
397 (defimplementation frame-var-value (frame var)
398 (let ((frame (nth-frame frame)))
399 (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
400 (declare (ignore _n _s _l))
401 value)))
cc43d38 First version.
Helmut Eller authored
402
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored
403 (defimplementation frame-source-location (frame)
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
404 (let ((frame (nth-frame frame))
405 (callee (if (plusp frame) (nth-frame (1- frame)))))
cc43d38 First version.
Helmut Eller authored
406 (if (dbg::call-frame-p frame)
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
407 (let ((dspec (dbg::call-frame-function-name frame))
408 (cname (and (dbg::call-frame-p callee)
409 (dbg::call-frame-function-name callee))))
410 (if dspec
411 (frame-location dspec cname))))))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
412
413 (defimplementation eval-in-frame (form frame-number)
414 (let ((frame (nth-frame frame-number)))
415 (dbg::dbg-eval form frame)))
416
417 (defimplementation return-from-frame (frame-number form)
418 (let* ((frame (nth-frame frame-number))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
419 (return-frame (dbg::find-frame-for-return frame)))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
420 (dbg::dbg-return-from-call-frame frame form return-frame
421 dbg::*debugger-stack*)))
422
423 (defimplementation restart-frame (frame-number)
424 (let ((frame (nth-frame frame-number)))
425 (dbg::restart-frame frame :same-args t)))
cc43d38 First version.
Helmut Eller authored
426
16d3f08 * swank-lispworks.lisp (disassemble-frame): Implemented.
Helmut Eller authored
427 (defimplementation disassemble-frame (frame-number)
428 (let* ((frame (nth-frame frame-number)))
429 (when (dbg::call-frame-p frame)
430 (let ((function (dbg::get-call-frame-function frame)))
431 (disassemble function)))))
432
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
433 ;;; Definition finding
434
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
435 (defun frame-location (dspec callee-name)
436 (let ((infos (dspec:find-dspec-locations dspec)))
437 (cond (infos
438 (destructuring-bind ((rdspec location) &rest _) infos
439 (declare (ignore _))
440 (let ((name (and callee-name (symbolp callee-name)
441 (string callee-name))))
442 (make-dspec-location rdspec location
443 `(:call-site ,name)))))
444 (t
445 (list :error (format nil "Source location not available for: ~S"
446 dspec))))))
cc43d38 First version.
Helmut Eller authored
447
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
448 (defimplementation find-definitions (name)
1c976ab (find-definitions): Some tweaking.
Helmut Eller authored
449 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
450 (loop for (dspec location) in locations
451 collect (list dspec (make-dspec-location dspec location)))))
ed76e57 Use the new format for source locations. Implement the
Helmut Eller authored
452
38c01bf Implement call-with-compilation-hooks.
Martin Simmons authored
453
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
454 ;;; Compilation
455
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
456 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
457 (lw:rebinding (location)
458 `(let ((compiler::*error-database* '()))
459 (with-compilation-unit ,options
5cb11c9 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
460 (multiple-value-prog1 (progn ,@body)
461 (signal-error-data-base compiler::*error-database*
462 ,location)
463 (signal-undefined-functions compiler::*unknown-functions*
464 ,location))))))
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
465
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
466 (defimplementation swank-compile-file (input-file output-file
20bed40 @stassats * slime.el (slime-compile-and-load-file): Accept C-u arguments for
stassats authored
467 load-p external-format
468 &key policy)
469 (declare (ignore policy))
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
470 (with-swank-compilation-unit (input-file)
471 (compile-file input-file
472 :output-file output-file
473 :load load-p
e3c38ae * swank-backend.lisp (swank-compile-file): Return the same
Helmut Eller authored
474 :external-format external-format)))
cc43d38 First version.
Helmut Eller authored
475
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
476 (defvar *within-call-with-compilation-hooks* nil
477 "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
478
479 (defvar *undefined-functions-hash* nil
480 "Hash table to map info about undefined functions to pathnames.")
481
482 (lw:defadvice (compile-file compile-file-and-collect-notes :around)
483 (pathname &rest rest)
148a69e (defadvice compile-file): Return all values from the real compile-file.
Martin Simmons authored
484 (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
485 (when *within-call-with-compilation-hooks*
486 (maphash (lambda (unfun dspecs)
487 (dolist (dspec dspecs)
488 (let ((unfun-info (list unfun dspec)))
489 (unless (gethash unfun-info *undefined-functions-hash*)
490 (setf (gethash unfun-info *undefined-functions-hash*)
491 pathname)))))
492 compiler::*unknown-functions*))))
493
38c01bf Implement call-with-compilation-hooks.
Martin Simmons authored
494 (defimplementation call-with-compilation-hooks (function)
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
495 (let ((compiler::*error-database* '())
496 (*undefined-functions-hash* (make-hash-table :test 'equal))
497 (*within-call-with-compilation-hooks* t))
498 (with-compilation-unit ()
499 (prog1 (funcall function)
500 (signal-error-data-base compiler::*error-database*)
501 (signal-undefined-functions compiler::*unknown-functions*)))))
38c01bf Implement call-with-compilation-hooks.
Martin Simmons authored
502
cc43d38 First version.
Helmut Eller authored
503 (defun map-error-database (database fn)
504 (loop for (filename . defs) in database do
505 (loop for (dspec . conditions) in defs do
506 (dolist (c conditions)
82514a5 (map-error-database): Make mapping work for LispWorks 5.1 too.
Martin Simmons authored
507 (funcall fn filename dspec (if (consp c) (car c) c))))))
cc43d38 First version.
Helmut Eller authored
508
509 (defun lispworks-severity (condition)
510 (cond ((not condition) :warning)
511 (t (etypecase condition
cfc6e78 (toggle-trace-fdefinition, tracedp): New support functions for
Helmut Eller authored
512 (error :error)
cc43d38 First version.
Helmut Eller authored
513 (style-warning :warning)
514 (warning :warning)))))
515
516 (defun signal-compiler-condition (message location condition)
517 (check-type message string)
518 (signal
519 (make-instance 'compiler-condition :message message
520 :severity (lispworks-severity condition)
521 :location location
522 :original-condition condition)))
523
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored
524 (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
525
cc43d38 First version.
Helmut Eller authored
526 (defun compile-from-temp-file (string filename)
527 (unwind-protect
528 (progn
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored
529 (with-open-file (s filename :direction :output
530 :if-exists :supersede
531 :external-format *temp-file-format*)
532
cc43d38 First version.
Helmut Eller authored
533 (write-string string s)
534 (finish-output s))
5cb11c9 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
535 (multiple-value-bind (binary-filename warnings? failure?)
536 (compile-file filename :load t
537 :external-format *temp-file-format*)
538 (declare (ignore warnings?))
cfc6e78 (toggle-trace-fdefinition, tracedp): New support functions for
Helmut Eller authored
539 (when binary-filename
5cb11c9 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
540 (delete-file binary-filename))
541 (not failure?)))
cc43d38 First version.
Helmut Eller authored
542 (delete-file filename)))
543
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
544 (defun dspec-function-name-position (dspec fallback)
8cbb478 more tweaking.
Helmut Eller authored
545 (etypecase dspec
546 (cons (let ((name (dspec:dspec-primary-name dspec)))
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored
547 (typecase name
8cbb478 more tweaking.
Helmut Eller authored
548 ((or symbol string)
549 (list :function-name (string name)))
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
550 (t fallback))))
551 (null fallback)
8cbb478 more tweaking.
Helmut Eller authored
552 (symbol (list :function-name (string dspec)))))
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
553
fc66307 (with-fairly-standard-io-syntax): New macro. Like
Luke Gorrie authored
554 (defmacro with-fairly-standard-io-syntax (&body body)
555 "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
556 (let ((package (gensym))
557 (readtable (gensym)))
558 `(let ((,package *package*)
559 (,readtable *readtable*))
560 (with-standard-io-syntax
561 (let ((*package* ,package)
562 (*readtable* ,readtable))
563 ,@body)))))
564
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
565 (defun skip-comments (stream)
566 (let ((pos0 (file-position stream)))
567 (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
568 '(()))
569 (file-position stream (1- (file-position stream))))
570 (t (file-position stream pos0)))))
571
57b781c Minor refactoring.
Helmut Eller authored
572 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
573 (defun dspec-stream-position (stream dspec)
fc66307 (with-fairly-standard-io-syntax): New macro. Like
Luke Gorrie authored
574 (with-fairly-standard-io-syntax
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
575 (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
762d2ab (dspec-stream-position): Remove `with-standard-io-syntax' so that we
Luke Gorrie authored
576 (form (read stream nil '#1=#:eof)))
577 (when (eq form '#1#)
578 (return nil))
579 (labels ((check-dspec (form)
580 (when (consp form)
581 (let ((operator (car form)))
582 (case operator
583 ((progn)
584 (mapcar #'check-dspec
585 (cdr form)))
586 ((eval-when locally macrolet symbol-macrolet)
587 (mapcar #'check-dspec
588 (cddr form)))
589 ((in-package)
590 (let ((package (find-package (second form))))
591 (when package
592 (setq *package* package))))
593 (otherwise
594 (let ((form-dspec (dspec:parse-form-dspec form)))
595 (when (dspec:dspec-equal dspec form-dspec)
596 (return pos)))))))))
597 (check-dspec form))))))
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
598
57b781c Minor refactoring.
Helmut Eller authored
599 (defun dspec-file-position (file dspec)
2da6155 (dspec-file-position): Bind *compile-file-pathname*,
Marco Baringer authored
600 (let* ((*compile-file-pathname* (pathname file))
601 (*compile-file-truename* (truename *compile-file-pathname*))
602 (*load-pathname* *compile-file-pathname*)
603 (*load-truename* *compile-file-truename*))
604 (with-open-file (stream file)
605 (let ((pos
606 #-(or lispworks4.1 lispworks4.2)
607 (dspec-stream-position stream dspec)))
608 (if pos
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
609 (list :position (1+ pos))
610 (dspec-function-name-position dspec `(:position 1)))))))
57b781c Minor refactoring.
Helmut Eller authored
611
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored
612 (defun emacs-buffer-location-p (location)
613 (and (consp location)
614 (eq (car location) :emacs-buffer)))
615
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
616 (defun make-dspec-location (dspec location &optional hints)
57b781c Minor refactoring.
Helmut Eller authored
617 (etypecase location
618 ((or pathname string)
619 (multiple-value-bind (file err)
620 (ignore-errors (namestring (truename location)))
621 (if err
622 (list :error (princ-to-string err))
623 (make-location `(:file ,file)
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
624 (dspec-file-position file dspec)
625 hints))))
57b781c Minor refactoring.
Helmut Eller authored
626 (symbol
627 `(:error ,(format nil "Cannot resolve location: ~S" location)))
628 ((satisfies emacs-buffer-location-p)
629 (destructuring-bind (_ buffer offset string) location
630 (declare (ignore _ string))
631 (make-location `(:buffer ,buffer)
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
632 (dspec-function-name-position dspec `(:offset ,offset 0))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
633 hints)))))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
634
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
635 (defun make-dspec-progenitor-location (dspec location)
636 (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
637 (make-dspec-location
638 (if canon-dspec
639 (if (dspec:local-dspec-p canon-dspec)
640 (dspec:dspec-progenitor canon-dspec)
641 canon-dspec)
642 nil)
643 location)))
644
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
645 (defun signal-error-data-base (database &optional location)
cc43d38 First version.
Helmut Eller authored
646 (map-error-database
647 database
648 (lambda (filename dspec condition)
649 (signal-compiler-condition
650 (format nil "~A" condition)
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
651 (make-dspec-progenitor-location dspec (or location filename))
cc43d38 First version.
Helmut Eller authored
652 condition))))
653
b15897a beautify undefined function warnings in LW
Edi Weitz authored
654 (defun unmangle-unfun (symbol)
655 "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
656 function names like \(SETF GET)."
c6f3f25 Drop remaining dependencies on nregex.
Helmut Eller authored
657 (cond ((sys::setf-symbol-p symbol)
658 (sys::setf-pair-from-underlying-name symbol))
659 (t symbol)))
660
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
661 (defun signal-undefined-functions (htab &optional filename)
cc43d38 First version.
Helmut Eller authored
662 (maphash (lambda (unfun dspecs)
663 (dolist (dspec dspecs)
664 (signal-compiler-condition
b15897a beautify undefined function warnings in LW
Edi Weitz authored
665 (format nil "Undefined function ~A" (unmangle-unfun unfun))
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored
666 (make-dspec-progenitor-location dspec
667 (or filename
668 (gethash (list unfun dspec)
669 *undefined-functions-hash*)))
cc43d38 First version.
Helmut Eller authored
670 nil)))
671 htab))
3992f62 (make-dspec-location): Handle logical pathnames.
Helmut Eller authored
672
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
673 (defimplementation swank-compile-string (string &key buffer position filename
674 policy)
675 (declare (ignore filename policy))
cc43d38 First version.
Helmut Eller authored
676 (assert buffer)
677 (assert position)
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
678 (let* ((location (list :emacs-buffer buffer position string))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
679 (tmpname (hcl:make-temp-file nil "lisp")))
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
680 (with-swank-compilation-unit (location)
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored
681 (compile-from-temp-file
f1670dc (swank-compile-string): Bind *print-radix* to t, to avoid problems if
Helmut Eller authored
682 (with-output-to-string (s)
683 (let ((*print-radix* t))
684 (print `(eval-when (:compile-toplevel)
685 (setq dspec::*location* (list ,@location)))
686 s))
687 (write-string string s))
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
688 tmpname))))
cc43d38 First version.
Helmut Eller authored
689
97a6e80 Xref support.
Helmut Eller authored
690 ;;; xref
691
8052a9e Minor modifications.
Helmut Eller authored
692 (defmacro defxref (name function)
693 `(defimplementation ,name (name)
694 (xref-results (,function name))))
695
696 (defxref who-calls hcl:who-calls)
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
697 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
698 (defxref calls-who hcl:calls-who)
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
699 (defxref list-callers list-callers-internal)
e5cffa7 @stassats * swank-lispworks.lisp (list-callers-internal): Fix for LW6.
stassats authored
700 (defxref list-callees list-callees-internal)
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
701
702 (defun list-callers-internal (name)
703 (let ((callers (make-array 100
704 :fill-pointer 0
705 :adjustable t)))
706 (hcl:sweep-all-objects
707 #'(lambda (object)
708 (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
2a71053 * swank-lispworks.lisp (list-callers-internal): Revert to previous
Martin Simmons authored
709 #+Harlequin-Unix-Lisp (sys:callablep object)
710 #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) (sys:compiled-code-p object)
d7417bd (dspec-stream-position): New function to make source location work for a...
Martin Simmons authored
711 (system::find-constant$funcallable name object))
712 (vector-push-extend object callers))))
713 ;; Delay dspec:object-dspec until after sweep-all-objects
714 ;; to reduce allocation problems.
715 (loop for object across callers
716 collect (if (symbolp object)
717 (list 'function object)
635b29f (list-callers-internal): Return the function if dspec:object-dspec
Helmut Eller authored
718 (or (dspec:object-dspec object) object)))))
8052a9e Minor modifications.
Helmut Eller authored
719
e5cffa7 @stassats * swank-lispworks.lisp (list-callers-internal): Fix for LW6.
stassats authored
720 (defun list-callees-internal (name)
2a71053 * swank-lispworks.lisp (list-callers-internal): Revert to previous
Martin Simmons authored
721 (let ((callees '()))
722 (system::find-constant$funcallable
723 'junk name
724 :test #'(lambda (junk constant)
725 (declare (ignore junk))
726 (when (and (symbolp constant)
727 (fboundp constant))
728 (pushnew (list 'function constant) callees :test 'equal))
729 ;; Return nil so we iterate over all constants.
730 nil))
731 callees))
e5cffa7 @stassats * swank-lispworks.lisp (list-callers-internal): Fix for LW6.
stassats authored
732
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored
733 ;; only for lispworks 4.2 and above
734 #-lispworks4.1
735 (progn
736 (defxref who-references hcl:who-references)
737 (defxref who-binds hcl:who-binds)
738 (defxref who-sets hcl:who-sets))
739
89b931a (emacs-connected): Add default method to
Helmut Eller authored
740 (defimplementation who-specializes (classname)
741 (let ((methods (clos:class-direct-methods (find-class classname))))
742 (xref-results (mapcar #'dspec:object-dspec methods))))
743
8052a9e Minor modifications.
Helmut Eller authored
744 (defun xref-results (dspecs)
635b29f (list-callers-internal): Return the function if dspec:object-dspec
Helmut Eller authored
745 (flet ((frob-locs (dspec locs)
746 (cond (locs
747 (loop for (name loc) in locs
748 collect (list name (make-dspec-location name loc))))
749 (t `((,dspec (:error "Source location not available")))))))
750 (loop for dspec in dspecs
751 append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
89e015f (slime-env): New class.
Helmut Eller authored
752
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored
753 ;;; Inspector
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
754
0c75cea Inspector cleanups.
Helmut Eller authored
755 (defmethod emacs-inspect ((o t))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
756 (lispworks-inspect o))
757
0c75cea Inspector cleanups.
Helmut Eller authored
758 (defmethod emacs-inspect ((o function))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
759 (lispworks-inspect o))
760
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored
761 ;; FIXME: slot-boundp-using-class in LW works with names so we can't
762 ;; use our method in swank.lisp.
0c75cea Inspector cleanups.
Helmut Eller authored
763 (defmethod emacs-inspect ((o standard-object))
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored
764 (lispworks-inspect o))
765
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
766 (defun lispworks-inspect (o)
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored
767 (multiple-value-bind (names values _getter _setter type)
768 (lw:get-inspector-values o nil)
769 (declare (ignore _getter _setter))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored
770 (append
771 (label-value-line "Type" type)
718e9ec (lispworks-inspect): Fix hanging caused by
Martin Simmons authored
772 (loop for name in names
773 for value in values
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
774 append (label-value-line name value)))))
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored
775
427fc2e (quit-lisp): Implemented.
Luke Gorrie authored
776 ;;; Miscellaneous
777
778 (defimplementation quit-lisp ()
779 (lispworks:quit))
780
89e015f (slime-env): New class.
Helmut Eller authored
781 ;;; Tracing
782
783 (defun parse-fspec (fspec)
784 "Return a dspec for FSPEC."
785 (ecase (car fspec)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
786 ((:defmethod) `(method ,(cdr fspec)))))
89e015f (slime-env): New class.
Helmut Eller authored
787
788 (defun tracedp (dspec)
789 (member dspec (eval '(trace)) :test #'equal))
790
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
791 (defun toggle-trace-aux (dspec)
89e015f (slime-env): New class.
Helmut Eller authored
792 (cond ((tracedp dspec)
793 (eval `(untrace ,dspec))
794 (format nil "~S is now untraced." dspec))
795 (t
796 (eval `(trace (,dspec)))
797 (format nil "~S is now traced." dspec))))
798
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
799 (defimplementation toggle-trace (fspec)
800 (toggle-trace-aux (parse-fspec fspec)))
89e015f (slime-env): New class.
Helmut Eller authored
801
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
802 ;;; Multithreading
803
b1d4f81 (initialize-multiprocessing): Update for new API.
Marco Baringer authored
804 (defimplementation initialize-multiprocessing (continuation)
fde8e35 (initialize-multiprocessing): Don't init MP if it is already running.
Helmut Eller authored
805 (cond ((not mp::*multiprocessing*)
806 (push (list "Initialize SLIME" '() continuation)
807 mp:*initial-processes*)
808 (mp:initialize-multiprocessing))
809 (t (funcall continuation))))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
810
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
811 (defimplementation spawn (fn &key name)
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored
812 (mp:process-run-function name () fn))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
813
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
814 (defvar *id-lock* (mp:make-lock))
815 (defvar *thread-id-counter* 0)
816
817 (defimplementation thread-id (thread)
818 (mp:with-lock (*id-lock*)
819 (or (getf (mp:process-plist thread) 'id)
820 (setf (getf (mp:process-plist thread) 'id)
821 (incf *thread-id-counter*)))))
822
823 (defimplementation find-thread (id)
824 (find id (mp:list-all-processes)
825 :key (lambda (p) (getf (mp:process-plist p) 'id))))
826
64ff730 Update for modified thread interface.
Helmut Eller authored
827 (defimplementation thread-name (thread)
828 (mp:process-name thread))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
829
64ff730 Update for modified thread interface.
Helmut Eller authored
830 (defimplementation thread-status (thread)
831 (format nil "~A ~D"
832 (mp:process-whostate thread)
833 (mp:process-priority thread)))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
834
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
835 (defimplementation make-lock (&key name)
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
836 (mp:make-lock :name name))
837
644d8cc (make-sigint-handler): New function.
Helmut Eller authored
838 (defimplementation call-with-lock-held (lock function)
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored
839 (mp:with-lock (lock) (funcall function)))
97a6e80 Xref support.
Helmut Eller authored
840
a2debb3 *** empty log message ***
Helmut Eller authored
841 (defimplementation current-thread ()
842 mp:*current-process*)
843
64ff730 Update for modified thread interface.
Helmut Eller authored
844 (defimplementation all-threads ()
845 (mp:list-all-processes))
846
a2debb3 *** empty log message ***
Helmut Eller authored
847 (defimplementation interrupt-thread (thread fn)
848 (mp:process-interrupt thread fn))
849
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored
850 (defimplementation kill-thread (thread)
851 (mp:process-kill thread))
852
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
853 (defimplementation thread-alive-p (thread)
854 (mp:process-alive-p thread))
855
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored
856 (defstruct (mailbox (:conc-name mailbox.))
857 (mutex (mp:make-lock :name "thread mailbox"))
858 (queue '() :type list))
859
a2debb3 *** empty log message ***
Helmut Eller authored
860 (defvar *mailbox-lock* (mp:make-lock))
861
862 (defun mailbox (thread)
863 (mp:with-lock (*mailbox-lock*)
864 (or (getf (mp:process-plist thread) 'mailbox)
865 (setf (getf (mp:process-plist thread) 'mailbox)
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored
866 (make-mailbox)))))
a2debb3 *** empty log message ***
Helmut Eller authored
867
8fcf89e * swank.lisp (wait-for-event): Add timeout argument. This is used
Helmut Eller authored
868 (defimplementation receive-if (test &optional timeout)
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored
869 (let* ((mbox (mailbox mp:*current-process*))
870 (lock (mailbox.mutex mbox)))
8fcf89e * swank.lisp (wait-for-event): Add timeout argument. This is used
Helmut Eller authored
871 (assert (or (not timeout) (eq timeout t)))
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored
872 (loop
5b27209 Queue interrupts in various places.
Helmut Eller authored
873 (check-slime-interrupts)
874 (mp:with-lock (lock "receive-if/try")
875 (let* ((q (mailbox.queue mbox))
876 (tail (member-if test q)))
877 (when tail
878 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
879 (return (car tail)))))
8fcf89e * swank.lisp (wait-for-event): Add timeout argument. This is used
Helmut Eller authored
880 (when (eq timeout t) (return (values nil t)))
5b27209 Queue interrupts in various places.
Helmut Eller authored
881 (mp:process-wait-with-timeout
2903ff0 * slime.el ([test] find-definition.2): Also fails for Lispworks.
Helmut Eller authored
882 "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored
883
884 (defimplementation send (thread message)
885 (let ((mbox (mailbox thread)))
5b27209 Queue interrupts in various places.
Helmut Eller authored
886 (mp:with-lock ((mailbox.mutex mbox))
887 (setf (mailbox.queue mbox)
888 (nconc (mailbox.queue mbox) (list message))))))
a2debb3 *** empty log message ***
Helmut Eller authored
889
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored
890 (defimplementation set-default-initial-binding (var form)
891 (setq mp:*process-initial-bindings*
892 (acons var `(eval (quote ,form))
893 mp:*process-initial-bindings* )))
894
57cbb3f * swank-lispworks.lisp (thread-attributes): Implemented.
Helmut Eller authored
895 (defimplementation thread-attributes (thread)
896 (list :priority (mp:process-priority thread)
897 :idle (mp:process-idle-time thread)))
898
89e015f (slime-env): New class.
Helmut Eller authored
899 ;;; Some intergration with the lispworks environment
900
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
901 (defun swank-sym (name) (find-symbol (string name) :swank))
b291c1e (env-internals:confirm-p): Fix last change (hopefully).
Matthias Koeppe authored
902
c3ec5f3 weak hash tables for LispWorks
Edi Weitz authored
903
904 ;;;; Weak hashtables
905
906 (defimplementation make-weak-key-hash-table (&rest args)
907 (apply #'make-hash-table :weak-kind :key args))
908
909 (defimplementation make-weak-value-hash-table (&rest args)
910 (apply #'make-hash-table :weak-kind :value args))
Something went wrong with that request. Please try again.