Skip to content
Newer
Older
100644 911 lines (765 sloc) 32 KB
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored Jul 5, 2005
1 ;;; -*- indent-tabs-mode: nil -*-
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 en…
Helmut Eller authored Mar 9, 2004
11 (in-package :swank-backend)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
55bf49e Use *gray-stream-symbols* instead of enumerating them in each backend.
Helmut Eller authored Sep 22, 2005
14 (require "comm")
15 (import-from :stream *gray-stream-symbols* :swank-backend))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
16
fafbcd3 (emacs-connected): Set sigint handler only for single threaded
Helmut Eller authored Nov 24, 2004
17 (import-swank-mop-symbols :clos '(:slot-definition-documentation
5fb2e15 swank-lispworks.lisp: wrapper functions for swank-mop
Martin Simmons authored Jan 15, 2009
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 Nov 24, 2004
21 :eql-specializer
06e774c (swank-mop:compute-applicable-methods-using-classes): Implement it.
Helmut Eller authored Feb 22, 2005
22 :eql-specializer-object
23 :compute-applicable-methods-using-classes))
05bc052 Set up the swank-mop package.
Martin Simmons authored Sep 13, 2004
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 Jan 15, 2009
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 Feb 22, 2005
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 Sep 17, 2004
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 Aug 9, 2008
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…
Helmut Eller authored Jun 30, 2004
64
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
65 ;;; TCP server
66
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored Mar 9, 2004
67 (defimplementation preferred-communication-style ()
68 :spawn)
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
69
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
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 Feb 8, 2004
75 (defimplementation create-socket (host port)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
76 (multiple-value-bind (socket where errno)
526a135 (create-socket): Work around bug in comm::create-tcp-socket-for-servi…
Martin Simmons authored Dec 21, 2004
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 Jan 13, 2004
81 (cond (socket socket)
b6bf550 (create-socket): Fix condition message.
Helmut Eller authored Jan 13, 2004
82 (t (error 'network-error
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
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 Jan 13, 2004
86 errno))))))
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
87
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored Jan 19, 2004
88 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
89 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
90
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored Jan 19, 2004
91 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
92 (comm::close-socket (socket-fd socket)))
93
635b29f (list-callers-internal): Return the function if dspec:object-dspec
Helmut Eller authored Nov 29, 2004
94 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored Aug 10, 2006
95 &key external-format buffering timeout)
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored Oct 4, 2008
96 (declare (ignore buffering))
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored Nov 19, 2004
97 (let* ((fd (comm::get-fd-from-socket socket)))
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored Jan 13, 2004
98 (assert (/= fd -1))
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored Oct 4, 2008
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 Jan 13, 2004
124
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored Nov 19, 2006
125 ;;; Coding Systems
126
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored Oct 4, 2008
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 Nov 19, 2006
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 Jan 18, 2004
147 ;;; Unix signals
148
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
149 (defun sigint-handler ()
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
150 (with-simple-restart (continue "Continue from SIGINT handler.")
151 (invoke-debugger "SIGINT")))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
152
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
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 Dec 31, 2008
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 Mar 5, 2004
172 (defimplementation getpid ()
173 #+win32 (win32:get-current-process-id)
174 #-win32 (system::getpid))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
175
3fb29a2 * slime.el: Various bits of support for maintaining multiple SLIME
Helmut Eller authored Feb 24, 2004
176 (defimplementation lisp-implementation-type-name ()
177 "lispworks")
178
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
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 Apr 30, 2004
182 ;;;; Documentation
183
6372ed6 @stassats swank-lispworks.lisp (replace-strings-with-symbols): Didn't work on
stassats authored Sep 28, 2009
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 Sep 2, 2009
191 (defun replace-strings-with-symbols (tree)
6372ed6 @stassats swank-lispworks.lisp (replace-strings-with-symbols): Didn't work on
stassats authored Sep 28, 2009
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 Sep 2, 2009
204
05bc052 Set up the swank-mop package.
Martin Simmons authored Sep 13, 2004
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 en…
Helmut Eller authored Mar 9, 2004
207 (etypecase arglist
3f16659 (arglist): Return :not-available if the arglist cannot be determined.
Helmut Eller authored Apr 25, 2004
208 ((member :dont-know)
209 :not-available)
210 (list
9b43099 @stassats * swank-lispworks.lisp (replace-strings-with-symbols): New function for
stassats authored Sep 2, 2009
211 (replace-strings-with-symbols arglist)))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
212
05bc052 Set up the swank-mop package.
Martin Simmons authored Sep 13, 2004
213 (defimplementation function-name (function)
214 (nth-value 2 (function-lambda-expression function)))
215
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored Jan 19, 2004
216 (defimplementation macroexpand-all (form)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
217 (walker:walk-form form))
218
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored Mar 25, 2004
219 (defun generic-function-p (object)
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
220 (typep object 'generic-function))
221
7cf16c3 Updated to use `defimplementation'.
Luke Gorrie authored Jan 19, 2004
222 (defimplementation describe-symbol-for-emacs (symbol)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Sep 15, 2008
230 (let ((string (or (documentation sym kind))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Mar 23, 2004
241 :generic-function (if (and (fboundp symbol)
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored Mar 25, 2004
242 (generic-function-p (fdefinition symbol)))
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
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 Mar 25, 2004
246 (not (generic-function-p (fdefinition symbol))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
247 (doc 'function)))
248 (maybe-push
f8c9312 (describe-symbol-for-emacs): Include information about setf-functions…
Helmut Eller authored Jun 30, 2004
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 Nov 27, 2003
253 :class (if (find-class symbol nil)
254 (doc 'class)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored Mar 9, 2004
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…
Helmut Eller authored Jun 30, 2004
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 en…
Helmut Eller authored Mar 9, 2004
263
264 (defun describe-function (symbol)
265 (cond ((fboundp symbol)
d97256c * swank-lispworks.lisp (describe-function): Don't use
Helmut Eller authored Oct 31, 2008
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 en…
Helmut Eller authored Mar 9, 2004
269 (documentation symbol 'function))
86f2dd5 (spawn): Remove CL symbols from mp:*process-initial-bindings*, to
Helmut Eller authored Mar 27, 2004
270 (describe (fdefinition symbol)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored Mar 9, 2004
271 (t (format t "~S is not fbound" symbol))))
272
273 (defun describe-symbol (sym)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 en…
Helmut Eller authored Mar 9, 2004
281 (describe-function sym)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
282
283 ;;; Debugging
284
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
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 Aug 9, 2008
293 (defmethod env-internals:environment-display-notifier
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
294 ((env slime-env) &key restarts condition)
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored Aug 9, 2008
295 (declare (ignore restarts condition))
4c0c2f2 *** empty log message ***
Helmut Eller authored Aug 11, 2008
296 (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
297 ;; nil
eaf984c * swank-lispworks.lisp (defimplementation): Record location.
Helmut Eller authored Aug 9, 2008
298 )
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
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 Aug 9, 2008
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 Aug 9, 2008
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 Feb 24, 2005
310
2410a8e (install-debugger-globally): hook into the environment globally to ca…
Martin Simmons authored Jul 2, 2008
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 Mar 3, 2004
315 (defvar *sldb-top-frame*)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
316
317 (defun interesting-frame-p (frame)
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
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 Nov 27, 2003
328
f18968b (find-top-frame): New function used to hide debugger internal frames.
Helmut Eller authored May 1, 2004
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 Jun 27, 2004
333 ((or (not frame)
334 (and (interesting-frame-p frame) (zerop i)))
335 frame)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
336
f18968b (find-top-frame): New function used to hide debugger internal frames.
Helmut Eller authored May 1, 2004
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 Apr 5, 2005
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 May 1, 2004
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 en…
Helmut Eller authored Mar 9, 2004
357 (defimplementation compute-backtrace (start end)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Oct 17, 2008
365 (push frame backtrace)))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
366
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
367 (defun frame-actual-args (frame)
4fd7ad6 (frame-actual-args): Bind *break-on-signals* to nil and special case
Helmut Eller authored Jul 1, 2004
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 Aug 4, 2004
374 (error (e) (format nil "<~A>" arg))))))
4fd7ad6 (frame-actual-args): Bind *break-on-signals* to nil and special case
Helmut Eller authored Jul 1, 2004
375 (dbg::call-frame-arglist frame))))
89b931a (emacs-connected): Add default method to
Helmut Eller authored Mar 23, 2004
376
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored Oct 17, 2008
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 Nov 27, 2003
383
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored Jun 25, 2004
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 Jan 19, 2004
387 (defimplementation frame-locals (n)
f3a6882 (getpid, emacs-connected): Conditionalize for Windows. Patch from Bill
Helmut Eller authored Mar 5, 2004
388 (let ((frame (nth-frame n)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
389 (if (dbg::call-frame-p frame)
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored Jun 25, 2004
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 Nov 27, 2003
402
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored Jun 21, 2009
403 (defimplementation frame-source-location (frame)
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
404 (let ((frame (nth-frame frame))
405 (callee (if (plusp frame) (nth-frame (1- frame)))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
406 (if (dbg::call-frame-p frame)
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
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 Mar 3, 2004
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 en…
Helmut Eller authored Mar 9, 2004
419 (return-frame (dbg::find-frame-for-return frame)))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored Mar 3, 2004
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 Nov 27, 2003
426
16d3f08 * swank-lispworks.lisp (disassemble-frame): Implemented.
Helmut Eller authored Aug 9, 2008
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 Jan 21, 2004
433 ;;; Definition finding
434
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
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 Nov 27, 2003
447
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored Mar 9, 2004
448 (defimplementation find-definitions (name)
1c976ab (find-definitions): Some tweaking.
Helmut Eller authored Mar 10, 2004
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 Nov 30, 2003
452
38c01bf Implement call-with-compilation-hooks.
Martin Simmons authored Sep 8, 2004
453
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
454 ;;; Compilation
455
d7417bd (dspec-stream-position): New function to make source location work fo…
Martin Simmons authored Jun 9, 2004
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 Oct 16, 2008
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 fo…
Martin Simmons authored Jun 9, 2004
465
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored Jan 10, 2009
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 Mar 2, 2010
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 Jan 10, 2009
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 Oct 16, 2008
474 :external-format external-format)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
475
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored May 4, 2005
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 Aug 10, 2005
484 (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored May 4, 2005
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 Sep 8, 2004
494 (defimplementation call-with-compilation-hooks (function)
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored May 4, 2005
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 Sep 8, 2004
502
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Mar 27, 2008
507 (funcall fn filename dspec (if (consp c) (car c) c))))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Dec 4, 2003
512 (error :error)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 Oct 4, 2008
524 (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
525
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
526 (defun compile-from-temp-file (string filename)
527 (unwind-protect
528 (progn
2eff8be UTF-8 support for Lispworks.
Helmut Eller authored Oct 4, 2008
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 Nov 27, 2003
533 (write-string string s)
534 (finish-output s))
5cb11c9 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored Oct 16, 2008
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 Dec 4, 2003
539 (when binary-filename
5cb11c9 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored Oct 16, 2008
540 (delete-file binary-filename))
541 (not failure?)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
542 (delete-file filename)))
543
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored Sep 17, 2008
544 (defun dspec-function-name-position (dspec fallback)
8cbb478 more tweaking.
Helmut Eller authored Mar 10, 2004
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 Mar 25, 2004
547 (typecase name
8cbb478 more tweaking.
Helmut Eller authored Mar 10, 2004
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 Sep 17, 2008
550 (t fallback))))
551 (null fallback)
8cbb478 more tweaking.
Helmut Eller authored Mar 10, 2004
552 (symbol (list :function-name (string dspec)))))
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
553
fc66307 (with-fairly-standard-io-syntax): New macro. Like
Luke Gorrie authored Jun 17, 2004
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 Sep 17, 2008
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 Aug 1, 2004
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 fo…
Martin Simmons authored Jun 9, 2004
573 (defun dspec-stream-position (stream dspec)
fc66307 (with-fairly-standard-io-syntax): New macro. Like
Luke Gorrie authored Jun 17, 2004
574 (with-fairly-standard-io-syntax
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored Sep 17, 2008
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 Jun 17, 2004
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 fo…
Martin Simmons authored Jun 9, 2004
598
57b781c Minor refactoring.
Helmut Eller authored Aug 1, 2004
599 (defun dspec-file-position (file dspec)
2da6155 (dspec-file-position): Bind *compile-file-pathname*,
Marco Baringer authored Feb 4, 2007
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 Sep 17, 2008
609 (list :position (1+ pos))
610 (dspec-function-name-position dspec `(:position 1)))))))
57b781c Minor refactoring.
Helmut Eller authored Aug 1, 2004
611
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored Mar 1, 2004
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 Nov 15, 2004
616 (defun make-dspec-location (dspec location &optional hints)
57b781c Minor refactoring.
Helmut Eller authored Aug 1, 2004
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 Nov 15, 2004
624 (dspec-file-position file dspec)
625 hints))))
57b781c Minor refactoring.
Helmut Eller authored Aug 1, 2004
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 Sep 17, 2008
632 (dspec-function-name-position dspec `(:offset ,offset 0))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
633 hints)))))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored Mar 3, 2004
634
d7417bd (dspec-stream-position): New function to make source location work fo…
Martin Simmons authored Jun 9, 2004
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 May 4, 2005
645 (defun signal-error-data-base (database &optional location)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
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 May 4, 2005
651 (make-dspec-progenitor-location dspec (or location filename))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
652 condition))))
653
b15897a beautify undefined function warnings in LW
Edi Weitz authored May 4, 2005
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 Nov 24, 2007
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 May 4, 2005
661 (defun signal-undefined-functions (htab &optional filename)
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
662 (maphash (lambda (unfun dspecs)
663 (dolist (dspec dspecs)
664 (signal-compiler-condition
b15897a beautify undefined function warnings in LW
Edi Weitz authored May 4, 2005
665 (format nil "Undefined function ~A" (unmangle-unfun unfun))
8b4126a call-with-compilation-hooks: better implementation for LW
Edi Weitz authored May 4, 2005
666 (make-dspec-progenitor-location dspec
667 (or filename
668 (gethash (list unfun dspec)
669 *undefined-functions-hash*)))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
670 nil)))
671 htab))
3992f62 (make-dspec-location): Handle logical pathnames.
Helmut Eller authored Nov 28, 2003
672
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored Jan 8, 2009
673 (defimplementation swank-compile-string (string &key buffer position filename
674 policy)
675 (declare (ignore filename policy))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
676 (assert buffer)
677 (assert position)
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored Mar 9, 2004
678 (let* ((location (list :emacs-buffer buffer position string))
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored Mar 3, 2004
679 (tmpname (hcl:make-temp-file nil "lisp")))
d7417bd (dspec-stream-position): New function to make source location work fo…
Martin Simmons authored Jun 9, 2004
680 (with-swank-compilation-unit (location)
3dd7de0 (call-with-debugging-environment): Bind *sldb-top-frame*.
Helmut Eller authored Mar 3, 2004
681 (compile-from-temp-file
f1670dc (swank-compile-string): Bind *print-radix* to t, to avoid problems if
Helmut Eller authored Mar 22, 2005
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 fo…
Martin Simmons authored Jun 9, 2004
688 tmpname))))
cc43d38 First version.
Helmut Eller authored Nov 27, 2003
689
97a6e80 Xref support.
Helmut Eller authored Nov 29, 2003
690 ;;; xref
691
8052a9e Minor modifications.
Helmut Eller authored Mar 9, 2004
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 fo…
Martin Simmons authored Jun 9, 2004
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 Feb 28, 2005
698 (defxref calls-who hcl:calls-who)
d7417bd (dspec-stream-position): New function to make source location work fo…
Martin Simmons authored Jun 9, 2004
699 (defxref list-callers list-callers-internal)
e5cffa7 @stassats * swank-lispworks.lisp (list-callers-internal): Fix for LW6.
stassats authored Jul 22, 2010
700 (defxref list-callees list-callees-internal)
d7417bd (dspec-stream-position): New function to make source location work fo…
Martin Simmons authored Jun 9, 2004
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 Nov 2, 2010
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 fo…
Martin Simmons authored Jun 9, 2004
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 Nov 29, 2004
718 (or (dspec:object-dspec object) object)))))
8052a9e Minor modifications.
Helmut Eller authored Mar 9, 2004
719
e5cffa7 @stassats * swank-lispworks.lisp (list-callers-internal): Fix for LW6.
stassats authored Jul 22, 2010
720 (defun list-callees-internal (name)
2a71053 * swank-lispworks.lisp (list-callers-internal): Revert to previous
Martin Simmons authored Nov 2, 2010
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 Jul 22, 2010
732
5f28bff (create-socket, set-sigint-handler, who-references, who-binds)
Helmut Eller authored Mar 25, 2004
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 Mar 23, 2004
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 Mar 9, 2004
744 (defun xref-results (dspecs)
635b29f (list-callers-internal): Return the function if dspec:object-dspec
Helmut Eller authored Nov 29, 2004
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 Feb 24, 2005
752
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored Mar 1, 2004
753 ;;; Inspector
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored Sep 14, 2004
754
0c75cea Inspector cleanups.
Helmut Eller authored Feb 9, 2008
755 (defmethod emacs-inspect ((o t))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
756 (lispworks-inspect o))
757
0c75cea Inspector cleanups.
Helmut Eller authored Feb 9, 2008
758 (defmethod emacs-inspect ((o function))
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
759 (lispworks-inspect o))
760
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored Feb 10, 2006
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 Feb 9, 2008
763 (defmethod emacs-inspect ((o standard-object))
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored Feb 10, 2006
764 (lispworks-inspect o))
765
9ddb31e (emacs-connected, make-stream-interactive): Move the soft-force-output
Helmut Eller authored Nov 15, 2004
766 (defun lispworks-inspect (o)
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored Mar 1, 2004
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 Nov 15, 2004
770 (append
771 (label-value-line "Type" type)
718e9ec (lispworks-inspect): Fix hanging caused by
Martin Simmons authored May 17, 2007
772 (loop for name in names
773 for value in values
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored Feb 9, 2008
774 append (label-value-line name value)))))
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored Mar 1, 2004
775
427fc2e (quit-lisp): Implemented.
Luke Gorrie authored Jun 17, 2004
776 ;;; Miscellaneous
777
778 (defimplementation quit-lisp ()
779 (lispworks:quit))
780
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
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 Feb 28, 2005
786 ((:defmethod) `(method ,(cdr fspec)))))
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
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 Feb 28, 2005
791 (defun toggle-trace-aux (dspec)
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
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 Feb 28, 2005
799 (defimplementation toggle-trace (fspec)
800 (toggle-trace-aux (parse-fspec fspec)))
89e015f (slime-env): New class.
Helmut Eller authored Feb 24, 2005
801
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
802 ;;; Multithreading
803
b1d4f81 (initialize-multiprocessing): Update for new API.
Marco Baringer authored Oct 20, 2006
804 (defimplementation initialize-multiprocessing (continuation)
fde8e35 (initialize-multiprocessing): Don't init MP if it is already running.
Helmut Eller authored Oct 21, 2006
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 Jan 18, 2004
810
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
811 (defimplementation spawn (fn &key name)
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored Jan 10, 2009
812 (mp:process-run-function name () fn))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
813
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored Jun 27, 2004
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 Feb 7, 2004
827 (defimplementation thread-name (thread)
828 (mp:process-name thread))
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
829
64ff730 Update for modified thread interface.
Helmut Eller authored Feb 7, 2004
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 Jan 18, 2004
834
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
835 (defimplementation make-lock (&key name)
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
836 (mp:make-lock :name name))
837
644d8cc (make-sigint-handler): New function.
Helmut Eller authored Jan 21, 2004
838 (defimplementation call-with-lock-held (lock function)
1c66c9e (sigint-handler): Bind a continue restart.
Helmut Eller authored Jan 18, 2004
839 (mp:with-lock (lock) (funcall function)))
97a6e80 Xref support.
Helmut Eller authored Nov 29, 2003
840
a2debb3 *** empty log message ***
Helmut Eller authored Jan 31, 2004
841 (defimplementation current-thread ()
842 mp:*current-process*)
843
64ff730 Update for modified thread interface.
Helmut Eller authored Feb 7, 2004
844 (defimplementation all-threads ()
845 (mp:list-all-processes))
846
a2debb3 *** empty log message ***
Helmut Eller authored Jan 31, 2004
847 (defimplementation interrupt-thread (thread fn)
848 (mp:process-interrupt thread fn))
849
c0efaf0 (dspec-buffer-position): Handle defgeneric.
Helmut Eller authored Mar 1, 2004
850 (defimplementation kill-thread (thread)
851 (mp:process-kill thread))
852
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored Mar 4, 2004
853 (defimplementation thread-alive-p (thread)
854 (mp:process-alive-p thread))
855
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored Aug 4, 2008
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 Jan 31, 2004
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 Aug 4, 2008
866 (make-mailbox)))))
a2debb3 *** empty log message ***
Helmut Eller authored Jan 31, 2004
867
8fcf89e * swank.lisp (wait-for-event): Add timeout argument. This is used
Helmut Eller authored Aug 11, 2008
868 (defimplementation receive-if (test &optional timeout)
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored Aug 4, 2008
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 Aug 11, 2008
871 (assert (or (not timeout) (eq timeout t)))
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored Aug 4, 2008
872 (loop
5b27209 Queue interrupts in various places.
Helmut Eller authored Aug 6, 2008
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 Aug 11, 2008
880 (when (eq timeout t) (return (values nil t)))
5b27209 Queue interrupts in various places.
Helmut Eller authored Aug 6, 2008
881 (mp:process-wait-with-timeout
2903ff0 * slime.el ([test] find-definition.2): Also fails for Lispworks.
Helmut Eller authored Dec 31, 2008
882 "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
aced5b4 * swank-lispworks.lisp (receive-if): Handle interrupts.
Helmut Eller authored Aug 4, 2008
883
884 (defimplementation send (thread message)
885 (let ((mbox (mailbox thread)))
5b27209 Queue interrupts in various places.
Helmut Eller authored Aug 6, 2008
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 Jan 31, 2004
889
bd661cf * swank-backend.lisp (set-default-initial-binding): New function.
Helmut Eller authored Jan 10, 2009
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 Jul 2, 2009
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 Feb 24, 2005
899 ;;; Some intergration with the lispworks environment
900
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored Jul 5, 2005
901 (defun swank-sym (name) (find-symbol (string name) :swank))
b291c1e (env-internals:confirm-p): Fix last change (hopefully).
Matthias Koeppe authored Aug 29, 2005
902
c3ec5f3 weak hash tables for LispWorks
Edi Weitz authored Dec 15, 2006
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.